diff options
Diffstat (limited to 'generic/tclTrace.c')
| -rw-r--r-- | generic/tclTrace.c | 1439 |
1 files changed, 824 insertions, 615 deletions
diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 9d7ab86..c0cde49 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -10,27 +10,30 @@ * * 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.26 2005/07/23 00:04:31 dkf Exp $ */ #include "tclInt.h" /* - * Structure used to hold information about variable traces: + * Structures used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NULL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual + size_t length; /* Number of non-NUL chars. in command. */ + 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 { + VarTrace traceInfo; + TraceVarInfo traceCmdInfo; +} CombinedTraceVarInfo; + /* * Structure used to hold information about command traces: */ @@ -38,7 +41,7 @@ typedef struct { typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NULL chars. in command. */ + size_t length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ int startLevel; /* Used for bookkeeping with step execution @@ -53,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; /* @@ -90,12 +93,12 @@ typedef struct { * Forward declarations for functions defined in this file: */ -typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, - int optionIndex, int objc, Tcl_Obj *CONST objv[])); +typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, + int objc, Tcl_Obj *const objv[]); -Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; -Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; -Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; +static Tcl_TraceTypeObjCmd TraceVariableObjCmd; +static Tcl_TraceTypeObjCmd TraceCommandObjCmd; +static Tcl_TraceTypeObjCmd TraceExecutionObjCmd; /* * Each subcommand has a number of 'types' to which it can apply. Currently @@ -104,38 +107,36 @@ Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; * add to the list of supported trace types. */ -static CONST char *traceTypeOptions[] = { - "execution", "command", "variable", (char*) NULL +static const char *const traceTypeOptions[] = { + "execution", "command", "variable", NULL }; -static Tcl_TraceTypeObjCmd* traceSubCmds[] = { - TclTraceExecutionObjCmd, - TclTraceCommandObjCmd, - TclTraceVariableObjCmd, +static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { + TraceExecutionObjCmd, + TraceCommandObjCmd, + TraceVariableObjCmd }; /* * Declarations for local functions to this file: */ -static int CallTraceFunction _ANSI_ARGS_((Tcl_Interp *interp, - Trace *tracePtr, Command *cmdPtr, - CONST char *command, int numChars, - int objc, Tcl_Obj *CONST objv[])); -static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags)); -static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST char *oldName, - CONST char *newName, int flags)); +static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, + Command *cmdPtr, const char *command, int numChars, + int objc, Tcl_Obj *const objv[]); +static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static void TraceCommandProc(ClientData clientData, + Tcl_Interp *interp, const char *oldName, + const char *newName, int flags); static Tcl_CmdObjTraceProc TraceExecutionProc; -static int StringTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, int level, - CONST char* command, Tcl_Command commandInfo, - int objc, Tcl_Obj *CONST objv[])); -static void StringTraceDeleteProc _ANSI_ARGS_(( - ClientData clientData)); -static void DisposeTraceResult _ANSI_ARGS_((int flags, - char *result)); +static int StringTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, + const char *command, Tcl_Command commandInfo, + int objc, Tcl_Obj *const objv[]); +static void StringTraceDeleteProc(ClientData clientData); +static void DisposeTraceResult(int flags, char *result); +static int TraceVarEx(Tcl_Interp *interp, const char *part1, + const char *part2, register VarTrace *tracePtr); /* * The following structure holds the client data for string-based @@ -144,8 +145,23 @@ static void DisposeTraceResult _ANSI_ARGS_((int flags, typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ - Tcl_CmdTraceProc* proc; /* Trace function from Tcl_CreateTrace */ + Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; + +/* + * Convenience macros for iterating over the list of traces. Note that each of + * these *must* be treated as a command, and *must* have a block following it. + */ + +#define FOREACH_VAR_TRACE(interp, name, clientData) \ + (clientData) = NULL; \ + while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \ + 0, TraceVarProc, (clientData))) != NULL) + +#define FOREACH_COMMAND_TRACE(interp, name, clientData) \ + (clientData) = NULL; \ + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, \ + TraceCommandProc, clientData)) != NULL) /* *---------------------------------------------------------------------- @@ -168,21 +184,22 @@ typedef struct StringTraceData { /* ARGSUSED */ int -Tcl_TraceObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_TraceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; - char *name, *flagOps, *p; + const char *name; + const char *flagOps, *p; /* Main sub commands to 'trace' */ - static CONST char *traceOptions[] = { + static const char *const traceOptions[] = { "add", "info", "remove", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif - (char *) NULL + NULL }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { @@ -193,12 +210,12 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, - "option", 0, &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, + &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { @@ -213,14 +230,14 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) int typeIndex; if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 2, objv, "type ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); } case TRACE_INFO: { /* @@ -243,7 +260,7 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); break; } @@ -267,30 +284,29 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) goto badVarOps; } for (p = flagOps; *p != 0; p++) { + Tcl_Obj *opObj; + if (*p == 'r') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("read", -1)); + TclNewLiteralStringObj(opObj, "read"); } else if (*p == 'w') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("write", -1)); + TclNewLiteralStringObj(opObj, "write"); } else if (*p == 'u') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("unset", -1)); + TclNewLiteralStringObj(opObj, "unset"); } else if (*p == 'a') { - Tcl_ListObjAppendElement(NULL, opsList, - Tcl_NewStringObj("array", -1)); + TclNewLiteralStringObj(opObj, "array"); } else { Tcl_DecrRefCount(opsList); goto badVarOps; } + Tcl_ListObjAppendElement(NULL, opsList, opObj); } copyObjv[0] = NULL; memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); copyObjv[4] = opsList; if (optionIndex == TRACE_OLD_VARIABLE) { - code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv); + code = traceSubCmds[2](interp, TRACE_ADD, objc+1, copyObjv); } else { - code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv); + code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv); } Tcl_DecrRefCount(opsList); return code; @@ -305,32 +321,29 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } resultListPtr = Tcl_NewObj(); - clientData = 0; name = Tcl_GetString(objv[2]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + FOREACH_VAR_TRACE(interp, name, clientData) { + TraceVarInfo *tvarPtr = clientData; + char *q = ops; - pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - p = ops; + pairObjPtr = Tcl_NewListObj(0, NULL); if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; + *q = 'r'; + q++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; + *q = 'w'; + q++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; + *q = 'u'; + q++; } if (tvarPtr->flags & TCL_TRACE_ARRAY) { - *p = 'a'; - p++; + *q = 'a'; + q++; } - *p = '\0'; + *q = '\0'; /* * Build a pair (2-item list) with the ops string as the first obj @@ -353,15 +366,17 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) return TCL_OK; badVarOps: - Tcl_AppendResult(interp, "bad operations \"", flagOps, - "\": should be one or more of rwua", (char *) 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; } /* *---------------------------------------------------------------------- * - * TclTraceExecutionObjCmd -- + * TraceExecutionObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the [trace * {add|remove|info} execution ...] subcommands. See the user @@ -377,21 +392,21 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -int -TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - int optionIndex; /* Add, info or remove */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static int +TraceExecutionObjCmd( + Tcl_Interp *interp, /* Current interpreter. */ + int optionIndex, /* Add, info or remove */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; - char *name, *command; + const char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { - "enter", "leave", "enterstep", "leavestep", (char *) NULL + static const char *const opStrings[] = { + "enter", "leave", "enterstep", "leavestep", NULL }; enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, @@ -420,9 +435,11 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) 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++) { @@ -448,11 +465,9 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; @@ -464,11 +479,11 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) 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, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); + tcmdPtr) != TCL_OK) { + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -478,19 +493,19 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) * first one that matches. */ - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); + ClientData clientData; + + /* + * First ensure the name given is valid. + */ - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { + name = Tcl_GetString(objv[3]); + if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; + FOREACH_COMMAND_TRACE(interp, name, clientData) { + TraceCommandInfo *tcmdPtr = clientData; /* * In checking the 'flags' field we must remove any extraneous @@ -519,15 +534,18 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) 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) { - /* Postpone deletion */ + /* + * Postpone deletion. + */ + tcmdPtr->flags = 0; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -537,27 +555,28 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) } case TRACE_INFO: { ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + Tcl_Obj *resultListPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - clientData = NULL; name = Tcl_GetString(objv[3]); - /* First ensure the name given is valid */ + /* + * First ensure the name given is valid. + */ + if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { + resultListPtr = Tcl_NewListObj(0, NULL); + FOREACH_COMMAND_TRACE(interp, name, clientData) { int numOps = 0; - - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; + TraceCommandInfo *tcmdPtr = clientData; /* * Build a list with the ops list as the first obj element and the @@ -565,38 +584,37 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) * list (as an element) to the end of the result object list. */ - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + elemObjPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enter",5)); + TclNewLiteralStringObj(opObj, "enter"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leave",5)); + TclNewLiteralStringObj(opObj, "leave"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enterstep",9)); + TclNewLiteralStringObj(opObj, "enterstep"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leavestep",9)); + TclNewLiteralStringObj(opObj, "leavestep"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + eachTraceObjPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); elemObjPtr = NULL; Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, Tcl_NewStringObj(tcmdPtr->command, -1)); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; @@ -608,7 +626,7 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) /* *---------------------------------------------------------------------- * - * TclTraceCommandObjCmd -- + * TraceCommandObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the [trace * {add|info|remove} command ...] subcommands. See the user documentation @@ -624,18 +642,18 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) *---------------------------------------------------------------------- */ -int -TclTraceCommandObjCmd(interp, optionIndex, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - int optionIndex; /* Add, info or remove */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static int +TraceCommandObjCmd( + Tcl_Interp *interp, /* Current interpreter. */ + int optionIndex, /* Add, info or remove */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; - char *name, *command; + const char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; + static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { @@ -660,8 +678,11 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) 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; } @@ -683,11 +704,9 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr; + TraceCommandInfo *tcmdPtr = ckalloc( + TclOffset(TraceCommandInfo, command) + 1 + length); - tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) - (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) - + length + 1)); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; @@ -695,11 +714,11 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) 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, - (ClientData) tcmdPtr) != TCL_OK) { - ckfree((char *) tcmdPtr); + tcmdPtr) != TCL_OK) { + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -709,28 +728,28 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) * first one that matches. */ - TraceCommandInfo *tcmdPtr; - ClientData clientData = NULL; - name = Tcl_GetString(objv[3]); + ClientData clientData; - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { + /* + * First ensure the name given is valid. + */ + + name = Tcl_GetString(objv[3]); + if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - tcmdPtr = (TraceCommandInfo *) clientData; - if ((tcmdPtr->length == length) - && (tcmdPtr->flags == flags) + FOREACH_COMMAND_TRACE(interp, name, clientData) { + TraceCommandInfo *tcmdPtr = clientData; + + if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -740,27 +759,27 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) } case TRACE_INFO: { ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + Tcl_Obj *resultListPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } - clientData = NULL; - name = Tcl_GetString(objv[3]); + /* + * First ensure the name given is valid. + */ - /* First ensure the name given is valid */ + name = Tcl_GetString(objv[3]); if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { + resultListPtr = Tcl_NewListObj(0, NULL); + FOREACH_COMMAND_TRACE(interp, name, clientData) { int numOps = 0; - - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; + TraceCommandInfo *tcmdPtr = clientData; /* * Build a list with the ops list as the first obj element and the @@ -768,22 +787,22 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) * list (as an element) to the end of the result object list. */ - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + elemObjPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(elemObjPtr); if (tcmdPtr->flags & TCL_TRACE_RENAME) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("rename",6)); + TclNewLiteralStringObj(opObj, "rename"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } if (tcmdPtr->flags & TCL_TRACE_DELETE) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("delete",6)); + TclNewLiteralStringObj(opObj, "delete"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); } Tcl_ListObjLength(NULL, elemObjPtr, &numOps); if (0 == numOps) { Tcl_DecrRefCount(elemObjPtr); continue; } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + eachTraceObjPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); Tcl_DecrRefCount(elemObjPtr); @@ -801,7 +820,7 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) /* *---------------------------------------------------------------------- * - * TclTraceVariableObjCmd -- + * TraceVariableObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the [trace * {add|info|remove} variable ...] subcommands. See the user @@ -817,19 +836,20 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) *---------------------------------------------------------------------- */ -int -TclTraceVariableObjCmd(interp, optionIndex, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - int optionIndex; /* Add, info or remove */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static int +TraceVariableObjCmd( + Tcl_Interp *interp, /* Current interpreter. */ + int optionIndex, /* Add, info or remove */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int commandLength, index; - char *name, *command; + const char *name, *command; size_t length; + ClientData clientData; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; - static CONST char *opStrings[] = { - "array", "read", "unset", "write", (char *) NULL + static const char *const opStrings[] = { + "array", "read", "unset", "write", NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE @@ -857,8 +877,11 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) 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++) { @@ -884,21 +907,24 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceVarInfo *tvarPtr; - tvarPtr = (TraceVarInfo *) ckalloc((unsigned) - (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) - + length + 1)); - tvarPtr->flags = flags; + CombinedTraceVarInfo *ctvarPtr = ckalloc( + TclOffset(CombinedTraceVarInfo, traceCmdInfo.command) + + 1 + length); + + ctvarPtr->traceCmdInfo.flags = flags; if (objv[0] == NULL) { - tvarPtr->flags |= TCL_TRACE_OLD_STYLE; + ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } - tvarPtr->length = length; + ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; - strcpy(tvarPtr->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 (Tcl_TraceVar(interp, name, flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); + if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) + != TCL_OK) { + ckfree(ctvarPtr); return TCL_ERROR; } } else { @@ -908,12 +934,10 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) * first one that matches. */ - TraceVarInfo *tvarPtr; - ClientData clientData = 0; name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; + FOREACH_VAR_TRACE(interp, name, clientData) { + TraceVarInfo *tvarPtr = clientData; + if ((tvarPtr->length == length) && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) && (strncmp(command, tvarPtr->command, @@ -921,7 +945,6 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } @@ -929,8 +952,7 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) break; } case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + Tcl_Obj *resultListPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); @@ -938,12 +960,10 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) } resultListPtr = Tcl_NewObj(); - clientData = 0; name = Tcl_GetString(objv[3]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, - clientData)) != 0) { - - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + FOREACH_VAR_TRACE(interp, name, clientData) { + Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; + TraceVarInfo *tvarPtr = clientData; /* * Build a list with the ops list as the first obj element and the @@ -951,24 +971,24 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) * list (as an element) to the end of the result object list. */ - elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + elemObjPtr = Tcl_NewListObj(0, NULL); if (tvarPtr->flags & TCL_TRACE_ARRAY) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("array", 5)); + TclNewLiteralStringObj(opObjPtr, "array"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); } if (tvarPtr->flags & TCL_TRACE_READS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("read", 4)); + TclNewLiteralStringObj(opObjPtr, "read"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); } if (tvarPtr->flags & TCL_TRACE_WRITES) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("write", 5)); + TclNewLiteralStringObj(opObjPtr, "write"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); } if (tvarPtr->flags & TCL_TRACE_UNSETS) { - Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("unset", 5)); + TclNewLiteralStringObj(opObjPtr, "unset"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObjPtr); } - eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + eachTraceObjPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); @@ -1009,13 +1029,13 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) */ ClientData -Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) - Tcl_Interp *interp; /* Interpreter containing command. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, +Tcl_CommandTraceInfo( + Tcl_Interp *interp, /* Interpreter containing command. */ + const char *cmdName, /* Name of command. */ + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_CommandTraceProc *proc; /* Function assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned by + Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ @@ -1074,16 +1094,16 @@ Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) */ int -Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which command is to be +Tcl_TraceCommand( + Tcl_Interp *interp, /* Interpreter in which command is to be * traced. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any of + const char *cmdName, /* Name of command. */ + int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Function to call when specified ops are + Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; register CommandTrace *tracePtr; @@ -1098,7 +1118,7 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) * Set up trace information. */ - tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); + tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & @@ -1107,8 +1127,18 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) 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; } @@ -1130,14 +1160,14 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) */ void -Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter containing command. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any of +Tcl_UntraceCommand( + Tcl_Interp *interp, /* Interpreter containing command. */ + const char *cmdName, /* Name of command. */ + int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Function assocated with trace. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { register CommandTrace *tracePtr; CommandTrace *prevPtr; @@ -1146,7 +1176,7 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) ActiveCommandTrace *activePtr; int hasExecTraces = 0; - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, + cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; @@ -1154,7 +1184,7 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); - for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; @@ -1194,7 +1224,7 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) tracePtr->flags = 0; if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); + ckfree(tracePtr); } if (hasExecTraces) { @@ -1211,6 +1241,15 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) */ 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++; + } } } @@ -1234,23 +1273,23 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) /* ARGSUSED */ static void -TraceCommandProc(clientData, interp, oldName, newName, flags) - ClientData clientData; /* Information about the command trace. */ - Tcl_Interp *interp; /* Interpreter containing command. */ - CONST char *oldName; /* Name of command being changed. */ - CONST char *newName; /* New name of command. Empty string or NULL +TraceCommandProc( + ClientData clientData, /* Information about the command trace. */ + Tcl_Interp *interp, /* Interpreter containing command. */ + const char *oldName, /* Name of command being changed. */ + const char *newName, /* New name of command. Empty string or NULL * means command is being deleted (renamed to * ""). */ - int flags; /* OR-ed bits giving operation and other + int flags) /* OR-ed bits giving operation and other * information. */ { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + TraceCommandInfo *tcmdPtr = clientData; int code; Tcl_DString cmd; tcmdPtr->refCount++; - if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { /* * Generate a command to execute by appending list elements for the @@ -1262,9 +1301,9 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) 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"); } /* @@ -1283,7 +1322,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) 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); } @@ -1301,7 +1340,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) 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) { @@ -1340,13 +1379,12 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) state = Tcl_SaveInterpState(interp, TCL_OK); Tcl_UntraceCommand(interp, oldName, untraceFlags, TraceCommandProc, clientData); - (void) Tcl_RestoreInterpState(interp, state); + Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree(tcmdPtr); } - return; } /* @@ -1375,32 +1413,30 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) */ int -TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, - objc, objv) - Tcl_Interp *interp; /* The current interpreter. */ - CONST char *command; /* Pointer to beginning of the current command +TclCheckExecutionTraces( + Tcl_Interp *interp, /* The current interpreter. */ + const char *command, /* Pointer to beginning of the current command * string. */ - int numChars; /* The number of characters in 'command' which + int numChars, /* The number of characters in 'command' which * are part of the command string. */ - Command *cmdPtr; /* Points to command's Command struct. */ - int code; /* The current result code. */ - int traceFlags; /* Current tracing situation. */ - int objc; /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ + Command *cmdPtr, /* Points to command's Command struct. */ + int code, /* The current result code. */ + int traceFlags, /* Current tracing situation. */ + int objc, /* Number of arguments for the command. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; int curLevel; int traceCode = TCL_OK; - TraceCommandInfo* tcmdPtr; Tcl_InterpState state = NULL; - if (command == NULL || cmdPtr->tracePtr == NULL) { + if (cmdPtr->tracePtr == NULL) { return traceCode; } - curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + curLevel = iPtr->varFramePtr->level; active.nextPtr = iPtr->activeCmdTracePtr; iPtr->activeCmdTracePtr = &active; @@ -1426,18 +1462,21 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } - tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; - if (tcmdPtr->flags != 0) { - tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; - tcmdPtr->curCode = code; - tcmdPtr->refCount++; - if (state == NULL) { - state = Tcl_SaveInterpState(interp, code); - } - traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, - curLevel, command, (Tcl_Command)cmdPtr, objc, objv); - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + if (tracePtr->traceProc == TraceCommandProc) { + TraceCommandInfo *tcmdPtr = tracePtr->clientData; + + if (tcmdPtr->flags != 0) { + tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; + tcmdPtr->curCode = code; + tcmdPtr->refCount++; + if (state == NULL) { + state = Tcl_SaveInterpState(interp, code); + } + traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, + command, (Tcl_Command) cmdPtr, objc, objv); + if ((--tcmdPtr->refCount) <= 0) { + ckfree(tcmdPtr); + } } } if (active.nextTracePtr) { @@ -1446,9 +1485,14 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, } iPtr->activeCmdTracePtr = active.nextPtr; if (state) { - (void) Tcl_RestoreInterpState(interp, state); + if (traceCode == TCL_OK) { + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); + } } - return(traceCode); + + return traceCode; } /* @@ -1475,18 +1519,17 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, */ int -TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, - objc, objv) - Tcl_Interp *interp; /* The current interpreter. */ - CONST char *command; /* Pointer to beginning of the current command +TclCheckInterpTraces( + Tcl_Interp *interp, /* The current interpreter. */ + const char *command, /* Pointer to beginning of the current command * string. */ - int numChars; /* The number of characters in 'command' which + int numChars, /* The number of characters in 'command' which * are part of the command string. */ - Command *cmdPtr; /* Points to command's Command struct. */ - int code; /* The current result code. */ - int traceFlags; /* Current tracing situation. */ - int objc; /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ + Command *cmdPtr, /* Points to command's Command struct. */ + int code, /* The current result code. */ + int traceFlags, /* Current tracing situation. */ + int objc, /* Number of arguments for the command. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; @@ -1495,7 +1538,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, int traceCode = TCL_OK; Tcl_InterpState state = NULL; - if (command == NULL || iPtr->tracePtr == NULL + if ((iPtr->tracePtr == NULL) || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { return(traceCode); } @@ -1526,6 +1569,9 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, active.nextTracePtr = tracePtr; tracePtr = tracePtr->nextPtr; } + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } } else { active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; @@ -1544,7 +1590,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, * it. */ - Tcl_Preserve((ClientData) tracePtr); + Tcl_Preserve(tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; if (state == NULL) { state = Tcl_SaveInterpState(interp, code); @@ -1558,14 +1604,14 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { - TraceCommandInfo* tcmdPtr = - (TraceCommandInfo *) tracePtr->clientData; + TraceCommandInfo *tcmdPtr = tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; - tcmdPtr->curCode = code; + tcmdPtr->curCode = code; } - traceCode = (tracePtr->proc)(tracePtr->clientData, - interp, curLevel, command, (Tcl_Command) cmdPtr, - objc, objv); + traceCode = tracePtr->proc(tracePtr->clientData, interp, + curLevel, command, (Tcl_Command) cmdPtr, objc, + objv); } } else { /* @@ -1583,21 +1629,19 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, } } tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - Tcl_Release((ClientData) tracePtr); - } - if (active.nextTracePtr) { - lastTracePtr = active.nextTracePtr->nextPtr; + Tcl_Release(tracePtr); } } iPtr->activeInterpTracePtr = active.nextPtr; if (state) { if (traceCode == TCL_OK) { - (void) Tcl_RestoreInterpState(interp, state); + Tcl_RestoreInterpState(interp, state); } else { Tcl_DiscardInterpState(state); } } - return(traceCode); + + return traceCode; } /* @@ -1620,16 +1664,16 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, */ static int -CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv) - Tcl_Interp *interp; /* The current interpreter. */ - register Trace *tracePtr; /* Describes the trace function to call. */ - Command *cmdPtr; /* Points to command's Command struct. */ - CONST char *command; /* Points to the first character of the +CallTraceFunction( + Tcl_Interp *interp, /* The current interpreter. */ + register Trace *tracePtr, /* Describes the trace function to call. */ + Command *cmdPtr, /* Points to command's Command struct. */ + const char *command, /* Points to the first character of the * command's source before substitutions. */ - int numChars; /* The number of characters in the command's + int numChars, /* The number of characters in the command's * source. */ - register int objc; /* Number of arguments for the command. */ - Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ + register int objc, /* Number of arguments for the command. */ + Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; char *commandCopy; @@ -1639,19 +1683,19 @@ CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv) * Copy the command characters into a new string. */ - commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); - memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); + commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1); + memcpy(commandCopy, command, (size_t) numChars); commandCopy[numChars] = '\0'; /* * Call the trace function then free allocated storage. */ - traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp*) iPtr, + traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr, iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); - ckfree((char *) commandCopy); - return(traceCode); + TclStackFree(interp, commandCopy); + return traceCode; } /* @@ -1672,10 +1716,13 @@ CallTraceFunction(interp, tracePtr, cmdPtr, command, numChars, objc, objv) */ static void -CommandObjTraceDeleted(ClientData clientData) { - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; +CommandObjTraceDeleted( + ClientData clientData) +{ + TraceCommandInfo *tcmdPtr = clientData; + if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree(tcmdPtr); } } @@ -1705,15 +1752,21 @@ CommandObjTraceDeleted(ClientData clientData) { */ static int -TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, - CONST char* command, Tcl_Command cmdInfo, int objc, - struct Tcl_Obj *CONST objv[]) { +TraceExecutionProc( + ClientData clientData, + Tcl_Interp *interp, + int level, + const char *command, + Tcl_Command cmdInfo, + int objc, + struct Tcl_Obj *const objv[]) +{ int call = 0; Interp *iPtr = (Interp *) interp; - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + TraceCommandInfo *tcmdPtr = clientData; int flags = tcmdPtr->curFlags; - int code = tcmdPtr->curCode; - int traceCode = TCL_OK; + int code = tcmdPtr->curCode; + int traceCode = TCL_OK; if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -1724,7 +1777,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, return traceCode; } - if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { /* * Check whether the current call is going to eval arbitrary Tcl code * with a generated trace, or whether we are only going to setup @@ -1752,7 +1805,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } @@ -1761,9 +1814,8 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, */ if (call) { - Tcl_DString cmd; - Tcl_DString sub; - int i; + Tcl_DString cmd, sub; + int i, saveInterpFlags; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); @@ -1790,8 +1842,8 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, Tcl_DStringAppendElement(&cmd, "enterstep"); } } else if (flags & TCL_TRACE_LEAVE_EXEC) { - Tcl_Obj* resultCode; - char* resultCodeStr; + Tcl_Obj *resultCode; + const char *resultCodeStr; /* * Append result code. @@ -1826,8 +1878,9 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, * returns. */ - tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + saveInterpFlags = iPtr->flags; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; tcmdPtr->refCount++; /* @@ -1838,7 +1891,13 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + + /* + * Restore the interp tracing flag to prevent cmd traces from + * affecting interp traces. + */ + + iPtr->flags = saveInterpFlags; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } @@ -1856,15 +1915,15 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { + register unsigned len = strlen(command) + 1; + tcmdPtr->startLevel = level; - tcmdPtr->startCmd = - (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(tcmdPtr->startCmd, command); + tcmdPtr->startCmd = ckalloc(len); + memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, (ClientData)tcmdPtr, - CommandObjTraceDeleted); + TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { @@ -1872,13 +1931,13 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } } if (call) { if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); + ckfree(tcmdPtr); } } return traceCode; @@ -1904,19 +1963,20 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, int level, /* ARGSUSED */ static char * -TraceVarProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Information about the variable trace. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *name1; /* Name of variable or array. */ - CONST char *name2; /* Name of element within array; NULL means +TraceVarProc( + ClientData clientData, /* Information about the variable trace. */ + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *name1, /* Name of variable or array. */ + const char *name2, /* Name of element within array; NULL means * scalar variable is being referenced. */ - int flags; /* OR-ed bits giving operation and other + int flags) /* OR-ed bits giving operation and other * information. */ { - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + TraceVarInfo *tvarPtr = clientData; char *result; - int code; + int code, destroy = 0; Tcl_DString cmd; + int rewind = ((Interp *)interp)->execEnvPtr->rewind; /* * We might call Tcl_Eval() below, and that might evaluate [trace vdelete] @@ -1925,10 +1985,8 @@ TraceVarProc(clientData, interp, name1, name2, flags) * it is not freed while we still need it. */ - Tcl_Preserve((ClientData) tvarPtr); - result = NULL; - if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { if (tvarPtr->length != (size_t) 0) { /* @@ -1943,24 +2001,24 @@ TraceVarProc(clientData, interp, name1, name2, flags) #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 } @@ -1975,29 +2033,40 @@ TraceVarProc(clientData, interp, name1, name2, flags) * double-free might occur depending on what the eval does. */ - if (flags & TCL_TRACE_DESTROYED) { + if ((flags & TCL_TRACE_DESTROYED) + && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { + destroy = 1; tvarPtr->flags |= TCL_TRACE_DESTROYED; } + + /* + * Make sure that unset traces are rune even if the execEnv is + * rewinding (coroutine deletion, [Bug 2093947] + */ + + if (rewind && (flags & TCL_TRACE_UNSETS)) { + ((Interp *)interp)->execEnvPtr->rewind = 0; + } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); + if (rewind) { + ((Interp *)interp)->execEnvPtr->rewind = rewind; + } if (code != TCL_OK) { /* copy error msg to result */ Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); result = (char *) errMsgObj; } Tcl_DStringFree(&cmd); } } - if (flags & TCL_TRACE_DESTROYED) { - if (result != NULL) { - register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + if (destroy && result != NULL) { + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; - Tcl_DecrRefCount(errMsgObj); - result = NULL; - } - Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); + Tcl_DecrRefCount(errMsgObj); + result = NULL; } - Tcl_Release((ClientData) tvarPtr); return result; } @@ -2018,12 +2087,12 @@ TraceVarProc(clientData, interp, name1, name2, flags) * form: * * void proc(ClientData clientData, - * Tcl_Interp* interp, + * Tcl_Interp * interp, * int level, - * CONST char* command, + * const char * command, * Tcl_Command commandInfo, * int objc, - * Tcl_Obj *CONST objv[]); + * Tcl_Obj *const objv[]); * * The 'clientData' and 'interp' arguments to 'proc' will be the same as * the arguments to Tcl_CreateObjTrace. The 'level' argument gives the @@ -2061,13 +2130,13 @@ TraceVarProc(clientData, interp, name1, name2, flags) */ Tcl_Trace -Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc) - Tcl_Interp* interp; /* Tcl interpreter */ - int level; /* Maximum nesting level */ - int flags; /* Flags, see above */ - Tcl_CmdObjTraceProc* proc; /* Trace callback */ - ClientData clientData; /* Client data for the callback */ - Tcl_CmdObjTraceDeleteProc* delProc; +Tcl_CreateObjTrace( + Tcl_Interp *interp, /* Tcl interpreter */ + int level, /* Maximum nesting level */ + int flags, /* Flags, see above */ + Tcl_CmdObjTraceProc *proc, /* Trace callback */ + ClientData clientData, /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { register Trace *tracePtr; @@ -2095,7 +2164,7 @@ Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc) iPtr->tracesForbiddingInline++; } - tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr = ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; @@ -2150,20 +2219,20 @@ Tcl_CreateObjTrace(interp, level, flags, proc, clientData, delProc) */ Tcl_Trace -Tcl_CreateTrace(interp, level, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which to create trace. */ - int level; /* Only call proc for commands at nesting +Tcl_CreateTrace( + Tcl_Interp *interp, /* Interpreter in which to create trace. */ + int level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ - Tcl_CmdTraceProc *proc; /* Function to call before executing each + Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ - ClientData clientData; /* Arbitrary value word to pass to proc. */ + ClientData clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData* data; - data = (StringTraceData *) ckalloc(sizeof(*data)); + StringTraceData *data = ckalloc(sizeof(StringTraceData)); + data->clientData = clientData; data->proc = proc; return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, - (ClientData) data, StringTraceDeleteProc); + data, StringTraceDeleteProc); } /* @@ -2183,18 +2252,18 @@ Tcl_CreateTrace(interp, level, proc, clientData) */ static int -StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) - ClientData clientData; - Tcl_Interp* interp; - int level; - CONST char* command; - Tcl_Command commandInfo; - int objc; - Tcl_Obj *CONST *objv; +StringTraceProc( + ClientData clientData, + Tcl_Interp *interp, + int level, + const char *command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *const *objv) { - StringTraceData* data = (StringTraceData*) clientData; - Command* cmdPtr = (Command*) commandInfo; - CONST char** argv; /* Args to pass to string trace proc */ + StringTraceData *data = clientData; + Command *cmdPtr = (Command *) commandInfo; + const char **argv; /* Args to pass to string trace proc */ int i; /* @@ -2202,8 +2271,8 @@ StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) * which uses strings for everything. */ - argv = (CONST char **) - ckalloc((unsigned) ((objc + 1) * sizeof(CONST char *))); + argv = (const char **) TclStackAlloc(interp, + (unsigned) ((objc + 1) * sizeof(const char *))); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } @@ -2215,9 +2284,9 @@ StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) * either command or argv. */ - (data->proc)(data->clientData, interp, level, (char *) command, + data->proc(data->clientData, interp, level, (char *) command, cmdPtr->proc, cmdPtr->clientData, objc, argv); - ckfree((char *) argv); + TclStackFree(interp, (void *) argv); return TCL_OK; } @@ -2239,10 +2308,10 @@ StringTraceProc(clientData, interp, level, command, commandInfo, objc, objv) */ static void -StringTraceDeleteProc(clientData) - ClientData clientData; +StringTraceDeleteProc( + ClientData clientData) { - ckfree((char *) clientData); + ckfree(clientData); } /* @@ -2263,14 +2332,14 @@ StringTraceDeleteProc(clientData) */ void -Tcl_DeleteTrace(interp, trace) - Tcl_Interp *interp; /* Interpreter that contains trace. */ - Tcl_Trace trace; /* Token for trace (returned previously by +Tcl_DeleteTrace( + Tcl_Interp *interp, /* Interpreter that contains trace. */ + Tcl_Trace trace) /* Token for trace (returned previously by * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; Trace *prevPtr, *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &(iPtr->tracePtr); + register Trace **tracePtr2 = &iPtr->tracePtr; ActiveInterpTrace *activePtr; /* @@ -2279,14 +2348,14 @@ Tcl_DeleteTrace(interp, trace) */ prevPtr = NULL; - while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + while (*tracePtr2 != NULL && *tracePtr2 != tracePtr) { prevPtr = *tracePtr2; - tracePtr2 = &((*tracePtr2)->nextPtr); + tracePtr2 = &prevPtr->nextPtr; } if (*tracePtr2 == NULL) { return; } - (*tracePtr2) = (*tracePtr2)->nextPtr; + *tracePtr2 = (*tracePtr2)->nextPtr; /* * The code below makes it possible to delete traces while traces are @@ -2325,14 +2394,14 @@ Tcl_DeleteTrace(interp, trace) */ if (tracePtr->delProc != NULL) { - (tracePtr->delProc)(tracePtr->clientData); + tracePtr->delProc(tracePtr->clientData); } /* * Delete the trace object. */ - Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); + Tcl_EventuallyFree((char *) tracePtr, TCL_DYNAMIC); } /* @@ -2354,12 +2423,11 @@ Tcl_DeleteTrace(interp, trace) */ Var * -TclVarTraceExists(interp, varName) - Tcl_Interp *interp; /* The interpreter */ - CONST char *varName; /* The variable name */ +TclVarTraceExists( + Tcl_Interp *interp, /* The interpreter */ + const char *varName) /* The variable name */ { - Var *varPtr; - Var *arrayPtr; + Var *varPtr, *arrayPtr; /* * The choice of "create" flag values is delicate here, and matches the @@ -2370,16 +2438,16 @@ TclVarTraceExists(interp, varName) * is triggered. This matches Tcl 7.6 semantics. */ - varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, "access", + varPtr = TclLookupVar(interp, varName, NULL, 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, + if ((varPtr->flags & VAR_TRACED_READ) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) { + TclCallVarTraces((Interp *) interp, arrayPtr, varPtr, varName, NULL, TCL_TRACE_READS, /* leaveErrMsg */ 0); } @@ -2420,32 +2488,63 @@ TclVarTraceExists(interp, varName) */ int -TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) - Interp *iPtr; /* Interpreter containing variable. */ - register Var *arrayPtr; /* Pointer to array variable that contains the +TclObjCallVarTraces( + Interp *iPtr, /* Interpreter containing variable. */ + register Var *arrayPtr, /* Pointer to array variable that contains the + * variable, or NULL if the variable isn't an + * element of an array. */ + Var *varPtr, /* Variable whose traces are to be invoked. */ + Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, /* Variable's two-part name. */ + int flags, /* Flags passed to trace functions: indicates + * what's happening to variable, plus maybe + * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ + int leaveErrMsg, /* If true, and one of the traces indicates an + * error, then leave an error message and + * stack trace information in *iPTr. */ + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ +{ + const char *part1, *part2; + + if (!part1Ptr) { + part1Ptr = localName(iPtr->varFramePtr, index); + } + part1 = TclGetString(part1Ptr); + part2 = part2Ptr? TclGetString(part2Ptr) : NULL; + + return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, + leaveErrMsg); +} + +int +TclCallVarTraces( + Interp *iPtr, /* Interpreter containing variable. */ + register Var *arrayPtr, /* Pointer to array variable that contains the * variable, or NULL if the variable isn't an * element of an array. */ - Var *varPtr; /* Variable whose traces are to be invoked. */ - CONST char *part1; - CONST char *part2; /* Variable's two-part name. */ - int flags; /* Flags passed to trace functions: indicates - * what's happening to variable, plus other - * stuff like TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, and - * TCL_INTERP_DESTROYED. */ - int leaveErrMsg; /* If true, and one of the traces indicates an + Var *varPtr, /* Variable whose traces are to be invoked. */ + const char *part1, + const char *part2, /* Variable's two-part name. */ + int flags, /* Flags passed to trace functions: indicates + * what's happening to variable, plus maybe + * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ + int leaveErrMsg) /* If true, and one of the traces indicates an * error, then leave an error message and * stack trace information in *iPTr. */ { register VarTrace *tracePtr; ActiveVarTrace active; char *result; - CONST char *openParen, *p; + const char *openParen, *p; Tcl_DString nameCopy; int copiedName; int code = TCL_OK; int disposeFlags = 0; Tcl_InterpState state = NULL; + Tcl_HashEntry *hPtr; + int traceflags = flags & VAR_ALL_TRACES; /* * If there are already similar trace functions active for the variable, @@ -2456,9 +2555,11 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) return code; } TclSetVarTraceActive(varPtr); - varPtr->refCount++; - if (arrayPtr != NULL) { - arrayPtr->refCount++; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; } /* @@ -2483,7 +2584,7 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) 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; @@ -2496,26 +2597,38 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) } /* + * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can + * set it correctly. + */ + + flags &= ~TCL_INTERP_DESTROYED; + + /* * Invoke traces on the array containing the variable, if relevant. */ result = NULL; active.nextPtr = iPtr->activeVarTracePtr; iPtr->activeVarTracePtr = &active; - Tcl_Preserve((ClientData) iPtr); - if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) { + Tcl_Preserve(iPtr); + if (arrayPtr && !TclIsVarTraceActive(arrayPtr) + && (arrayPtr->flags & traceflags)) { + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr); active.varPtr = arrayPtr; - for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + for (tracePtr = Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } - Tcl_Preserve((ClientData) tracePtr); + Tcl_Preserve(tracePtr); if (state == NULL) { - state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); + state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } - result = (*tracePtr->traceProc)(tracePtr->clientData, + if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } + result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { @@ -2529,7 +2642,7 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) code = TCL_ERROR; } } - Tcl_Release((ClientData) tracePtr); + Tcl_Release(tracePtr); if (code == TCL_ERROR) { goto done; } @@ -2544,33 +2657,39 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) flags |= TCL_TRACE_DESTROYED; } active.varPtr = varPtr; - for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { - active.nextTracePtr = tracePtr->nextPtr; - if (!(tracePtr->flags & flags)) { - continue; - } - Tcl_Preserve((ClientData) tracePtr); - if (state == NULL) { - state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); - } - result = (*tracePtr->traceProc)(tracePtr->clientData, - (Tcl_Interp *) iPtr, part1, part2, flags); - if (result != NULL) { - if (flags & TCL_TRACE_UNSETS) { - /* - * Ignore errors in unset traces. - */ + if (varPtr->flags & traceflags) { + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + for (tracePtr = Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + Tcl_Preserve(tracePtr); + if (state == NULL) { + state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); + } + if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } + result = tracePtr->traceProc(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + /* + * Ignore errors in unset traces. + */ - DisposeTraceResult(tracePtr->flags, result); - } else { - disposeFlags = tracePtr->flags; - code = TCL_ERROR; + DisposeTraceResult(tracePtr->flags, result); + } else { + disposeFlags = tracePtr->flags; + code = TCL_ERROR; + } + } + Tcl_Release(tracePtr); + if (code == TCL_ERROR) { + goto done; } - } - Tcl_Release((ClientData) tracePtr); - if (code == TCL_ERROR) { - goto done; } } @@ -2582,77 +2701,68 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) done: if (code == TCL_ERROR) { if (leaveErrMsg) { - CONST char *type = ""; - Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code); - Tcl_Obj *errorInfoKey = Tcl_NewStringObj("-errorinfo", -1); - Tcl_Obj *errorInfo; - - Tcl_IncrRefCount(errorInfoKey); - Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo); - Tcl_IncrRefCount(errorInfo); - Tcl_DictObjRemove(NULL, options, errorInfoKey); - if (Tcl_IsShared(errorInfo)) { - Tcl_DecrRefCount(errorInfo); - errorInfo = Tcl_DuplicateObj(errorInfo); - Tcl_IncrRefCount(errorInfo); - } - Tcl_AppendToObj(errorInfo, "\n (", -1); + const char *verb = ""; + const char *type = ""; + switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { case TCL_TRACE_READS: - type = "read"; - Tcl_AppendToObj(errorInfo, type, -1); + verb = "read"; + type = verb; break; case TCL_TRACE_WRITES: - type = "set"; - Tcl_AppendToObj(errorInfo, "write", -1); + verb = "set"; + type = "write"; break; case TCL_TRACE_ARRAY: - type = "trace array"; - Tcl_AppendToObj(errorInfo, "array", -1); + verb = "trace array"; + type = "array"; break; } + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, + Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); + } else { + Tcl_SetObjResult((Tcl_Interp *)iPtr, + Tcl_NewStringObj(result, -1)); + } + Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); + + Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( + "\n (%s trace on \"%s%s%s%s\")", type, part1, + (part2 ? "(" : ""), (part2 ? part2 : ""), + (part2 ? ")" : "") )); + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, Tcl_GetString((Tcl_Obj *) result)); } else { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); - } - Tcl_AppendToObj(errorInfo, " trace on \"", -1); - Tcl_AppendToObj(errorInfo, part1, -1); - if (part2 != NULL) { - Tcl_AppendToObj(errorInfo, "(", -1); - Tcl_AppendToObj(errorInfo, part1, -1); - Tcl_AppendToObj(errorInfo, ")", -1); - } - Tcl_AppendToObj(errorInfo, "\")", -1); - Tcl_DictObjPut(NULL, options, errorInfoKey, errorInfo); - Tcl_DecrRefCount(errorInfoKey); - Tcl_DecrRefCount(errorInfo); - code = Tcl_SetReturnOptions((Tcl_Interp *)iPtr, options); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); + } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); } else { - (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); + Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); } DisposeTraceResult(disposeFlags,result); } else if (state) { if (code == TCL_OK) { - code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); + code = Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state); } else { Tcl_DiscardInterpState(state); } } - if (arrayPtr != NULL) { - arrayPtr->refCount--; + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; } if (copiedName) { Tcl_DStringFree(&nameCopy); } TclClearVarTraceActive(varPtr); - varPtr->refCount--; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } iPtr->activeVarTracePtr = active.nextPtr; - Tcl_Release((ClientData) iPtr); + Tcl_Release(iPtr); return code; } @@ -2675,10 +2785,10 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) */ static void -DisposeTraceResult(flags, result) - int flags; /* Indicates type of result to determine +DisposeTraceResult( + int flags, /* Indicates type of result to determine * proper disposal method. */ - char *result; /* The result returned from a trace function + char *result) /* The result returned from a trace function * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { @@ -2705,19 +2815,20 @@ DisposeTraceResult(flags, result) *---------------------------------------------------------------------- */ +#undef Tcl_UntraceVar void -Tcl_UntraceVar(interp, varName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *varName; /* Name of variable; may end with "(index)" to +Tcl_UntraceVar( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ - int flags; /* OR-ed collection of bits describing current + int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Function assocated with trace. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { - Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); } /* @@ -2738,25 +2849,26 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) */ void -Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *part1; /* Name of variable or array. */ - CONST char *part2; /* Name of element within array; NULL means +Tcl_UntraceVar2( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - int flags; /* OR-ed collection of bits describing current + int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Function assocated with trace. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { register VarTrace *tracePtr; - VarTrace *prevPtr; + VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - int flagMask; + int flagMask, allFlags = 0; + Tcl_HashEntry *hPtr; /* * Set up a mask to mask out the parts of the flags that we are not @@ -2764,10 +2876,9 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) */ flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; - varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, - /*msg*/ (char *) NULL, + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - if (varPtr == NULL) { + if (varPtr == NULL || !(varPtr->flags & VAR_ALL_TRACES & flags)) { return; } @@ -2782,21 +2893,34 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) flagMask |= TCL_TRACE_OLD_STYLE; #endif flags &= flagMask; - for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + for (tracePtr = Tcl_GetHashValue(hPtr), prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { - return; + goto updateFlags; } if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { break; } + allFlags |= tracePtr->flags; } /* * 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; @@ -2805,20 +2929,35 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) activePtr->nextTracePtr = tracePtr->nextPtr; } } + nextPtr = tracePtr->nextPtr; if (prevPtr == NULL) { - varPtr->tracePtr = tracePtr->nextPtr; + if (nextPtr) { + Tcl_SetHashValue(hPtr, nextPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } } else { - prevPtr->nextPtr = tracePtr->nextPtr; + prevPtr->nextPtr = nextPtr; } - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + tracePtr->nextPtr = NULL; + Tcl_EventuallyFree(tracePtr, TCL_DYNAMIC); - /* - * If this is the last trace on the variable, and the variable is unset - * and unused, then free up the variable. - */ + for (tracePtr = nextPtr; tracePtr != NULL; + tracePtr = tracePtr->nextPtr) { + allFlags |= tracePtr->flags; + } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, (Var *) NULL); + updateFlags: + varPtr->flags &= ~VAR_ALL_TRACES; + if (allFlags & VAR_ALL_TRACES) { + varPtr->flags |= (allFlags & VAR_ALL_TRACES); + } else if (TclIsVarUndefined(varPtr)) { + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + TclCleanupVar(varPtr, NULL); } } @@ -2845,21 +2984,22 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) *---------------------------------------------------------------------- */ +#undef Tcl_VarTraceInfo ClientData -Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *varName; /* Name of variable; may end with "(index)" to +Tcl_VarTraceInfo( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ - int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_VarTraceProc *proc; /* Function assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned by + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { - return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, - flags, proc, prevClientData); + return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, + prevClientData); } /* @@ -2880,26 +3020,26 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) */ ClientData -Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *part1; /* Name of variable or array. */ - CONST char *part2; /* Name of element within array; NULL means +Tcl_VarTraceInfo2( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Function assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned by + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ { - register VarTrace *tracePtr; + Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), - /*msg*/ (char *) NULL, + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return NULL; @@ -2909,19 +3049,24 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) * Find the relevant trace, if any, and return its clientData. */ - tracePtr = varPtr->tracePtr; - if (prevClientData != NULL) { - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { - if ((tracePtr->clientData == prevClientData) - && (tracePtr->traceProc == proc)) { - tracePtr = tracePtr->nextPtr; - break; + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + + if (hPtr) { + register VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + + if (prevClientData != NULL) { + for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; + break; + } } } - } - for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) { - if (tracePtr->traceProc == proc) { - return tracePtr->clientData; + for (; tracePtr != NULL ; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } } } return NULL; @@ -2943,26 +3088,27 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) * A trace is set up on the variable given by varName, such that future * references to the variable will be intermediated by proc. See the * manual entry for complete details on the calling sequence for proc. + * The variable's flags are updated. * *---------------------------------------------------------------------- */ +#undef Tcl_TraceVar int -Tcl_TraceVar(interp, varName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which variable is to be +Tcl_TraceVar( + Tcl_Interp *interp, /* Interpreter in which variable is to be * traced. */ - CONST char *varName; /* Name of variable; may end with "(index)" to + const char *varName, /* Name of variable; may end with "(index)" to * signify an array reference. */ - int flags; /* OR-ed collection of bits, including any of + int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Function to call when specified ops are + Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { - return Tcl_TraceVar2(interp, varName, (char *) NULL, - flags, proc, clientData); + return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); } /* @@ -2981,30 +3127,83 @@ Tcl_TraceVar(interp, varName, flags, proc, clientData) * A trace is set up on the variable given by part1 and part2, such that * future references to the variable will be intermediated by proc. See * the manual entry for complete details on the calling sequence for - * proc. + * proc. The variable's flags are updated. * *---------------------------------------------------------------------- */ int -Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which variable is to be +Tcl_TraceVar2( + Tcl_Interp *interp, /* Interpreter in which variable is to be * traced. */ - CONST char *part1; /* Name of scalar variable or array. */ - CONST char *part2; /* Name of element within array; NULL means + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ - int flags; /* OR-ed collection of bits, including any of + int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc; /* Function to call when specified ops are + Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { - Var *varPtr, *arrayPtr; register VarTrace *tracePtr; - int flagMask; + int result; + + tracePtr = ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags; + + result = TraceVarEx(interp, part1, part2, tracePtr); + + if (result != TCL_OK) { + ckfree(tracePtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarEx -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such that + * future references to the variable will be intermediated by the + * traceProc listed in tracePtr. See the manual entry for complete + * details on the calling sequence for proc. + * + *---------------------------------------------------------------------- + */ + +static int +TraceVarEx( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + register VarTrace *tracePtr)/* Structure containing flags, traceProc and + * clientData fields. Others should be left + * blank. Will be ckfree()d (eventually) if + * this function returns TCL_OK, and up to + * caller to free if this function returns + * TCL_ERROR. */ +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + int flagMask, isNew; + Tcl_HashEntry *hPtr; /* * We strip 'flags' down to just the parts which are relevant to @@ -3015,7 +3214,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; varPtr = TclLookupVar(interp, part1, part2, - (flags & flagMask) | TCL_LEAVE_ERR_MSG, + (tracePtr->flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -3026,7 +3225,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) * because there should be no code path that ever sets both flags. */ - if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { + if ((tracePtr->flags & TCL_TRACE_RESULT_DYNAMIC) + && (tracePtr->flags & TCL_TRACE_RESULT_OBJECT)) { Tcl_Panic("bad result flag combination"); } @@ -3039,13 +3239,22 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif - tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = flags & flagMask; - tracePtr->nextPtr = varPtr->tracePtr; + tracePtr->flags = tracePtr->flags & flagMask; + + hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew); + if (isNew) { + tracePtr->nextPtr = NULL; + } else { + tracePtr->nextPtr = Tcl_GetHashValue(hPtr); + } + Tcl_SetHashValue(hPtr, tracePtr); + + /* + * Mark the variable as traced so we know to call them. + */ + + varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES); - varPtr->tracePtr = tracePtr; return TCL_OK; } |