Index: doc/trace.n =================================================================== RCS file: /cvsroot/tcl/doc/trace.n,v retrieving revision 1.7 diff -c -r1.7 trace.n *** trace.n 2000/09/07 17:39:04 1.7 --- trace.n 2000/09/14 09:58:58 *************** *** 48,56 **** command to an empty string. Commands are also deleted when the interpreter is deleted, but traces will not be invoked because there is no interpreter in which to execute them. .PP ! When the trace triggers, three arguments are appended to ! \fIcommand\fR so that the actual command is as follows: .CS \fIcommand oldName newName op\fR .CE --- 48,77 ---- command to an empty string. Commands are also deleted when the interpreter is deleted, but traces will not be invoked because there is no interpreter in which to execute them. + .TP + \fBbefore\fR + Invoke \fIcommand\fR whenever the command is executed, just before the + actual execution takes place. + .TP + \fBafter\fR + Invoke \fIcommand\fR whenever the command is executed, just after the + actual execution takes place. + .TP + \fBpreinside\fR + Invoke \fIcommand\fR whenever anything is executed inside the the command + being traced, just before that execution takes place. For example if we + have 'proc foo {} { puts "hello" }', then a \fIpreinside\fR trace would be + invoked just before \fIputs "hello"\fR was executed. + .TP + \fBpostinside\fR + Invoke \fIcommand\fR whenever anything is executed inside the the command + being traced, just after that execution takes place. .PP ! When the trace triggers, depending on the operations being traced, a ! number of arguments are appended to \fIcommand\fR so that the actual ! command is as follows: ! ! For \fBrename\fR and \fBdelete\fR operations: .CS \fIcommand oldName newName op\fR .CE *************** *** 65,70 **** --- 86,125 ---- of the same type to be evaluated, so a delete trace which itself deletes the command, or a rename trace which itself renames the command will not cause further trace evaluations to occur. + .RE + For \fBbefore\fR and \fBpreinside\fR operations: + .CS + \fIcommand command-string op\fR + .CE + \fICommand-string\fR gives the complete current command being + executed (the traced command for a \fBbefore\fR operation, an + arbitrary command for a \fBpreinside\fR operation), including + all arguments. Since this occurs before the command is actually + executed, those arguments are in their unexpanded form. + \fIOp\fR indicates what operation is being performed on the + variable, and is one of \fBbefore\fR or \fBpreinside\fR as + defined above. The trace operation can be used to stop the + command from executing, by deleting the command in question. Of + course when the command is subsequently executed, an 'invalid command' + error will occur. + .RE + For \fBafter\fR and \fBpostinside\fR operations: + .CS + \fIcommand command-string code result op\fR + .CE + \fICommand-string\fR gives the complete current command being + executed (the traced command for a \fBbefore\fR operation, an + arbitrary command for a \fBpreinside\fR operation), including + all arguments. Since this occurs after the command is actually + executed, those arguments are in their fully expanded form. + \fICode\fR gives the result code of that execution, and \fIresult\R + the result string. + \fIOp\fR indicates what operation is being performed on the + variable, and is one of \fBafter\fR or \fBpostinside\fR as + defined above. Note that the creation of many \fBpreinside\fR or + \fBpostinside\fR traces can lead to unintuitive results, since the + invoked commands from one trace can themselves lead to further + command invocations for other traces. .RE .TP \fBtrace add variable\fI name ops command\fR Index: generic/tcl.decls =================================================================== RCS file: /cvsroot/tcl/generic/tcl.decls,v retrieving revision 1.39 diff -c -r1.39 tcl.decls *** tcl.decls 2000/08/25 02:04:27 1.39 --- tcl.decls 2000/09/14 09:59:01 *************** *** 1418,1423 **** --- 1418,1427 ---- void Tcl_UntraceCommand(Tcl_Interp *interp, char *varName, int flags, \ Tcl_CommandTraceProc *proc, ClientData clientData) } + declare 410 generic { + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, \ + Tcl_CmdTraceObjProc *proc, ClientData clientData) + } ############################################################################## Index: generic/tcl.h =================================================================== RCS file: /cvsroot/tcl/generic/tcl.h,v retrieving revision 1.78 diff -c -r1.78 tcl.h *** tcl.h 2000/09/06 18:50:15 1.78 --- tcl.h 2000/09/14 09:59:07 *************** *** 566,571 **** --- 566,575 ---- typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, ClientData cmdClientData, int argc, char *argv[])); + typedef void (Tcl_CmdTraceObjProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, int flags, int code, + char* command, int length, Tcl_Command currentCmd, + int objc, struct Tcl_Obj *CONST objv[])); typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr)); typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, *************** *** 939,944 **** --- 943,956 ---- #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 + + /* + * Flag values passed to Tcl_CreateTraceObj, and used internally + * by command execution traces. Slots 4,8,16 and 32 are + * used internally by execution traces (see tclCmdMZ.c) + */ + #define TCL_TRACE_BEFORE_EXEC 1 + #define TCL_TRACE_AFTER_EXEC 2 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. Index: generic/tclBasic.c =================================================================== RCS file: /cvsroot/tcl/generic/tclBasic.c,v retrieving revision 1.29 diff -c -r1.29 tclBasic.c *** tclBasic.c 2000/08/25 02:04:28 1.29 --- tclBasic.c 2000/09/14 09:59:15 *************** *** 339,344 **** --- 339,345 ---- iPtr->flags = 0; iPtr->tracePtr = NULL; iPtr->activeCmdTracePtr = NULL; + iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ *************** *** 2418,2432 **** } static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) ! Interp *iPtr; /* Interpreter containing variable. */ ! Command *cmdPtr; /* Variable whose traces are to be * invoked. */ char *oldName; /* Command's old name, or NULL if we * must get the name from cmdPtr */ char *newName; /* Command's new name, or NULL if * the command is not being renamed */ int flags; /* Flags passed to trace procedures: ! * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ --- 2419,2433 ---- } static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) ! Interp *iPtr; /* Interpreter containing command. */ ! Command *cmdPtr; /* Command whose traces are to be * invoked. */ char *oldName; /* Command's old name, or NULL if we * must get the name from cmdPtr */ char *newName; /* Command's new name, or NULL if * the command is not being renamed */ int flags; /* Flags passed to trace procedures: ! * indicates what's happening to command, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ *************** *** 2457,2462 **** --- 2458,2466 ---- active.nextPtr = iPtr->activeCmdTracePtr; iPtr->activeCmdTracePtr = &active; + if (flags & TCL_TRACE_DELETE) { + flags |= TCL_TRACE_DESTROYED; + } active.cmdPtr = cmdPtr; for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { *************** *** 3974,3981 **** iPtr->flags |= DONT_COMPILE_CMDS_INLINE; tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; ! tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; --- 3978,4021 ---- iPtr->flags |= DONT_COMPILE_CMDS_INLINE; tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->flags = 0; + tracePtr->proc.stringProc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; + } + Tcl_Trace + Tcl_CreateObjTrace(interp, level, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + int level; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). */ + int flags; /* OR'd combination of execution trace + * flags. */ + Tcl_CmdTraceObjProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary value word to pass to proc. */ + { + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + /* + * Invalidate existing compiled code for this interpreter and arrange + * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling + * new code, no commands will be compiled inline (i.e., into an inline + * sequence of instructions). We do this because commands that were + * compiled inline will never result in a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; ! tracePtr->flags = flags; ! tracePtr->proc.objProc = proc; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; *************** *** 4009,4014 **** --- 4049,4068 ---- register Interp *iPtr = (Interp *) interp; register Trace *tracePtr = (Trace *) trace; register Trace *tracePtr2; + register ActiveInterpTrace *activePtr; + + /* + * 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 TclCheckInterpTraces. + */ + + for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } if (iPtr->tracePtr == tracePtr) { iPtr->tracePtr = tracePtr->nextPtr; Index: generic/tclCmdMZ.c =================================================================== RCS file: /cvsroot/tcl/generic/tclCmdMZ.c,v retrieving revision 1.29 diff -c -r1.29 tclCmdMZ.c *** tclCmdMZ.c 2000/09/06 18:31:36 1.29 --- tclCmdMZ.c 2000/09/14 09:59:32 *************** *** 55,65 **** } TraceVarInfo; /* ! * The same structure is used for command traces at present */ ! typedef TraceVarInfo TraceCommandInfo; /* * Forward declarations for procedures defined in this file: */ --- 55,102 ---- } TraceVarInfo; /* ! * Structure used to hold information about command traces: */ ! typedef struct { ! int flags; /* Operations for which Tcl command is ! * to be invoked. */ ! size_t length; /* Number of non-NULL chars. in command. */ ! Tcl_Trace insideTrace; /* Used for execution traces, when tracing ! * inside the given command */ ! int startLevel; /* Used for bookkeeping with execution traces */ ! char command[4]; /* 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. */ ! } TraceCommandInfo; + /* + * Used by command execution traces. Note that we assume in the code + * that the first two defines are exactly 4 times the + * 'TCL_TRACE_BEFORE_EXEC' and 'TCL_TRACE_AFTER_EXEC' constants. + * + * TCL_TRACE_BEFORE_DURING_EXEC - Trace each command inside the command + * currently being traced, before execution. + * TCL_TRACE_AFTER_DURING_EXEC - Trace each command inside the command + * currently being traced, after execution. + * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. + * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace + * is currently executing. Therefore we + * don't let further traces execute. + * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly + * by the command being traced, not because + * of an internal trace. + * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also + * be used in command execution traces. + */ + #define TCL_TRACE_BEFORE_DURING_EXEC 4 + #define TCL_TRACE_AFTER_DURING_EXEC 8 + #define TCL_TRACE_ANY_EXEC 15 + #define TCL_TRACE_EXEC_IN_PROGRESS 0x10 + #define TCL_TRACE_EXEC_DIRECT 0x20 + /* * Forward declarations for procedures defined in this file: */ *************** *** 85,98 **** TclTraceVariableObjCmd, }; static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *oldName, char *newName, int flags)); - /* *---------------------------------------------------------------------- * --- 122,142 ---- TclTraceVariableObjCmd, }; + /* + * Declarations for local procedures to this file: + */ + static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + char *command, int numChars, + int objc, Tcl_Obj *CONST objv[])); static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *oldName, char *newName, int flags)); + static Tcl_CmdTraceObjProc TraceExecutionProc; /* *---------------------------------------------------------------------- * *************** *** 2693,2700 **** TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); } ! ckfree((char *) tvarPtr); break; } } --- 2737,2745 ---- TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; } ! Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } *************** *** 2794,2801 **** char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; ! static char *opStrings[] = { "delete", "rename", (char *) NULL }; ! enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: --- 2839,2848 ---- char *name, *command; size_t length; enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; ! static char *opStrings[] = { "delete", "rename", "before", ! "after", "preinside", "postinside", (char *) NULL }; ! enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME, TRACE_EXEC_BEFORE, ! TRACE_EXEC_AFTER, TRACE_EXEC_PREINSIDE, TRACE_EXEC_POSTINSIDE }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: *************** *** 2819,2825 **** } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " ! "one or more of delete or rename", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { --- 2866,2872 ---- } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " ! "one or more of delete, rename, before, after, preinside, or postinside", TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { *************** *** 2834,2839 **** --- 2881,2898 ---- case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; + case TRACE_EXEC_BEFORE: + flags |= TCL_TRACE_BEFORE_EXEC; + break; + case TRACE_EXEC_AFTER: + flags |= TCL_TRACE_AFTER_EXEC; + break; + case TRACE_EXEC_PREINSIDE: + flags |= TCL_TRACE_BEFORE_DURING_EXEC; + break; + case TRACE_EXEC_POSTINSIDE: + flags |= TCL_TRACE_AFTER_DURING_EXEC; + break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); *************** *** 2844,2852 **** (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; ! tcmdPtr->errMsg = NULL; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, --- 2903,2915 ---- (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; ! tcmdPtr->insideTrace = NULL; ! tcmdPtr->startLevel = 0; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_PREINSIDE | TRACE_EXEC_POSTINSIDE)) { + flags |= (TCL_TRACE_BEFORE_EXEC | TCL_TRACE_AFTER_EXEC); + } strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, *************** *** 2868,2884 **** while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != 0) { tcmdPtr = (TraceCommandInfo *) 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); ! if (tcmdPtr->errMsg != NULL) { ! ckfree(tcmdPtr->errMsg); } - ckfree((char *) tcmdPtr); break; } } --- 2931,2966 ---- while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != 0) { tcmdPtr = (TraceCommandInfo *) clientData; + /* + * In checking the 'flags' field we must remove any extraneous + * flags which may have been temporarily added by various pieces + * of the trace mechanism. + */ if ((tcmdPtr->length == length) ! && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | ! TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { + flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_PREINSIDE | TRACE_EXEC_POSTINSIDE)) { + flags |= (TCL_TRACE_BEFORE_EXEC | TCL_TRACE_AFTER_EXEC); + } Tcl_UntraceCommand(interp, name, ! flags, TraceCommandProc, clientData); ! if (tcmdPtr->insideTrace != NULL) { ! /* ! * We need to remove the interpreter-wide trace ! * which we created to allow 'inside' traces. ! */ ! Tcl_DeleteTrace(interp, tcmdPtr->insideTrace); ! tcmdPtr->insideTrace = NULL; ! } ! /* Postpone deletion */ ! if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { ! tcmdPtr->flags = 0; ! } else { ! Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); } break; } } *************** *** 2904,2912 **** eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); /* ! * Build a list with the ops list as ! * the first obj element and the tcmdPtr->command string ! * as the second obj element. Append this list (as an * element) to the end of the result object list. */ --- 2986,2994 ---- eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); /* ! * Build a list with the ops list as the first obj ! * element and the tcmdPtr->command string as the ! * second obj element. Append this list (as an * element) to the end of the result object list. */ *************** *** 2919,2924 **** --- 3001,3022 ---- Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("delete",6)); } + if (tcmdPtr->flags & TCL_TRACE_BEFORE_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("before",6)); + } + if (tcmdPtr->flags & TCL_TRACE_AFTER_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("after",5)); + } + if (tcmdPtr->flags & TCL_TRACE_BEFORE_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("preinside",9)); + } + if (tcmdPtr->flags & TCL_TRACE_AFTER_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("postinside",10)); + } Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); *************** *** 3054,3061 **** TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); } ! ckfree((char *) tvarPtr); break; } } --- 3152,3160 ---- TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; } ! Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } *************** *** 3195,3200 **** --- 3294,3302 ---- * * Arrange for rename/deletes to a command to cause a * procedure to be invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command + * to cause a procedure to be invoked. * * Results: * A standard Tcl return value. *************** *** 3214,3220 **** * to be traced. */ char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any ! * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ --- 3316,3323 ---- * to be traced. */ 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; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ *************** *** 3235,3243 **** tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; ! tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE); tracePtr->nextPtr = cmdPtr->tracePtr; cmdPtr->tracePtr = tracePtr; return TCL_OK; } --- 3338,3350 ---- tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; ! tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE ! | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; cmdPtr->tracePtr = tracePtr; + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + cmdPtr->flags |= CMD_HAS_EXEC_TRACES; + } return TCL_OK; } *************** *** 3264,3270 **** Tcl_Interp *interp; /* Interpreter containing command. */ char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any ! * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { --- 3371,3378 ---- Tcl_Interp *interp; /* Interpreter containing command. */ 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; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { *************** *** 3273,3301 **** Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; ! cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } - flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE); for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } ! if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { break; } } ! /* * 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 CallTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; --- 3381,3414 ---- Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; ! int hasExecTraces = 0; ! cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } + + flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } ! if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags) && (tracePtr->clientData == clientData)) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + hasExecTraces = 1; + } break; } } ! /* * 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 CallCommandTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; *************** *** 3308,3315 **** cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } - ckfree((char *) tracePtr); } /* --- 3421,3443 ---- cmdPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; + } + tracePtr->flags = 0; + Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC); + + if (hasExecTraces) { + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + return; + } + } + /* + * None of the remaining traces on this command are execution + * traces. We therefore remove this flag: + */ + cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; } } /* *************** *** 3318,3324 **** * TraceCommandProc -- * * This procedure is called to handle command changes that have ! * been traced using the "trace" command. * * Results: * None. --- 3446,3453 ---- * TraceCommandProc -- * * This procedure is called to handle command changes that have ! * been traced using the "trace" command, when using the ! * 'rename' or 'delete' options. * * Results: * None. *************** *** 3345,3355 **** TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; ! ! if (tcmdPtr->errMsg != NULL) { ! ckfree(tcmdPtr->errMsg); ! tcmdPtr->errMsg = NULL; ! } if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements --- 3474,3482 ---- TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; ! ! Tcl_Preserve((ClientData) tcmdPtr); ! if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements *************** *** 3385,3395 **** Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { ! if (tcmdPtr->errMsg != NULL) { ! ckfree(tcmdPtr->errMsg); } ! ckfree((char *) tcmdPtr); } return; } --- 3512,3921 ---- Tcl_DStringFree(&cmd); } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->insideTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->insideTrace); + tcmdPtr->insideTrace = NULL; + } + /* Postpone deletion, until exec trace returns */ + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + tcmdPtr->flags = 0; + } else { + Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } + } + Tcl_Release((ClientData) tcmdPtr); + return; + } + + /* + *---------------------------------------------------------------------- + * + * TclCheckExecutionTraces -- + * + * Checks on all current command execution traces, and invokes + * procedures which have been registered. This procedure can be + * used by other code which performs execution to unify the + * tracing system, so that execution traces will function for that + * other code. + * + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is used by 'EvalObjv' and 'TclExecuteByteCode' + * + * Results: + * None. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ + void + TclCheckExecutionTraces(interp, command, numChars, cmdPtr, result, traceFlags, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + char *command; /* Pointer to beginning of the current + * command string. */ + int numChars; /* The number of characters in 'command' + * which are part of the command string. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int result; /* 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; + ActiveCommandTrace active; + int curLevel; + + if (command == NULL) { + return; + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + active.cmdPtr = cmdPtr; + for (tracePtr = cmdPtr->tracePtr;tracePtr != NULL; + tracePtr = active.nextTracePtr) { + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + active.nextTracePtr = tracePtr->nextPtr; + if (tcmdPtr->flags != 0) { + TraceExecutionProc((ClientData)tcmdPtr, interp, + curLevel, traceFlags | TCL_TRACE_EXEC_DIRECT, result, + command, numChars, (Tcl_Command)cmdPtr, + objc, objv); + } + } + iPtr->activeCmdTracePtr = active.nextPtr; + } + + /* + *---------------------------------------------------------------------- + * + * TclCheckInterpTraces -- + * + * Checks on all current traces, and invokes procedures which + * have been registered. This procedure can be used by other + * code which performs execution to unify the tracing system. + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is used by 'EvalObjv' and 'TclExecuteByteCode' + * + * Results: + * None. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ + void + TclCheckInterpTraces(interp, command, numChars, cmdPtr, result, traceFlags, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + char *command; /* Pointer to beginning of the current + * command string. */ + int numChars; /* The number of characters in 'command' + * which are part of the command string. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int result; /* 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; + ActiveInterpTrace active; + int curLevel; + + if (command == NULL) { + return; + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeInterpTracePtr; + iPtr->activeInterpTracePtr = &active; + + for (tracePtr = iPtr->tracePtr;tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (tracePtr->level != 0 && curLevel > tracePtr->level) { + continue; + } + if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { + tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + if (tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) { + if ((tracePtr->flags & traceFlags) != 0) { + (*tracePtr->proc.objProc)(tracePtr->clientData, interp, curLevel, + traceFlags, result, command, numChars, + (Tcl_Command)cmdPtr, objc, objv); + } + } else { + if (traceFlags & TCL_TRACE_BEFORE_EXEC) { + /* + * Old-style interpreter-wide traces only trigger + * before the command is executed. + */ + CallTraceProcedure(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); + } + } + tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + } + + } + iPtr->activeInterpTracePtr = active.nextPtr; + } + + /* + *---------------------------------------------------------------------- + * + * CallTraceProcedure -- + * + * Invokes a trace procedure registered with an interpreter. These + * procedures trace command execution. Currently this trace procedure + * is called with the address of the string-based Tcl_CmdProc for the + * command, not the Tcl_ObjCmdProc. + * + * Results: + * None. + * + * Side effects: + * Those side effects made by the trace procedure. + * + *---------------------------------------------------------------------- + */ + + static void + CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + register Trace *tracePtr; /* Describes the trace procedure to call. */ + Command *cmdPtr; /* Points to command's Command struct. */ + char *command; /* Points to the first character of the + * command's source before substitutions. */ + 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. */ + { + Interp *iPtr = (Interp *) interp; + register char **argv; + register int i; + int length; + char *p; + + /* + * Get the string rep from the objv argument objects and place their + * pointers in argv. First make sure argv is large enough to hold the + * objc args plus 1 extra word for the zero end-of-argv word. + */ + + argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetStringFromObj(objv[i], &length); + } + argv[objc] = 0; + + /* + * Copy the command characters into a new string. + */ + + p = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) p, (VOID *) command, (size_t) numChars); + p[numChars] = '\0'; + + /* + * Call the trace procedure then free allocated storage. + */ + + (*tracePtr->proc.stringProc)(tracePtr->clientData, interp, iPtr->numLevels, + p, cmdPtr->proc, cmdPtr->clientData, objc, argv); + + ckfree((char *) argv); + ckfree((char *) p); + } + + /* + *---------------------------------------------------------------------- + * + * TraceExecutionProc -- + * + * This procedure is invoked whenever code relevant to a + * 'trace execution' command is executed. It is called in one + * of two ways in Tcl's core: + * + * (i) by the above procedure, when an execution trace has been + * triggered. + * (ii) by TclCheckInterpTraces, when a prior execution trace has + * created a trace of the internals of a procedure, passing in + * this procedure as the one to be called. + * + * Results: + * None. + * + * Side effects: + * May invoke an arbitrary Tcl procedure, and may create or + * delete an interpreter-wide trace. + * + *---------------------------------------------------------------------- + */ + void + TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, + int level, int flags, int code, + char* command, int length, Tcl_Command cmdInfo, + int objc, struct Tcl_Obj *CONST objv[]) { + int call = 0; + Interp *iPtr = (Interp *) interp; + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* + * Inside any kind of execution trace callback, we do + * not allow any further execution trace callbacks to + * be called for the same trace. + */ + return; + } + + if (!(flags & TCL_INTERP_DESTROYED)) { + /* + * Check whether the current call is going to eval arbitrary + * Tcl code with a generated trace, or whether we are only + * going to setup interpreter-wide traces to implement the + * 'inside' traces. This latter situation can happen if + * we create a command trace without either before or after + * operations, but with either of the inside operations. + */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + call = flags & tcmdPtr->flags & (TCL_TRACE_BEFORE_EXEC | TCL_TRACE_AFTER_EXEC); + } else { + call = 1; + } + /* + * First, if we have returned back to the level at which we + * created an interpreter trace, we remove it + */ + if (flags & TCL_TRACE_AFTER_EXEC) { + if ((tcmdPtr->insideTrace != NULL) && (level == tcmdPtr->startLevel)) { + Tcl_DeleteTrace(interp, tcmdPtr->insideTrace); + tcmdPtr->insideTrace = NULL; + } + + } + + /* + * Second, create the tcl callback, if required. + */ + if (call) { + Tcl_SavedResult state; + Tcl_DString cmd; + + Tcl_DStringInit(&cmd); + if (flags & TCL_TRACE_BEFORE_EXEC) { + Tcl_DString sub; + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + /* Append command with arguments */ + Tcl_DStringInit(&sub); + Tcl_DStringAppend(&sub, command, length); + Tcl_DStringAppendElement(&cmd,Tcl_DStringValue(&sub)); + Tcl_DStringFree(&sub); + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "before"); + } else { + Tcl_DStringAppendElement(&cmd, "preinside"); + } + } else if (flags & TCL_TRACE_AFTER_EXEC) { + Tcl_DString sub; + int i; + Tcl_Obj* resultCode; + char* resultCodeStr; + + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + /* Append command with arguments */ + Tcl_DStringInit(&sub); + for (i = 0; i < objc; i++) { + char* str; + int len; + str = Tcl_GetStringFromObj(objv[i],&len); + Tcl_DStringAppendElement(&sub, str); + } + Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); + Tcl_DStringFree(&sub); + + /* Append result code */ + resultCode = Tcl_NewIntObj(code); + resultCodeStr = Tcl_GetString(resultCode); + Tcl_DStringAppendElement(&cmd, resultCodeStr); + Tcl_DecrRefCount(resultCode); + + /* Append result string */ + Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "after"); + } else { + Tcl_DStringAppendElement(&cmd, "postinside"); + } + } else { + panic("TraceExecutionProc: bad flag combination"); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + Tcl_Preserve((ClientData)tcmdPtr); + /* + * This line can have quite arbitrary side-effects, + * including deleting the trace, the command being + * traced, or even the interpreter. + */ + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + if (tcmdPtr->flags == 0) { + flags |= TCL_TRACE_DESTROYED; + } + + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + Tcl_DStringFree(&cmd); + } + + /* + * Third, create an interpreter trace, if we need one for + * subsequent internal execution traces. + */ + if ((flags & TCL_TRACE_BEFORE_EXEC) && (tcmdPtr->insideTrace == NULL) + && (tcmdPtr->flags & (TCL_TRACE_BEFORE_DURING_EXEC | TCL_TRACE_AFTER_DURING_EXEC))) { + tcmdPtr->startLevel = level; + tcmdPtr->insideTrace = Tcl_CreateObjTrace(interp, 0, + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, (ClientData)tcmdPtr); + } + } if (flags & TCL_TRACE_DESTROYED) { ! if (tcmdPtr->insideTrace != NULL) { ! Tcl_DeleteTrace(interp, tcmdPtr->insideTrace); ! tcmdPtr->insideTrace = NULL; } ! Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC); ! } ! if (call) { ! Tcl_Release((ClientData)tcmdPtr); } return; } *************** *** 3429,3434 **** --- 3955,3970 ---- int code; Tcl_DString cmd; + /* + * We might call Tcl_Eval() below, and that might evaluate + * [trace vdelete] which might try to free tvarPtr. We want + * to use tvarPtr until the end of this function, so we use + * Tcl_Preserve() and Tcl_Release() to be sure it is not + * freed while we still need it. + */ + + Tcl_Preserve((ClientData) tvarPtr); + result = NULL; if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); *************** *** 3501,3509 **** result = NULL; if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); } ! ckfree((char *) tvarPtr); } return result; } --- 4037,4047 ---- result = NULL; if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); + tvarPtr->errMsg = NULL; } ! Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); } + Tcl_Release((ClientData) tvarPtr); return result; } Index: generic/tclDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclDecls.h,v retrieving revision 1.40 diff -c -r1.40 tclDecls.h *** tclDecls.h 2000/08/25 02:04:28 1.40 --- tclDecls.h 2000/09/14 09:59:41 *************** *** 1283,1288 **** --- 1283,1293 ---- char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); + /* 410 */ + EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp * interp, + int level, int flags, + Tcl_CmdTraceObjProc * proc, + ClientData clientData)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; *************** *** 1760,1765 **** --- 1765,1771 ---- ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 407 */ int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 408 */ void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 409 */ + Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp * interp, int level, int flags, Tcl_CmdTraceObjProc * proc, ClientData clientData)); /* 410 */ } TclStubs; #ifdef __cplusplus *************** *** 3444,3449 **** --- 3450,3459 ---- #ifndef Tcl_UntraceCommand #define Tcl_UntraceCommand \ (tclStubsPtr->tcl_UntraceCommand) /* 409 */ + #endif + #ifndef Tcl_CreateObjTrace + #define Tcl_CreateObjTrace \ + (tclStubsPtr->tcl_CreateObjTrace) /* 410 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ Index: generic/tclExecute.c =================================================================== RCS file: /cvsroot/tcl/generic/tclExecute.c,v retrieving revision 1.15 diff -c -r1.15 tclExecute.c *** tclExecute.c 2000/09/06 16:59:27 1.15 --- tclExecute.c 2000/09/14 09:59:54 *************** *** 218,227 **** * Declarations for local procedures to this file: */ - static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, - Trace *tracePtr, Command *cmdPtr, - char *command, int numChars, - int objc, Tcl_Obj *objv[])); static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, --- 218,223 ---- *************** *** 745,750 **** --- 741,748 ---- Tcl_Obj **objv; /* The array of argument objects. */ Command *cmdPtr; /* Points to command's Command struct. */ int newPcOffset; /* New inst offset for break, continue. */ + char *command; /* String starting with actual command */ + int numChars; /* Number of chars of command to use */ #ifdef TCL_COMPILE_DEBUG int isUnknownCmd = 0; char cmdNameBuf[21]; *************** *** 771,826 **** */ objv = &(stackPtr[stackTop - (objc-1)]); ! cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); ! if (cmdPtr == NULL) { ! cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", ! (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); ! if (cmdPtr == NULL) { ! Tcl_ResetResult(interp); ! Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), ! "invalid command name \"", ! Tcl_GetString(objv[0]), "\"", ! (char *) NULL); ! TRACE(("%u => unknown proc not found: ", objc)); ! result = TCL_ERROR; ! goto checkForCatch; ! } #ifdef TCL_COMPILE_DEBUG isUnknownCmd = 1; #endif /*TCL_COMPILE_DEBUG*/ ! stackTop++; /* need room for new inserted objv[0] */ ! for (i = objc-1; i >= 0; i--) { ! objv[i+1] = objv[i]; } ! objc++; ! objv[0] = Tcl_NewStringObj("unknown", -1); ! Tcl_IncrRefCount(objv[0]); ! } ! ! /* ! * Call any trace procedures. ! */ ! ! if (iPtr->tracePtr != NULL) { ! Trace *tracePtr, *nextTracePtr; ! for (tracePtr = iPtr->tracePtr; tracePtr != NULL; ! tracePtr = nextTracePtr) { ! nextTracePtr = tracePtr->nextPtr; ! if (iPtr->numLevels <= tracePtr->level) { ! int numChars; ! char *cmd = GetSrcInfoForPc(pc, codePtr, ! &numChars); ! if (cmd != NULL) { ! DECACHE_STACK_INFO(); ! CallTraceProcedure(interp, tracePtr, cmdPtr, ! cmd, numChars, objc, objv); ! CACHE_STACK_INFO(); } } } } ! /* * Finally, invoke the command's Tcl_ObjCmdProc. First reset * the interpreter's string and object results to their --- 769,838 ---- */ objv = &(stackPtr[stackTop - (objc-1)]); ! ! /* ! * If any execution traces rename or delete the current command, ! * we may need two passes here. ! */ ! while (1) { ! int checkTraces = 1; ! ! cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); ! if (cmdPtr == NULL) { ! cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", ! (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); ! if (cmdPtr == NULL) { ! Tcl_ResetResult(interp); ! Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), ! "invalid command name \"", ! Tcl_GetString(objv[0]), "\"", ! (char *) NULL); ! TRACE(("%u => unknown proc not found: ", objc)); ! result = TCL_ERROR; ! goto checkForCatch; ! } #ifdef TCL_COMPILE_DEBUG isUnknownCmd = 1; #endif /*TCL_COMPILE_DEBUG*/ ! stackTop++; /* need room for new inserted objv[0] */ ! for (i = objc-1; i >= 0; i--) { ! objv[i+1] = objv[i]; ! } ! objc++; ! objv[0] = Tcl_NewStringObj("unknown", -1); ! Tcl_IncrRefCount(objv[0]); } ! ! /* ! * Call any trace procedures. ! */ ! if (checkTraces) { ! if ((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { ! int cmdEpoch = cmdPtr->cmdEpoch; ! cmdPtr->refCount++; ! command = GetSrcInfoForPc(pc, codePtr, &numChars); ! DECACHE_STACK_INFO(); ! if (iPtr->tracePtr != NULL) { ! TclCheckInterpTraces(interp,command,numChars,cmdPtr,TCL_OK, ! TCL_TRACE_BEFORE_EXEC,objc,objv); } + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { + TclCheckExecutionTraces(interp,command,numChars,cmdPtr,TCL_OK, + TCL_TRACE_BEFORE_EXEC,objc,objv); + } + CACHE_STACK_INFO(); + cmdPtr->refCount--; + if (cmdEpoch != cmdPtr->cmdEpoch) { + /* The command has been modified in some way */ + checkTraces = 0; + continue; + } } } + break; } ! /* * Finally, invoke the command's Tcl_ObjCmdProc. First reset * the interpreter's string and object results to their *************** *** 875,880 **** --- 887,908 ---- } /* + * Call 'after' command traces. + */ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { + DECACHE_STACK_INFO(); + TclCheckExecutionTraces(interp,command,numChars,cmdPtr,result, + TCL_TRACE_AFTER_EXEC,objc,objv); + CACHE_STACK_INFO(); + } + if (iPtr->tracePtr != NULL) { + DECACHE_STACK_INFO(); + TclCheckInterpTraces(interp,command,numChars,cmdPtr,result, + TCL_TRACE_AFTER_EXEC,objc,objv); + CACHE_STACK_INFO(); + } + + /* * Pop the objc top stack elements and decrement their ref * counts. */ *************** *** 3313,3386 **** msg, " as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } - } - - /* - *---------------------------------------------------------------------- - * - * CallTraceProcedure -- - * - * Invokes a trace procedure registered with an interpreter. These - * procedures trace command execution. Currently this trace procedure - * is called with the address of the string-based Tcl_CmdProc for the - * command, not the Tcl_ObjCmdProc. - * - * Results: - * None. - * - * Side effects: - * Those side effects made by the trace procedure. - * - *---------------------------------------------------------------------- - */ - - static void - CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) - Tcl_Interp *interp; /* The current interpreter. */ - register Trace *tracePtr; /* Describes the trace procedure to call. */ - Command *cmdPtr; /* Points to command's Command struct. */ - char *command; /* Points to the first character of the - * command's source before substitutions. */ - int numChars; /* The number of characters in the - * command's source. */ - register int objc; /* Number of arguments for the command. */ - Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ - { - Interp *iPtr = (Interp *) interp; - register char **argv; - register int i; - int length; - char *p; - - /* - * Get the string rep from the objv argument objects and place their - * pointers in argv. First make sure argv is large enough to hold the - * objc args plus 1 extra word for the zero end-of-argv word. - */ - - argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], &length); - } - argv[objc] = 0; - - /* - * Copy the command characters into a new string. - */ - - p = (char *) ckalloc((unsigned) (numChars + 1)); - memcpy((VOID *) p, (VOID *) command, (size_t) numChars); - p[numChars] = '\0'; - - /* - * Call the trace procedure then free allocated storage. - */ - - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - p, cmdPtr->proc, cmdPtr->clientData, objc, argv); - - ckfree((char *) argv); - ckfree((char *) p); } /* --- 3341,3346 ---- Index: generic/tclInt.decls =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.decls,v retrieving revision 1.22 diff -c -r1.22 tclInt.decls *** tclInt.decls 2000/07/26 01:28:49 1.22 --- tclInt.decls 2000/09/14 09:59:57 *************** *** 607,612 **** --- 607,622 ---- declare 161 generic { void TclChannelEventScriptInvoker(ClientData clientData, int mask) } + declare 162 generic { + void TclCheckInterpTraces (Tcl_Interp *interp, char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) + } + declare 163 generic { + void TclCheckExecutionTraces (Tcl_Interp *interp, char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) + } ############################################################################## Index: generic/tclInt.h =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.h,v retrieving revision 1.50 diff -c -r1.50 tclInt.h *** tclInt.h 2000/08/25 02:04:29 1.50 --- tclInt.h 2000/09/14 10:00:07 *************** *** 286,295 **** * a particular command. */ } CommandTrace; typedef struct ActiveCommandTrace { ! struct Command *cmdPtr; /* Variable that's being traced. */ struct ActiveCommandTrace *nextPtr; ! /* Next in list of all active variable * traces for the interpreter, or NULL * if no more. */ CommandTrace *nextTracePtr; /* Next trace to check after current --- 286,303 ---- * a particular command. */ } CommandTrace; + /* + * When a command trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the command's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + typedef struct ActiveCommandTrace { ! struct Command *cmdPtr; /* Command that's being traced. */ struct ActiveCommandTrace *nextPtr; ! /* Next in list of all active command * traces for the interpreter, or NULL * if no more. */ CommandTrace *nextTracePtr; /* Next trace to check after current *************** *** 641,654 **** */ typedef struct Trace { ! int level; /* Only trace commands at nesting level ! * less than or equal to this. */ ! Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ ! ClientData clientData; /* Arbitrary value to pass to proc. */ ! struct Trace *nextPtr; /* Next in list of traces for this interp. */ } Trace; /* * The structure below defines an entry in the assocData hash table which * is associated with an interpreter. The entry contains a pointer to a * function to call when the interpreter is deleted, and a pointer to --- 649,686 ---- */ typedef struct Trace { ! int level; /* Only trace commands at nesting level ! * less than or equal to this. */ ! union { ! Tcl_CmdTraceProc *stringProc; /* Procedure to call to trace command. */ ! Tcl_CmdTraceObjProc *objProc; /* Procedure to call to trace command. */ ! } proc; ! ClientData clientData; /* Arbitrary value to pass to proc. */ ! struct Trace *nextPtr; /* Next in list of traces for this ! * interp. */ ! int flags; } Trace; /* + * When an interpreter trace is active (i.e. its associated procedure + * is executing), one of the following structures is linked into a list + * associated with the interpreter. The information in the structure + * is needed in order for Tcl to behave reasonably if traces are + * deleted while traces are active. + */ + + typedef struct ActiveInterpTrace { + struct ActiveInterpTrace *nextPtr; + /* Next in list of all active command + * traces for the interpreter, or NULL + * if no more. */ + Trace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ + } ActiveInterpTrace; + + /* * The structure below defines an entry in the assocData hash table which * is associated with an interpreter. The entry contains a pointer to a * function to call when the interpreter is deleted, and a pointer to *************** *** 1073,1078 **** --- 1105,1113 ---- * underway for a rename/delete change. * See the two flags below for which is * currently being processed. + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least + * one execution trace (as opposed to simple + * delete/rename traces) in its tracePtr list. * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further *************** *** 1081,1086 **** --- 1116,1122 ---- */ #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 + #define CMD_HAS_EXEC_TRACES 0x4 /* *---------------------------------------------------------------- *************** *** 1299,1304 **** --- 1335,1343 ---- ActiveCommandTrace *activeCmdTracePtr; /* First in list of active command traces for + * interp, or NULL if no active traces. */ + ActiveInterpTrace *activeInterpTracePtr; + /* First in list of active traces for * interp, or NULL if no active traces. */ /* * Statistical information about the bytecode compiler and interpreter's Index: generic/tclIntDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclIntDecls.h,v retrieving revision 1.20 diff -c -r1.20 tclIntDecls.h *** tclIntDecls.h 2000/05/19 21:30:16 1.20 --- tclIntDecls.h 2000/09/14 10:00:09 *************** *** 527,532 **** --- 527,544 ---- /* 161 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int mask)); + /* 162 */ + EXTERN void TclCheckInterpTraces _ANSI_ARGS_(( + Tcl_Interp * interp, char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); + /* 163 */ + EXTERN void TclCheckExecutionTraces _ANSI_ARGS_(( + Tcl_Interp * interp, char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); typedef struct TclIntStubs { int magic; *************** *** 726,731 **** --- 738,745 ---- char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int mask)); /* 161 */ + void (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 162 */ + void (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 163 */ } TclIntStubs; #ifdef __cplusplus *************** *** 1376,1381 **** --- 1390,1403 ---- #ifndef TclChannelEventScriptInvoker #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 161 */ + #endif + #ifndef TclCheckInterpTraces + #define TclCheckInterpTraces \ + (tclIntStubsPtr->tclCheckInterpTraces) /* 162 */ + #endif + #ifndef TclCheckExecutionTraces + #define TclCheckExecutionTraces \ + (tclIntStubsPtr->tclCheckExecutionTraces) /* 163 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ Index: generic/tclParse.c =================================================================== RCS file: /cvsroot/tcl/generic/tclParse.c,v retrieving revision 1.13 diff -c -r1.13 tclParse.c *** tclParse.c 1999/11/10 02:51:57 1.13 --- tclParse.c 2000/09/14 10:00:16 *************** *** 799,806 **** Interp *iPtr = (Interp *) interp; Tcl_Obj **newObjv; int i, code; - Trace *tracePtr, *nextPtr; - char **argv, *commandCopy; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ --- 799,804 ---- *************** *** 853,924 **** * to execute it. */ - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", Tcl_GetString(objv[0]), "\"", - (char *) NULL); - code = TCL_ERROR; - } else { - code = EvalObjv(interp, objc+1, newObjv, command, length, 0); - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - goto done; - } - /* ! * Call trace procedures if needed. */ ! ! argv = NULL; ! commandCopy = command; ! ! for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { ! nextPtr = tracePtr->nextPtr; ! if (iPtr->numLevels > tracePtr->level) { ! continue; } ! /* ! * This is a bit messy because we have to emulate the old trace ! * interface, which uses strings for everything. */ ! if (argv == NULL) { ! argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); ! for (i = 0; i < objc; i++) { ! argv[i] = Tcl_GetString(objv[i]); ! } ! argv[objc] = 0; ! ! if (length < 0) { ! length = strlen(command); ! } else if ((size_t)length < strlen(command)) { ! commandCopy = (char *) ckalloc((unsigned) (length + 1)); ! strncpy(commandCopy, command, (size_t) length); ! commandCopy[length] = 0; } } ! (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, ! commandCopy, cmdPtr->proc, cmdPtr->clientData, ! objc, argv); ! } ! if (argv != NULL) { ! ckfree((char *) argv); } - if (commandCopy != command) { - ckfree((char *) commandCopy); - } /* * Finally, invoke the command's Tcl_ObjCmdProc. --- 851,915 ---- * to execute it. */ /* ! * If any execution traces rename or delete the current command, ! * we may need two passes here. */ ! while (1) { ! int checkTraces = 1; ! ! cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); ! if (cmdPtr == NULL) { ! newObjv = (Tcl_Obj **) ckalloc((unsigned) ! ((objc + 1) * sizeof (Tcl_Obj *))); ! for (i = objc-1; i >= 0; i--) { ! newObjv[i+1] = objv[i]; ! } ! newObjv[0] = Tcl_NewStringObj("unknown", -1); ! Tcl_IncrRefCount(newObjv[0]); ! cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); ! if (cmdPtr == NULL) { ! Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), ! "invalid command name \"", Tcl_GetString(objv[0]), "\"", ! (char *) NULL); ! code = TCL_ERROR; ! } else { ! code = EvalObjv(interp, objc+1, newObjv, command, length, 0); ! } ! Tcl_DecrRefCount(newObjv[0]); ! ckfree((char *) newObjv); ! goto done; } ! /* ! * Call trace procedures if needed. */ ! if (checkTraces) { ! if ((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { ! int cmdEpoch = cmdPtr->cmdEpoch; ! cmdPtr->refCount++; ! /* If the first set of traces modifies/deletes the command or ! * any existing traces, then the se ! */ ! if (iPtr->tracePtr != NULL) { ! TclCheckInterpTraces(interp, command, length, cmdPtr, TCL_OK, ! TCL_TRACE_BEFORE_EXEC, objc, objv); ! } ! if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { ! TclCheckExecutionTraces(interp, command, length, cmdPtr, TCL_OK, ! TCL_TRACE_BEFORE_EXEC, objc, objv); ! } ! cmdPtr->refCount--; ! if (cmdEpoch != cmdPtr->cmdEpoch) { ! /* The command has been modified in some way */ ! checkTraces = 0; ! continue; ! } } } ! break; } /* * Finally, invoke the command's Tcl_ObjCmdProc. *************** *** 946,951 **** --- 937,954 ---- (void) Tcl_GetObjResult(interp); } + /* + * Call 'after' command traces + */ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { + TclCheckExecutionTraces(interp,command, length, cmdPtr, code, + TCL_TRACE_AFTER_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL) { + TclCheckInterpTraces(interp,command, length, cmdPtr, code, + TCL_TRACE_AFTER_EXEC, objc, objv); + } + done: iPtr->numLevels--; return code; *************** *** 994,1000 **** /* * EvalObjv will increment numLevels so use "<" rather than "<=" */ ! if (iPtr->numLevels < tracePtr->level) { int i; /* * The command will be needed for an execution trace or stack trace --- 997,1003 ---- /* * EvalObjv will increment numLevels so use "<" rather than "<=" */ ! if (tracePtr->level == 0 || (iPtr->numLevels < tracePtr->level)) { int i; /* * The command will be needed for an execution trace or stack trace *************** *** 1387,1396 **** } /* ! * Execute the command and free the objects for its words. */ ! code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); if (code != TCL_OK) { goto error; } --- 1390,1405 ---- } /* ! * Execute the command and free the objects for its words. So that traces ! * can execute properly, we have to be careful what exact string we send ! * to EvalObjv. */ ! if (parse.commandStart[parse.commandSize-1] == '\n') { ! code = EvalObjv(interp, objectsUsed, objv, parse.commandStart, parse.commandSize -1, 0); ! } else { ! code = EvalObjv(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); ! } if (code != TCL_OK) { goto error; } Index: generic/tclStubInit.c =================================================================== RCS file: /cvsroot/tcl/generic/tclStubInit.c,v retrieving revision 1.43 diff -c -r1.43 tclStubInit.c *** tclStubInit.c 2000/08/25 02:04:29 1.43 --- tclStubInit.c 2000/09/14 10:00:17 *************** *** 241,246 **** --- 241,248 ---- TclGetStartupScriptFileName, /* 159 */ TclpMatchFilesTypes, /* 160 */ TclChannelEventScriptInvoker, /* 161 */ + TclCheckInterpTraces, /* 162 */ + TclCheckExecutionTraces, /* 163 */ }; TclIntPlatStubs tclIntPlatStubs = { *************** *** 812,817 **** --- 814,820 ---- Tcl_CommandTraceInfo, /* 407 */ Tcl_TraceCommand, /* 408 */ Tcl_UntraceCommand, /* 409 */ + Tcl_CreateObjTrace, /* 410 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclVar.c =================================================================== RCS file: /cvsroot/tcl/generic/tclVar.c,v retrieving revision 1.23 diff -c -r1.23 tclVar.c *** tclVar.c 2000/08/25 20:39:31 1.23 --- tclVar.c 2000/09/14 10:00:28 *************** *** 39,45 **** * Forward references to procedures defined later in this file: */ ! static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, Var *varPtr, char *part1, char *part2, int flags)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, --- 39,45 ---- * Forward references to procedures defined later in this file: */ ! static char * CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, Var *varPtr, char *part1, char *part2, int flags)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, *************** *** 618,624 **** if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { --- 618,624 ---- if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! msg = CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { *************** *** 742,748 **** */ if (varPtr->tracePtr != NULL) { ! msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { --- 742,748 ---- */ if (varPtr->tracePtr != NULL) { ! msg = CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { *************** *** 900,906 **** if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { --- 900,906 ---- if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! msg = CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { *************** *** 1337,1343 **** if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { --- 1337,1343 ---- if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! char *msg = CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { *************** *** 1516,1522 **** */ if (varPtr->tracePtr != NULL) { ! char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, (char *) NULL, TCL_TRACE_WRITES); if (msg != NULL) { if (leaveErrorMsg) { --- 1516,1522 ---- */ if (varPtr->tracePtr != NULL) { ! char *msg = CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, (char *) NULL, TCL_TRACE_WRITES); if (msg != NULL) { if (leaveErrorMsg) { *************** *** 1737,1743 **** if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_WRITES); if (msg != NULL) { if (leaveErrorMsg) { --- 1737,1743 ---- if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { ! char *msg = CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_WRITES); if (msg != NULL) { if (leaveErrorMsg) { *************** *** 2141,2147 **** * Call trace procedures for the variable being deleted. Then delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: ! * 1. We need to increment varPtr's refCount around this: CallTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. --- 2141,2147 ---- * Call trace procedures for the variable being deleted. Then delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: ! * 1. We need to increment varPtr's refCount around this: CallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. *************** *** 2151,2157 **** || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; ! (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; --- 2151,2157 ---- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; ! (void) CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; *************** *** 2454,2460 **** /* * 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 CallTraces. */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; --- 2454,2460 ---- /* * 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 CallVarTraces. */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; *************** *** 2949,2955 **** if (varPtr != NULL && varPtr->tracePtr != NULL && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { ! msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY)); if (msg != NULL) { --- 2949,2955 ---- if (varPtr != NULL && varPtr->tracePtr != NULL && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { ! msg = CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY)); if (msg != NULL) { *************** *** 4129,4135 **** /* *---------------------------------------------------------------------- * ! * CallTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on --- 4129,4135 ---- /* *---------------------------------------------------------------------- * ! * CallVarTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on *************** *** 4152,4158 **** */ static char * ! CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable --- 4152,4158 ---- */ static char * ! CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable *************** *** 4505,4511 **** * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole ! * table is deleted). Note that we give CallTraces the variable's * fully-qualified name so that any called trace procedures can * refer to these variables being deleted. */ --- 4505,4511 ---- * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole ! * table is deleted). Note that we give CallVarTraces the variable's * fully-qualified name so that any called trace procedures can * refer to these variables being deleted. */ *************** *** 4514,4520 **** objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); ! (void) CallTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), (char *) NULL, flags); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ --- 4514,4520 ---- objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); ! (void) CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), (char *) NULL, flags); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ *************** *** 4640,4646 **** */ if (varPtr->tracePtr != NULL) { ! (void) CallTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, (char *) NULL, flags); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; --- 4640,4646 ---- */ if (varPtr->tracePtr != NULL) { ! (void) CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, (char *) NULL, flags); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; *************** *** 4704,4710 **** char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ ! int flags; /* Flags to pass to CallTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or --- 4704,4710 ---- char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ ! int flags; /* Flags to pass to CallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or *************** *** 4728,4734 **** elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; ! (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; --- 4728,4734 ---- elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; ! (void) CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; *************** *** 4884,4890 **** if ((varPtr != NULL) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { ! msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName, (char *) NULL, TCL_TRACE_READS); if (msg != NULL) { /* --- 4884,4890 ---- if ((varPtr != NULL) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { ! msg = CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, (char *) NULL, TCL_TRACE_READS); if (msg != NULL) { /* Index: tests/trace.test =================================================================== RCS file: /cvsroot/tcl/tests/trace.test,v retrieving revision 1.9 diff -c -r1.9 trace.test *** trace.test 2000/08/25 20:39:32 1.9 --- trace.test 2000/09/14 10:00:31 *************** *** 724,730 **** # error messages. set i 0 ! set errs [list "array, read, unset, or write" "delete or rename"] set abbvs [list {a r u w} {d r}] foreach type {variable command} err $errs abbvlist $abbvs { foreach op {add remove} { --- 724,730 ---- # error messages. set i 0 ! set errs [list "array, read, unset, or write" "delete, rename, before, after, preinside, or postinside"] set abbvs [list {a r u w} {d r}] foreach type {variable command} err $errs abbvlist $abbvs { foreach op {add remove} { *************** *** 1337,1348 **** catch {rename foo {}} catch {rename bar {}} ! # Delete arrays when done, so they can be re-used as scalars ! # elsewhere. ! catch {unset x} ! catch {unset y} # cleanup ::tcltest::cleanupTests --- 1337,1777 ---- catch {rename foo {}} catch {rename bar {}} ! proc foo {a} { ! set b $a ! } ! proc traceExecute {args} { ! global info ! lappend info $args ! } ! ! test trace-20.1 {blah} { ! set info {} ! trace add command foo before [list traceExecute foo] ! foo 1 ! trace remove command foo before [list traceExecute foo] ! set info ! } {{foo {foo 1} before}} ! ! test trace-20.2 {blah} { ! set info {} ! trace add command foo after [list traceExecute foo] ! foo 2 ! trace remove command foo after [list traceExecute foo] ! set info ! } {{foo {foo 2} 0 2 after}} ! ! test trace-20.3 {blah} { ! set info {} ! trace add command foo {before after} [list traceExecute foo] ! foo 3 ! trace remove command foo {before after} [list traceExecute foo] ! set info ! } {{foo {foo 3} before} {foo {foo 3} 0 3 after}} ! ! test trace-20.4 {blah} { ! set info {} ! trace add command foo {before after preinside} [list traceExecute foo] ! foo 3 ! trace remove command foo {before after preinside} [list traceExecute foo] ! set info ! } {{foo {foo 3} before} {foo {set b $a} preinside} {foo {foo 3} 0 3 after}} ! ! test trace-20.5 {blah} { ! set info {} ! trace add command foo {before after preinside postinside} [list traceExecute foo] ! foo 3 ! trace remove command foo {before after preinside postinside} [list traceExecute foo] ! set info ! } {{foo {foo 3} before} {foo {set b $a} preinside} {foo {set b 3} 0 3 postinside} {foo {foo 3} 0 3 after}} ! ! test trace-20.6 {blah} { ! set info {} ! trace add command foo {preinside postinside} [list traceExecute foo] ! foo 3 ! trace remove command foo {preinside postinside} [list traceExecute foo] ! set info ! } {{foo {set b $a} preinside} {foo {set b 3} 0 3 postinside}} ! ! test trace-20.7 {blah} { ! set info {} ! trace add command foo {preinside} [list traceExecute foo] ! foo 3 ! trace remove command foo {preinside} [list traceExecute foo] ! set info ! } {{foo {set b $a} preinside}} ! ! test trace-20.8 {blah} { ! set info {} ! trace add command foo {postinside} [list traceExecute foo] ! foo 3 ! trace remove command foo {postinside} [list traceExecute foo] ! set info ! } {{foo {set b 3} 0 3 postinside}} ! ! proc factorial {n} { ! if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } ! return 1 ! } ! ! test trace-21.1 {} { ! set info {} ! trace add command factorial {before} [list traceExecute factorial] ! factorial 1 ! trace remove command factorial {before} [list traceExecute factorial] ! set info ! } {{factorial {factorial 1} before}} ! ! test trace-21.2 {} { ! set info {} ! trace add command factorial {before} [list traceExecute factorial] ! factorial 2 ! trace remove command factorial {before} [list traceExecute factorial] ! set info ! } {{factorial {factorial 2} before} {factorial {factorial [expr {$n -1 }} before}} ! ! test trace-21.3 {} { ! set info {} ! trace add command factorial {before} [list traceExecute factorial] ! factorial 3 ! trace remove command factorial {before} [list traceExecute factorial] ! set info ! } {{factorial {factorial 3} before} {factorial {factorial [expr {$n -1 }} before} {factorial {factorial [expr {$n -1 }} before}} ! ! test trace-22.1 {} { ! set info {} ! trace add command factorial {before after preinside postinside} [list traceExecute] ! factorial 1 ! trace remove command factorial {before after preinside postinside} [list traceExecute] ! join $info "\n" ! } {{factorial 1} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} postinside ! {return 1} preinside ! {return 1} 2 1 postinside ! {factorial 1} 0 1 after} ! ! test trace-22.2 {} { ! set info {} ! trace add command factorial {before after preinside postinside} [list traceExecute] ! factorial 2 ! trace remove command factorial {before after preinside postinside} [list traceExecute] ! join $info "\n" ! } {{factorial 2} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {expr {$n * [factorial [expr {$n -1 }]]}} preinside ! {expr {$n -1 }} preinside ! {expr {$n -1 }} 0 1 postinside ! {factorial [expr {$n -1 }} preinside ! {factorial [expr {$n -1 }} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} postinside ! {return 1} preinside ! {return 1} 2 1 postinside ! {factorial 1} 0 1 after ! {factorial 1} 0 1 postinside ! {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 postinside ! {return [expr {$n * [factorial [expr {$n -1 }]]}] } preinside ! {return 2} 2 2 postinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 postinside ! {factorial 2} 0 2 after} ! ! test trace-22.3 {} { ! set info {} ! trace add command factorial {before after preinside postinside} [list traceExecute] ! factorial 3 ! trace remove command factorial {before after preinside postinside} [list traceExecute] ! join $info "\n" ! } {{factorial 3} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {expr {$n * [factorial [expr {$n -1 }]]}} preinside ! {expr {$n -1 }} preinside ! {expr {$n -1 }} 0 2 postinside ! {factorial [expr {$n -1 }} preinside ! {factorial [expr {$n -1 }} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {expr {$n * [factorial [expr {$n -1 }]]}} preinside ! {expr {$n -1 }} preinside ! {expr {$n -1 }} 0 1 postinside ! {factorial [expr {$n -1 }} preinside ! {factorial [expr {$n -1 }} before ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} preinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} postinside ! {return 1} preinside ! {return 1} 2 1 postinside ! {factorial 1} 0 1 after ! {factorial 1} 0 1 postinside ! {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 postinside ! {return [expr {$n * [factorial [expr {$n -1 }]]}] } preinside ! {return 2} 2 2 postinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 postinside ! {factorial 2} 0 2 after ! {factorial 2} 0 2 postinside ! {expr {$n * [factorial [expr {$n -1 }]]}} 0 6 postinside ! {return [expr {$n * [factorial [expr {$n -1 }]]}] } preinside ! {return 6} 2 6 postinside ! {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 postinside ! {factorial 3} 0 6 after} ! ! proc traceDelete {cmd args} { ! eval trace remove command $cmd [lindex [trace list command $cmd] 0] ! global info ! set info $args ! } ! ! test trace-23.1 {delete trace during before trace} { ! set info {} ! trace add command foo before [list traceDelete foo] ! foo 1 ! list $info [trace list command foo] ! } {{{foo 1} before} {}} ! ! test trace-23.2 {delete trace during after trace} { ! set info {} ! trace add command foo after [list traceDelete foo] ! foo 1 ! list $info [trace list command foo] ! } {{{foo 1} 0 1 after} {}} ! ! test trace-23.3 {delete trace during before-after trace} { ! set info {} ! trace add command foo {before after} [list traceDelete foo] ! foo 1 ! list $info [trace list command foo] ! } {{{foo 1} before} {}} ! ! test trace-23.4 {delete trace during all exec traces} { ! set info {} ! trace add command foo {before after preinside postinside} [list traceDelete foo] ! foo 1 ! list $info [trace list command foo] ! } {{{foo 1} before} {}} ! ! test trace-23.5 {delete trace during all exec traces except before} { ! set info {} ! trace add command foo {after preinside postinside} [list traceDelete foo] ! foo 1 ! list $info [trace list command foo] ! } {{{set b $a} preinside} {}} ! ! proc traceDelete {cmd args} { ! rename $cmd {} ! global info ! set info $args ! } ! ! proc foo {a} { ! set b $a ! } + test trace-24.1 {delete command during before trace} { + set info {} + trace add command foo before [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {{invalid command name "foo"} {{foo 1} before} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + + test trace-24.2 {delete command during after trace} { + set info {} + trace add command foo after [list traceDelete foo] + foo 1 + list $info [trace list command foo] + } {{{foo 1} 0 1 after} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + + test trace-24.3 {delete command during before then after trace} { + set info {} + trace add command foo before [list traceDelete foo] + trace add command foo after [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {{invalid command name "foo"} {{foo 1} before} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + proc traceExecute2 {args} { + global info + lappend info $args + } + + # This shows the peculiar consequences of having two inside traces + # at the same time: as well as tracing the procedure you want + # you also trace the other callbacks. Each callback will not + # trace itself, but it has no way of distinguishing other callbacks + # from genuine code inside the Tcl procedure (and neither should it + # have such a way, really). + test trace-24.4 {two inside traces} { + set info {} + trace add command foo preinside [list traceExecute traceExecute] + trace add command foo preinside [list traceExecute2 traceExecute2] + catch {foo 1} err + trace remove command foo preinside [list traceExecute traceExecute] + trace remove command foo preinside [list traceExecute2 traceExecute2] + join [list $err [join $info \n] [trace list command foo]] "\n" + } {1 + traceExecute2 {traceExecute traceExecute {set b $a} preinside} preinside + traceExecute2 {global info} preinside + traceExecute2 {lappend info $args} preinside + traceExecute {set b $a} preinside + traceExecute {traceExecute2 traceExecute2 {set b $a} preinside} preinside + traceExecute {global info} preinside + traceExecute {lappend info $args} preinside + traceExecute2 {set b $a} preinside + } + + test trace-24.5 {two inside traces order dependence} { + set info {} + trace add command foo preinside [list traceExecute2 traceExecute2] + trace add command foo preinside [list traceExecute traceExecute] + catch {foo 1} err + trace remove command foo preinside [list traceExecute traceExecute] + trace remove command foo preinside [list traceExecute2 traceExecute2] + join [list $err [join $info \n] [trace list command foo]] "\n" + } {1 + traceExecute {traceExecute2 traceExecute2 {set b $a} preinside} preinside + traceExecute {global info} preinside + traceExecute {lappend info $args} preinside + traceExecute2 {set b $a} preinside + traceExecute2 {traceExecute traceExecute {set b $a} preinside} preinside + traceExecute2 {global info} preinside + traceExecute2 {lappend info $args} preinside + traceExecute {set b $a} preinside + } + + # We don't want the result string (5th argument), or the results + # will get unmanageable. + proc tracePostExecute {args} { + global info + lappend info [concat [lrange $args 0 2] [lindex $args 4]] + } + proc tracePostExecute2 {args} { + global info + lappend info [concat [lrange $args 0 2] [lindex $args 4]] + } + + # This even more peculiar consequences of having two postinside traces + # at the same time. + test trace-24.6 {two inside traces} { + set info {} + trace add command foo postinside [list tracePostExecute tracePostExecute] + trace add command foo postinside [list tracePostExecute2 tracePostExecute2] + catch {foo 1} err + trace remove command foo postinside [list tracePostExecute tracePostExecute] + trace remove command foo postinside [list tracePostExecute2 tracePostExecute2] + join [list $err [join $info \n] [trace list command foo]] "\n" + } {1 + tracePostExecute2 {global info} 0 postinside + tracePostExecute2 {lrange {tracePostExecute {set b 1} 0 1 postinside} 0 2} 0 postinside + tracePostExecute2 {lindex {tracePostExecute {set b 1} 0 1 postinside} 4} 0 postinside + tracePostExecute2 {concat {tracePostExecute {set b 1} 0} postinside} 0 postinside + tracePostExecute {set b 1} 0 postinside + tracePostExecute2 {lappend info {tracePostExecute {set b 1} 0 postinside}} 0 postinside + tracePostExecute2 {tracePostExecute tracePostExecute {set b 1} 0 1 postinside} 0 postinside + tracePostExecute {global info} 0 postinside + tracePostExecute {lrange {tracePostExecute2 {set b 1} 0 1 postinside} 0 2} 0 postinside + tracePostExecute {lindex {tracePostExecute2 {set b 1} 0 1 postinside} 4} 0 postinside + tracePostExecute {concat {tracePostExecute2 {set b 1} 0} postinside} 0 postinside + tracePostExecute2 {set b 1} 0 postinside + tracePostExecute {lappend info {tracePostExecute2 {set b 1} 0 postinside}} 0 postinside + tracePostExecute {tracePostExecute2 tracePostExecute2 {set b 1} 0 1 postinside} 0 postinside + } + + test trace-24.7 {two inside traces order dependence} { + set info {} + trace add command foo postinside [list tracePostExecute2 tracePostExecute2] + trace add command foo postinside [list tracePostExecute tracePostExecute] + catch {foo 1} err + trace remove command foo postinside [list tracePostExecute tracePostExecute] + trace remove command foo postinside [list tracePostExecute2 tracePostExecute2] + join [list $err [join $info \n] [trace list command foo]] "\n" + } {1 + tracePostExecute {global info} 0 postinside + tracePostExecute {lrange {tracePostExecute2 {set b 1} 0 1 postinside} 0 2} 0 postinside + tracePostExecute {lindex {tracePostExecute2 {set b 1} 0 1 postinside} 4} 0 postinside + tracePostExecute {concat {tracePostExecute2 {set b 1} 0} postinside} 0 postinside + tracePostExecute2 {set b 1} 0 postinside + tracePostExecute {lappend info {tracePostExecute2 {set b 1} 0 postinside}} 0 postinside + tracePostExecute {tracePostExecute2 tracePostExecute2 {set b 1} 0 1 postinside} 0 postinside + tracePostExecute2 {global info} 0 postinside + tracePostExecute2 {lrange {tracePostExecute {set b 1} 0 1 postinside} 0 2} 0 postinside + tracePostExecute2 {lindex {tracePostExecute {set b 1} 0 1 postinside} 4} 0 postinside + tracePostExecute2 {concat {tracePostExecute {set b 1} 0} postinside} 0 postinside + tracePostExecute {set b 1} 0 postinside + tracePostExecute2 {lappend info {tracePostExecute {set b 1} 0 postinside}} 0 postinside + tracePostExecute2 {tracePostExecute tracePostExecute {set b 1} 0 1 postinside} 0 postinside + } + + proc foo {a} { + set b $a + } + + proc traceDelete {cmd args} { + rename $cmd {} + global info + set info $args + } + + test trace-24.8 {delete command during before after and pre/post-inside traces} { + set info {} + trace add command foo before [list traceDelete foo] + trace add command foo after [list traceDelete foo] + trace add command foo preinside [list traceDelete foo] + trace add command foo postinside [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {{invalid command name "foo"} {{traceDelete foo {foo 1} before} preinside} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + + test trace-24.9 {delete command during before after and postinside traces} { + set info {} + trace add command foo before [list traceDelete foo] + trace add command foo after [list traceDelete foo] + trace add command foo postinside [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {{invalid command name "foo"} {{foo 1} before} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + + test trace-24.10 {delete command during after and postinside traces} { + set info {} + trace add command foo after [list traceDelete foo] + trace add command foo postinside [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {1 {{set b 1} 0 1 postinside} {unknown command "foo"}} + + proc foo {a} { + set b $a + } + + test trace-24.11 {delete command during before and preinside traces} { + set info {} + trace add command foo before [list traceDelete foo] + trace add command foo preinside [list traceDelete foo] + catch {foo 1} err + list $err $info [trace list command foo] + } {{invalid command name "foo"} {{traceDelete foo {foo 1} before} preinside} {unknown command "foo"}} + + # Delete procedures when done, so we don't clash with other tests + # (e.g. foobar will clash with 'unknown' tests). + catch {rename foobar {}} + catch {rename foo {}} + catch {rename bar {}} # cleanup ::tcltest::cleanupTests