summaryrefslogtreecommitdiffstats
path: root/generic/tclTrace.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTrace.c')
-rw-r--r--generic/tclTrace.c180
1 files changed, 111 insertions, 69 deletions
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index ca1f736..c0cde49 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -10,8 +10,6 @@
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclTrace.c,v 1.57 2009/10/21 13:36:23 dkf Exp $
*/
#include "tclInt.h"
@@ -24,11 +22,11 @@ typedef struct {
int flags; /* Operations for which Tcl command is to be
* invoked. */
size_t length; /* Number of non-NUL chars. in command. */
- char command[4]; /* Space for Tcl command to invoke. Actual
+ char command[1]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
- * structure, so that it can be larger than 4
- * bytes. */
+ * structure, so that it can be larger than 1
+ * byte. */
} TraceVarInfo;
typedef struct {
@@ -58,11 +56,11 @@ typedef struct {
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
- char command[4]; /* Space for Tcl command to invoke. Actual
+ char command[1]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to hold
* command. This field must be the last in the
- * structure, so that it can be larger than 4
- * bytes. */
+ * structure, so that it can be larger than 1
+ * byte. */
} TraceCommandInfo;
/*
@@ -115,7 +113,7 @@ static const char *const traceTypeOptions[] = {
static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
TraceExecutionObjCmd,
TraceCommandObjCmd,
- TraceVariableObjCmd,
+ TraceVariableObjCmd
};
/*
@@ -157,8 +155,8 @@ typedef struct StringTraceData {
#define FOREACH_VAR_TRACE(interp, name, clientData) \
(clientData) = NULL; \
- while (((clientData) = Tcl_VarTraceInfo((interp), (name), 0, \
- TraceVarProc, (clientData))) != NULL)
+ while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \
+ 0, TraceVarProc, (clientData))) != NULL)
#define FOREACH_COMMAND_TRACE(interp, name, clientData) \
(clientData) = NULL; \
@@ -368,8 +366,10 @@ Tcl_TraceObjCmd(
return TCL_OK;
badVarOps:
- Tcl_AppendResult(interp, "bad operations \"", flagOps,
- "\": should be one or more of rwua", NULL);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad operations \"%s\": should be one or more of rwua",
+ flagOps));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
}
@@ -435,9 +435,11 @@ TraceExecutionObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of enter, leave, enterstep, or leavestep",
- TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " enter, leave, enterstep, or leavestep", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
@@ -463,9 +465,8 @@ TraceExecutionObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
- ckalloc((unsigned) (sizeof(TraceCommandInfo)
- - sizeof(tcmdPtr->command) + length + 1));
+ TraceCommandInfo *tcmdPtr = ckalloc(
+ TclOffset(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -478,11 +479,11 @@ TraceExecutionObjCmd(
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
- strcpy(tcmdPtr->command, command);
+ memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
@@ -533,7 +534,7 @@ TraceExecutionObjCmd(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -544,7 +545,7 @@ TraceExecutionObjCmd(
tcmdPtr->flags = 0;
}
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
break;
}
@@ -677,8 +678,11 @@ TraceCommandObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of delete or rename", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " delete or rename", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
@@ -700,9 +704,8 @@ TraceCommandObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
- ckalloc((unsigned) (sizeof(TraceCommandInfo)
- - sizeof(tcmdPtr->command) + length + 1));
+ TraceCommandInfo *tcmdPtr = ckalloc(
+ TclOffset(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
@@ -711,11 +714,11 @@ TraceCommandObjCmd(
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
- strcpy(tcmdPtr->command, command);
+ memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
@@ -746,7 +749,7 @@ TraceCommandObjCmd(
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
break;
}
@@ -843,6 +846,7 @@ TraceVariableObjCmd(
int commandLength, index;
const char *name, *command;
size_t length;
+ ClientData clientData;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
@@ -873,8 +877,11 @@ TraceVariableObjCmd(
return result;
}
if (listLen == 0) {
- Tcl_SetResult(interp, "bad operation list \"\": must be "
- "one or more of array, read, unset, or write", TCL_STATIC);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad operation list \"\": must be one or more of"
+ " array, read, unset, or write", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+ NULL);
return TCL_ERROR;
}
for (i = 0; i < listLen ; i++) {
@@ -900,23 +907,24 @@ TraceVariableObjCmd(
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
- CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)
- ckalloc((unsigned) (sizeof(CombinedTraceVarInfo)
- + length + 1 - sizeof(ctvarPtr->traceCmdInfo.command)));
+ CombinedTraceVarInfo *ctvarPtr = ckalloc(
+ TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+ + 1 + length);
+
ctvarPtr->traceCmdInfo.flags = flags;
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
}
ctvarPtr->traceCmdInfo.length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
- strcpy(ctvarPtr->traceCmdInfo.command, command);
+ memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
ctvarPtr->traceInfo.traceProc = TraceVarProc;
ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo;
ctvarPtr->traceInfo.flags = flags;
name = Tcl_GetString(objv[3]);
if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
!= TCL_OK) {
- ckfree((char *) ctvarPtr);
+ ckfree(ctvarPtr);
return TCL_ERROR;
}
} else {
@@ -926,8 +934,6 @@ TraceVariableObjCmd(
* first one that matches.
*/
- ClientData clientData;
-
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = clientData;
@@ -946,7 +952,6 @@ TraceVariableObjCmd(
break;
}
case TRACE_INFO: {
- ClientData clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
@@ -1113,7 +1118,7 @@ Tcl_TraceCommand(
* Set up trace information.
*/
- tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
+ tracePtr = ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
@@ -1122,8 +1127,18 @@ Tcl_TraceCommand(
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+ /*
+ * Bug 3484621: up the interp's epoch if this is a BC'ed command
+ */
+
+ if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
+ Interp *iPtr = (Interp *) interp;
+ iPtr->compileEpoch++;
+ }
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
+
+
return TCL_OK;
}
@@ -1209,7 +1224,7 @@ Tcl_UntraceCommand(
tracePtr->flags = 0;
if ((--tracePtr->refCount) <= 0) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
if (hasExecTraces) {
@@ -1226,6 +1241,15 @@ Tcl_UntraceCommand(
*/
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
+
+ /*
+ * Bug 3484621: up the interp's epoch if this is a BC'ed command
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ Interp *iPtr = (Interp *) interp;
+ iPtr->compileEpoch++;
+ }
}
}
@@ -1277,9 +1301,9 @@ TraceCommandProc(
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
- Tcl_DStringAppend(&cmd, " rename", 7);
+ TclDStringAppendLiteral(&cmd, " rename");
} else if (flags & TCL_TRACE_DELETE) {
- Tcl_DStringAppend(&cmd, " delete", 7);
+ TclDStringAppendLiteral(&cmd, " delete");
}
/*
@@ -1298,7 +1322,7 @@ TraceCommandProc(
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
/* We ignore errors in these traced commands */
- /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
+ /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/
}
Tcl_DStringFree(&cmd);
}
@@ -1316,7 +1340,7 @@ TraceCommandProc(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -1359,7 +1383,7 @@ TraceCommandProc(
tcmdPtr->refCount--;
}
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
@@ -1451,7 +1475,7 @@ TclCheckExecutionTraces(
traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
command, (Tcl_Command) cmdPtr, objc, objv);
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
}
@@ -1461,7 +1485,11 @@ TclCheckExecutionTraces(
}
iPtr->activeCmdTracePtr = active.nextPtr;
if (state) {
- Tcl_RestoreInterpState(interp, state);
+ if (traceCode == TCL_OK) {
+ (void) Tcl_RestoreInterpState(interp, state);
+ } else {
+ Tcl_DiscardInterpState(state);
+ }
}
return traceCode;
@@ -1694,7 +1722,7 @@ CommandObjTraceDeleted(
TraceCommandInfo *tcmdPtr = clientData;
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
@@ -1777,7 +1805,7 @@ TraceExecutionProc(
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
- ckfree((char *) tcmdPtr->startCmd);
+ ckfree(tcmdPtr->startCmd);
}
}
@@ -1909,7 +1937,7 @@ TraceExecutionProc(
}
if (call) {
if ((--tcmdPtr->refCount) <= 0) {
- ckfree((char *) tcmdPtr);
+ ckfree(tcmdPtr);
}
}
return traceCode;
@@ -1973,24 +2001,24 @@ TraceVarProc(
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
- Tcl_DStringAppend(&cmd, " a", 2);
+ TclDStringAppendLiteral(&cmd, " a");
} else if (flags & TCL_TRACE_READS) {
- Tcl_DStringAppend(&cmd, " r", 2);
+ TclDStringAppendLiteral(&cmd, " r");
} else if (flags & TCL_TRACE_WRITES) {
- Tcl_DStringAppend(&cmd, " w", 2);
+ TclDStringAppendLiteral(&cmd, " w");
} else if (flags & TCL_TRACE_UNSETS) {
- Tcl_DStringAppend(&cmd, " u", 2);
+ TclDStringAppendLiteral(&cmd, " u");
}
} else {
#endif
if (flags & TCL_TRACE_ARRAY) {
- Tcl_DStringAppend(&cmd, " array", 6);
+ TclDStringAppendLiteral(&cmd, " array");
} else if (flags & TCL_TRACE_READS) {
- Tcl_DStringAppend(&cmd, " read", 5);
+ TclDStringAppendLiteral(&cmd, " read");
} else if (flags & TCL_TRACE_WRITES) {
- Tcl_DStringAppend(&cmd, " write", 6);
+ TclDStringAppendLiteral(&cmd, " write");
} else if (flags & TCL_TRACE_UNSETS) {
- Tcl_DStringAppend(&cmd, " unset", 6);
+ TclDStringAppendLiteral(&cmd, " unset");
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
}
@@ -2026,6 +2054,7 @@ TraceVarProc(
}
if (code != TCL_OK) { /* copy error msg to result */
Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
@@ -2135,7 +2164,7 @@ Tcl_CreateObjTrace(
iPtr->tracesForbiddingInline++;
}
- tracePtr = (Trace *) ckalloc(sizeof(Trace));
+ tracePtr = ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
@@ -2198,8 +2227,7 @@ Tcl_CreateTrace(
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
- StringTraceData *data = (StringTraceData *)
- ckalloc(sizeof(StringTraceData));
+ StringTraceData *data = ckalloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
@@ -2556,7 +2584,7 @@ TclCallVarTraces(
char *newPart1;
Tcl_DStringInit(&nameCopy);
- Tcl_DStringAppend(&nameCopy, part1, (p-part1));
+ Tcl_DStringAppend(&nameCopy, part1, p-part1);
newPart1 = Tcl_DStringValue(&nameCopy);
newPart1[offset] = 0;
part1 = newPart1;
@@ -2694,7 +2722,8 @@ TclCallVarTraces(
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
} else {
- Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC);
+ Tcl_SetObjResult((Tcl_Interp *)iPtr,
+ Tcl_NewStringObj(result, -1));
}
Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
@@ -2786,6 +2815,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
Tcl_Interp *interp, /* Interpreter containing variable. */
@@ -2881,6 +2911,16 @@ Tcl_UntraceVar2(
* The code below makes it possible to delete traces while traces are
* active: it makes sure that the deleted trace won't be processed by
* TclCallVarTraces.
+ *
+ * Caveat (Bug 3062331): When an unset trace handler on a variable
+ * tries to delete a different unset trace handler on the same variable,
+ * the results may be surprising. When variable unset traces fire, the
+ * traced variable is already gone. So the TclLookupVar() call above
+ * will not find that variable, and not finding it will never reach here
+ * to perform the deletion. This means callers of Tcl_UntraceVar*()
+ * attempting to delete unset traces from within the handler of another
+ * unset trace have to account for the possibility that their call to
+ * Tcl_UntraceVar*() is a no-op.
*/
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
@@ -2944,6 +2984,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
Tcl_Interp *interp, /* Interpreter containing variable. */
@@ -3052,6 +3093,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#undef Tcl_TraceVar
int
Tcl_TraceVar(
Tcl_Interp *interp, /* Interpreter in which variable is to be
@@ -3109,7 +3151,7 @@ Tcl_TraceVar2(
register VarTrace *tracePtr;
int result;
- tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
+ tracePtr = ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
@@ -3117,7 +3159,7 @@ Tcl_TraceVar2(
result = TraceVarEx(interp, part1, part2, tracePtr);
if (result != TCL_OK) {
- ckfree((char *) tracePtr);
+ ckfree(tracePtr);
}
return result;
}
@@ -3199,7 +3241,7 @@ TraceVarEx(
#endif
tracePtr->flags = tracePtr->flags & flagMask;
- hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew);
+ hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
generated by cgit v0.12 at 2025-10-21 21:19:29 (GMT)