? tests/trace-old.test Index: doc/trace.n =================================================================== RCS file: /cvsroot/tcl/doc/trace.n,v retrieving revision 1.3 diff -c -3 -r1.3 trace.n *** trace.n 2000/01/26 21:36:35 1.3 --- trace.n 2000/06/30 17:31:11 *************** *** 20,31 **** .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are ! invoked. At present, only variable tracing is implemented. The legal \fIoption\fR's (which may be abbreviated) are: .TP ! \fBtrace variable \fIname ops command\fR Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR ! is accessed in one of the ways given by \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array as a whole (i.e. \fIname\fR may be just the name of an array, with no parenthesized index). If \fIname\fR refers to a whole array, then --- 20,76 ---- .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are ! invoked. At present, only variable, execution and command tracing are ! implemented. The legal \fIoption\fR's (which may be abbreviated) are: .TP ! \fBtrace add \fItype name ops command\fR ! Where \fItype\fR is either 'command', 'execution' or 'variable'. ! .RS ! .PP ! \fBcommand\fI ! Arrange for \fIcommand\fR to be executed whenever command \fIname\fR ! is modified in one of the ways given by the list \fIops\fR. \fIName\fR will be ! resolved using the usual namespace resolution rules used by ! procedures. If the command does not exist, an error will be thrown. ! .RS ! .PP ! \fIOps\fR indicates which operations are of interest, and is a list of ! one or more of the following items: ! .TP ! \fBrename\fR ! Invoke \fIcommand\fR whenever the command is renamed. Note that ! renaming to the empty string is considered deletion, and will not ! be traced with '\fBrename\fR'. ! .TP ! \fBdelete\fR ! Invoke \fIcommand\fR when the command is deleted. Commands can be ! deleted explicitly by using the \fBrename\fR command to rename the ! 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 ! \fIOldName\fR and \fInewName\fR give the traced command's current ! (old) namename, and the name to which it is being renamed (the empty ! string if this is a 'delete' operation). ! \fIOp\fR indicates what operation is being performed on the ! variable, and is one of \fBrename\fR, \fBdelete\fR as ! defined above. The trace operation cannot be used to stop a command ! from being deleted. Tcl will always remove the command once the trace ! is complete. Recursive renaming or deleting will not cause further traces ! 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. ! .PP ! \fBvariable\fI Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR ! is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array as a whole (i.e. \fIname\fR may be just the name of an array, with no parenthesized index). If \fIname\fR refers to a whole array, then *************** *** 35,50 **** queries, but not to \fBinfo exists\fR queries. .RS .PP ! \fIOps\fR indicates which operations are of interest, and consists of ! one or more of the following letters: .TP ! \fBr\fR Invoke \fIcommand\fR whenever the variable is read. .TP ! \fBw\fR Invoke \fIcommand\fR whenever the variable is written. .TP ! \fBu\fR Invoke \fIcommand\fR whenever the variable is unset. Variables can be unset explicitly with the \fBunset\fR command, or implicitly when procedures return (all of their local variables --- 80,95 ---- queries, but not to \fBinfo exists\fR queries. .RS .PP ! \fIOps\fR indicates which operations are of interest, and is a list of ! one or more of the following items: .TP ! \fBread\fR Invoke \fIcommand\fR whenever the variable is read. .TP ! \fBwrite\fR Invoke \fIcommand\fR whenever the variable is written. .TP ! \fBunset\fR Invoke \fIcommand\fR whenever the variable is unset. Variables can be unset explicitly with the \fBunset\fR command, or implicitly when procedures return (all of their local variables *************** *** 70,76 **** command allows a procedure to reference a variable under a different name. \fIOp\fR indicates what operation is being performed on the ! variable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as defined above. .PP \fICommand\fR executes in the same context as the code that invoked --- 115,121 ---- command allows a procedure to reference a variable under a different name. \fIOp\fR indicates what operation is being performed on the ! variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as defined above. .PP \fICommand\fR executes in the same context as the code that invoked *************** *** 131,137 **** is invoked before the one on the element. .PP Once created, the trace remains in effect either until the ! trace is removed with the \fBtrace vdelete\fR command described below, until the variable is unset, or until the interpreter is deleted. Unsetting an element of array will remove any traces on that --- 176,182 ---- is invoked before the one on the element. .PP Once created, the trace remains in effect either until the ! trace is removed with the \fBtrace remove variable\fR command described below, until the variable is unset, or until the interpreter is deleted. Unsetting an element of array will remove any traces on that *************** *** 140,153 **** This command returns an empty string. .RE .TP ! \fBtrace vdelete \fIname ops command\fR If there is a trace set on variable \fIname\fR with the operations and command given by \fIops\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. .TP ! \fBtrace vinfo \fIname\fR Returns a list containing one element for each trace currently set on variable \fIname\fR. Each element of the list is itself a list containing two --- 185,229 ---- This command returns an empty string. .RE .TP ! \fBtrace remove \fItype name ops command\fR ! Where \fItype\fR is either 'command', 'execution' or 'variable'. ! .RS ! .PP ! \fBcommand\fI ! \fBtrace remove command \fIname ops command\fR ! If there is a trace set on command \fIname\fR with the ! operations and command given by \fIops\fR and \fIcommand\fR, ! then the trace is removed, so that \fIcommand\fR will never ! again be invoked. ! Returns an empty string, unless \fIname\fR doesn't ! exist, when the command will throw an error. ! .PP ! \fBvariable\fI ! \fBtrace remove variable \fIname ops command\fR If there is a trace set on variable \fIname\fR with the operations and command given by \fIops\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. + .RE .TP ! \fBtrace list \fItype name\fR ! Where \fItype\fR is either 'command', 'execution' or 'variable'. ! .RS ! .PP ! \fBcommand\fI ! \fBtrace list command \fIname\fR ! Returns a list containing one element for each trace ! currently set on command \fIname\fR. ! Each element of the list is itself a list containing two ! elements, which are the \fIops\fR and \fIcommand\fR associated ! with the trace. ! If \fIname\fR doesn't have any traces set, then ! the result of the command will be an empty string. If \fIname\fR doesn't ! exist, the command will throw an error. ! .PP ! \fBvariable\fI ! \fBtrace list variable \fIname\fR Returns a list containing one element for each trace currently set on variable \fIname\fR. Each element of the list is itself a list containing two *************** *** 155,160 **** with the trace. If \fIname\fR doesn't exist or doesn't have any traces set, then the result of the command will be an empty string. .SH KEYWORDS ! read, variable, write, trace, unset --- 231,286 ---- with the trace. If \fIname\fR doesn't exist or doesn't have any traces set, then the result of the command will be an empty string. + .RE + .PP + For backwards compatibility, three other subcommands are availble. + These are \fBtrace variable \fIname ops command\fR (equivalent to + \fBtrace add variable \fIname ops command\fR), + \fBtrace vdelete \fIname ops command\fR + (equivalent to \fBtrace remove variable \fIname ops command\fR) and + \fBtrace vinfo \fIname\fR (equivalent to \fBtrace list variable + \fIname\fR). These subcommands may be removed in a future version of + Tcl. They use an older syntax in which 'read', 'write', 'unset' are + replaced by 'r', 'w' and 'u' respectively, and the 'ops' argument is + not a list, but simply a string concatenation of the ops, such as 'rwu'. + + Trace add,remove,list execution -- this needs to be merged in above, + but my troff skills are nonexistent. Sorry. + + 'execution' traces are primarily useful as a debugging aid. They can + be used to capture the sequence of evaluations inside any procedure or + command, including their results. The entire captured sequence (for + one or more evaluations of that procedure/command) can then be retreived as a + large text string. + + trace add execution name ops ?-minlevel m -maxlevel n \ + -truncate t -depth d? + + Here 'ops' is a list of one or more of 'before' or 'after'. + + The '-minlevel' option specifies the minimum stack frame depth (in the + sense of 'info level') for which we will trace this command, and + '-maxlevel' the maximum such depth. If the procedure/command 'name' is + evaluated at a stack frame which lies between minlevel and maxlevel + (more precisely if minlevel >= level >= maxlevel), + then command execution tracing is turned on for all evaluations until + the given procedure/command returns -- i.e. each command/sub-procedure + evaluated is traced. The 'before' option means a record should be kept + of each command and its arguments, before the command is evaluated, and + 'after' means a record should be kept after (with the result of the + evaluation). Finally '-depth' restricts the relative stack frame + depth to which tracing will occur: e.g. '-depth 3' means we will + record the aforementioned information for each call which isn't more + than three levels deeper in the stack. The '-truncate' option + specifies how many characters of information should be stored for each + line of text captured. For example '-truncate 72', would provide a + reasonably output for a text window. + + Once the execution trace has been created, the sequence of evaluations + is captured internally. To retrieve a string containing that + sequence, use 'trace list execution name'. + + Execution traces are removed with 'trace remove execution name ops'. .SH KEYWORDS ! read, command, rename, variable, write, trace, unset Index: generic/tcl.decls =================================================================== RCS file: /cvsroot/tcl/generic/tcl.decls,v retrieving revision 1.35 diff -c -3 -r1.35 tcl.decls *** tcl.decls 2000/05/08 21:59:58 1.35 --- tcl.decls 2000/06/30 17:31:11 *************** *** 1387,1392 **** --- 1387,1409 ---- int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr, \ CONST Tcl_UniChar *pattern, int nocase) } + declare 403 generic { + Tcl_Trace Tcl_CreateTraceObj(Tcl_Interp* interp, Tcl_Obj* insideCmd, \ + int traceFlags, int maxLevel, int minLevel, \ + Tcl_CmdTraceObjProc *proc, ClientData clientData) + } + declare 404 generic { + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, char *varName, \ + int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData) + } + declare 405 generic { + int Tcl_TraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) + } + declare 406 generic { + void Tcl_UntraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) + } ############################################################################## Index: generic/tcl.h =================================================================== RCS file: /cvsroot/tcl/generic/tcl.h,v retrieving revision 1.72 diff -c -3 -r1.72 tcl.h *** tcl.h 2000/06/24 00:26:08 1.72 --- tcl.h 2000/06/30 17:31:12 *************** *** 558,563 **** --- 558,567 ---- 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 startLevel, 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, *************** *** 595,600 **** --- 599,606 ---- typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags)); + typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *oldName, char *newName, int flags)); typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd)); *************** *** 918,923 **** --- 924,954 ---- #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 + #ifndef TCL_REMOVE_OBSOLETE_TRACES + /* Required to support old variable/vdelete/vinfo traces */ + #define TCL_TRACE_OLD_STYLE 0x1000 + #endif + + /* + * Flag values passed to all trace-related procedures. + */ + + #define TCL_TRACE_COUNT 0x2000 + + /* + * Flag values passed to command-related procedures. Note + * that 'TCL_TRACE_COUNT' is also passed to command-related + * procedures. + */ + + #define TCL_TRACE_RENAME 0x4000 + #define TCL_TRACE_DELETE 0x8000 + + /* + * Flag values passed to Tcl_CreateTraceObj + */ + #define TCL_CMD_TRACE_BEFORE 1 + #define TCL_CMD_TRACE_AFTER 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.28 diff -c -3 -r1.28 tclBasic.c *** tclBasic.c 2000/05/23 22:10:49 1.28 --- tclBasic.c 2000/06/30 17:31:12 *************** *** 25,30 **** --- 25,33 ---- * Static procedures in this file: */ + static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, + Command *cmdPtr, char *oldName, + char* newName, int flags)); static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ProcessUnexpectedResult _ANSI_ARGS_(( Tcl_Interp *interp, int returnCode)); *************** *** 335,340 **** --- 338,344 ---- iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; + iPtr->executionTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ *************** *** 447,454 **** } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; ! cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } --- 451,459 ---- } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; ! cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } *************** *** 1047,1052 **** --- 1052,1058 ---- iPtr->appendResult = NULL; } TclFreePackageInfo(iPtr); + TclFreeTraceExecutionInfo(iPtr); while (iPtr->tracePtr != NULL) { Trace *nextPtr = iPtr->tracePtr->nextPtr; *************** *** 1498,1505 **** cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; ! cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; /* * Plug in any existing import references found above. Be sure --- 1504,1512 ---- cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; ! cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure *************** *** 1659,1666 **** cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; ! cmdPtr->deleted = 0; cmdPtr->importRefPtr = NULL; /* * Plug in any existing import references found above. Be sure --- 1666,1674 ---- cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; ! cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure *************** *** 1975,1980 **** --- 1983,1990 ---- return result; } + CallCommandTraces(iPtr,cmdPtr,oldName,newName,TCL_TRACE_RENAME); + /* * The new command name is okay, so remove the command from its * current namespace. This is like deleting the command, so bump *************** *** 2281,2287 **** * flag allows us to detect these cases and skip nested deletes. */ ! if (cmdPtr->deleted) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the --- 2291,2297 ---- * flag allows us to detect these cases and skip nested deletes. */ ! if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the *************** *** 2293,2298 **** --- 2303,2335 ---- return 0; } + /* + * We must delete this command, even though both traces and + * delete procs may try to avoid this (renaming the command etc). + * Also traces and delete procs may try to delete the command + * themsevles. This flag declares that a delete is in progress + * and that recursive deletes should be ignored. + */ + cmdPtr->flags |= CMD_IS_DELETED; + + /* + * Call trace procedures for the command being deleted. Then delete + * its traces. + */ + + if (cmdPtr->tracePtr != NULL) { + CommandTrace *tracePtr; + CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); + /* Now delete these traces */ + tracePtr = cmdPtr->tracePtr; + while (tracePtr != NULL) { + CommandTrace *nextPtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + tracePtr = nextPtr; + } + cmdPtr->tracePtr = NULL; + } + /* * If the command being deleted has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This *************** *** 2306,2312 **** iPtr->compileEpoch++; } - cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command --- 2343,2348 ---- *************** *** 2381,2386 **** --- 2417,2491 ---- TclCleanupCommand(cmdPtr); return 0; } + 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. */ + { + register CommandTrace *tracePtr; + ActiveCommandTrace active; + char *result; + if (cmdPtr->flags & CMD_TRACE_ACTIVE) { + /* + * While a rename trace is active, we will not process any more + * rename traces; while a delete trace is active we will not + * process any more delete traces + */ + if (cmdPtr->flags & TCL_TRACE_RENAME) { + flags &= ~TCL_TRACE_RENAME; + } + if (cmdPtr->flags & TCL_TRACE_DELETE) { + flags &= ~TCL_TRACE_DELETE; + } + if (flags == 0) { + return NULL; + } + } + cmdPtr->flags |= CMD_TRACE_ACTIVE; + cmdPtr->refCount++; + + result = NULL; + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + active.cmdPtr = cmdPtr; + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + cmdPtr->flags |= tracePtr->flags; + if (oldName == NULL) { + oldName = Tcl_GetCommandName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr); + } + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); + cmdPtr->flags &= ~tracePtr->flags; + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + cmdPtr->flags &= ~CMD_TRACE_ACTIVE; + cmdPtr->refCount--; + iPtr->activeCmdTracePtr = active.nextPtr; + return result; + } + /* *---------------------------------------------------------------------- *************** *** 3871,3881 **** tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; ! tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } --- 3976,4107 ---- tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; ! tracePtr->proc.stringProc = proc; ! tracePtr->traceFlags = 0; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; + return (Tcl_Trace) tracePtr; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_CreateTraceObj -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command, provided certain conditions + * are met. These conditions may include: current execution + * level is at least 'minLevel'; current execution level is at + * most 'maxLevel'; execution is currently inside the command/proc + * 'insideCmd'. For any given occasion on which those conditions + * are met, there are two times at which this procedure may + * be called: before the command is executed, and after the + * command is executed. Depending on the value to 'traceFlags' + * the procedure will be called in one or both of those situations. + * + * Calls to proc will have the following form: + * + * void + * proc(clientData, interp, level, startLevel, flags, code, + * command, length, currentCmd, objc, objv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * int startLevel; + * int flags; + * int code; + * char *command; + * int length; + * Tcl_Command currentCmd; + * int objc; + * struct Tcl_Obj *CONST objv[]; + * { + * } + * + * The clientData, interp and flags arguments to proc will be the + * same as the corresponding arguments to this procedure. Level + * gives the nesting level of command interpretation for this + * interpreter (0 corresponds to top level). StartLevel gives the + * level at which the first command trace was triggered (so + * Level-StartLevel gives a relative level). The first 'length' + * characters of Command gives the ASCII text of the raw command, + * and currentCmd is the Tcl_Command structure referring to the + * current command. will receive, and objc and objv give the + * arguments to the command, after any argument parsing and + * substitution. Proc does not return a value. + * + *---------------------------------------------------------------------- + */ + + Tcl_Trace + Tcl_CreateTraceObj(interp, insideCmd, traceFlags, maxLevel, minLevel, + proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + Tcl_Obj* insideCmd; /* Only activate this trace when execution + * is inside a call to this command, and + * after it is inside, later deactivate the + * trace when execution of this command is + * complete. */ + int traceFlags; /* Or'd combination of TCL_CMD_TRACE_ flags, + * to indicate whether to call the given + * procedure before command execution, + * or after command execution (with the + * result of the command execution). If + * zero, then equivalent to the default + * of tracing before and after. */ + int maxLevel; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). + * If zero, then ignore minimum level. */ + int minLevel; /* Only call proc for commands at nesting + * level>=argument level (1=>top level). + * If zero then ignore maximum level. */ + 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 = maxLevel; + tracePtr->proc.objProc = proc; + if((traceFlags & 3) == 0) { + tracePtr->traceFlags = TCL_CMD_TRACE_BEFORE | TCL_CMD_TRACE_AFTER; + } else { + tracePtr->traceFlags = traceFlags & 3; + } + tracePtr->clientData = clientData; + tracePtr->minLevel = minLevel; + tracePtr->cmdPtr = NULL; + if(insideCmd != NULL) { + tracePtr->cmdPtr = Tcl_FindCommand(interp, + Tcl_GetString(insideCmd), (Tcl_Namespace *) NULL, /*flags*/ 0); + } + tracePtr->tracingCmdDepth = 0; + tracePtr->tracingInitialDepth = 0; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; + return (Tcl_Trace) tracePtr; } Index: generic/tclCmdMZ.c =================================================================== RCS file: /cvsroot/tcl/generic/tclCmdMZ.c,v retrieving revision 1.27 diff -c -3 -r1.27 tclCmdMZ.c *** tclCmdMZ.c 2000/05/26 08:51:11 1.27 --- tclCmdMZ.c 2000/06/30 17:31:13 *************** *** 46,51 **** --- 46,53 ---- * to be invoked. */ char *errMsg; /* Error message returned from Tcl command, * or NULL. Malloc'ed. */ + int count; /* Number of times this trace has been + * called. */ size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to *************** *** 55,67 **** --- 57,121 ---- } TraceVarInfo; /* + * The same structure is used for command traces at present + */ + + typedef TraceVarInfo TraceCommandInfo; + + /* + * Structure used to hold information about execution traces: + */ + + typedef struct TraceExecutionInfo { + int flags; + Tcl_DString traceDetails; + Tcl_Trace tracePtr; + Tcl_Command cmdPtr; + int truncationLength; + int relativeDepth; + struct TraceExecutionInfo* nextPtr; + } TraceExecutionInfo; + + /* * Forward declarations for procedures defined in this file: */ + typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, int optionIndex, + int objc, Tcl_Obj *CONST objv[])); + + Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; + Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; + Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; + + /* + * Each subcommand has a number of 'types' to which it can apply. + * Currently 'command', 'execution' and 'variable' are the only + * types supported. These two arrays MUST be kept in sync! + * In the future we may provide an API to add to the list of + * supported trace types. + */ + static char *traceTypeOptions[] = { + "command", "execution", "variable", (char*) NULL + }; + static Tcl_TraceTypeObjCmd* traceSubCmds[] = { + TclTraceCommandObjCmd, + TclTraceExecutionObjCmd, + 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)); + + static Tcl_CmdTraceObjProc TraceExecutionProc; + static void TraceExecAddIndentTruncate _ANSI_ARGS_((Tcl_DString *ds, + int indent, int truncate, Tcl_DString *add)); + + /* *---------------------------------------------------------------------- * *************** *** 2469,2481 **** * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. - * *---------------------------------------------------------------------- */ --- 2523,2540 ---- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. + * + * Standard syntax as of Tcl 8.4 is + * + * trace {add|remove|list} {command|variable} name ops cmd + * trace execution * + * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ *************** *** 2488,2500 **** Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex, commandLength; ! char *name, *rwuOps, *command, *p; size_t length; static char *traceOptions[] = { ! "variable", "vdelete", "vinfo", (char *) NULL }; enum traceOptions { ! TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO }; if (objc < 2) { --- 2547,2568 ---- Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex, commandLength; ! char *name, *flagOps, *command, *p; size_t length; + /* Main sub commands to 'trace' */ static char *traceOptions[] = { ! "add", "list", "remove", ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! "variable", "vdelete", "vinfo", ! #endif ! (char *) NULL }; + /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { ! TRACE_ADD, TRACE_LIST, TRACE_REMOVE, ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO ! #endif }; if (objc < 2) { *************** *** 2507,2592 **** return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { ! case TRACE_VARIABLE: { ! int flags; ! TraceVarInfo *tvarPtr; ! if (objc != 5) { ! Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); ! return TCL_ERROR; } ! flags = 0; ! rwuOps = Tcl_GetString(objv[3]); ! for (p = rwuOps; *p != 0; p++) { ! if (*p == 'r') { ! flags |= TCL_TRACE_READS; ! } else if (*p == 'w') { ! flags |= TCL_TRACE_WRITES; ! } else if (*p == 'u') { ! flags |= TCL_TRACE_UNSETS; } else { ! goto badOps; } } ! if (flags == 0) { ! goto badOps; } ! command = Tcl_GetStringFromObj(objv[4], &commandLength); length = (size_t) commandLength; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; tvarPtr->errMsg = NULL; tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; strcpy(tvarPtr->command, command); ! name = Tcl_GetString(objv[2]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } ! break; ! } ! case TRACE_VDELETE: { ! int flags; ! TraceVarInfo *tvarPtr; ! ClientData clientData; ! ! if (objc != 5) { ! Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); ! return TCL_ERROR; ! } ! ! flags = 0; ! rwuOps = Tcl_GetString(objv[3]); ! for (p = rwuOps; *p != 0; p++) { ! if (*p == 'r') { ! flags |= TCL_TRACE_READS; ! } else if (*p == 'w') { ! flags |= TCL_TRACE_WRITES; ! } else if (*p == 'u') { ! flags |= TCL_TRACE_UNSETS; ! } else { ! goto badOps; ! } ! } ! if (flags == 0) { ! goto badOps; ! } ! /* * Search through all of our traces on this variable to * see if there's one with the given command. If so, then * delete the first one that matches. */ ! command = Tcl_GetStringFromObj(objv[4], &commandLength); ! length = (size_t) commandLength; clientData = 0; ! name = Tcl_GetString(objv[2]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; --- 2575,3260 ---- return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { ! case TRACE_ADD: ! case TRACE_REMOVE: ! case TRACE_LIST: { ! /* ! * All sub commands of trace add/remove must take at least ! * one more argument. Beyond that we let the subcommand itself ! * control the argument structure. ! */ ! int typeIndex; ! if (objc < 3) { ! Tcl_WrongNumArgs(interp, 2, objv, "option [arg 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); ! break; ! } ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! case TRACE_OLD_VARIABLE: { ! int flags; ! TraceVarInfo *tvarPtr; ! if (objc != 5) { ! Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); ! return TCL_ERROR; ! } ! ! flags = 0; ! flagOps = Tcl_GetString(objv[3]); ! for (p = flagOps; *p != 0; p++) { ! if (*p == 'r') { ! flags |= TCL_TRACE_READS; ! } else if (*p == 'w') { ! flags |= TCL_TRACE_WRITES; ! } else if (*p == 'u') { ! flags |= TCL_TRACE_UNSETS; ! } else { ! goto badVarOps; } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; + /* + * There is no way to access the count for old-style traces. + * However, we set it here to avoid purify-warnings about + * accessing unset memory. + */ + tvarPtr->count = 0; + flags |= TCL_TRACE_UNSETS; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; + } + case TRACE_OLD_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badVarOps; + } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + break; + } + case TRACE_OLD_VINFO: { + ClientData clientData; + char ops[4]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; ! pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); ! p = ops; ! if (tvarPtr->flags & TCL_TRACE_READS) { ! *p = 'r'; ! p++; ! } ! if (tvarPtr->flags & TCL_TRACE_WRITES) { ! *p = 'w'; ! p++; ! } ! if (tvarPtr->flags & TCL_TRACE_UNSETS) { ! *p = 'u'; ! p++; ! } ! *p = '\0'; ! ! /* ! * Build a pair (2-item list) with the ops string as ! * the first obj element and the tvarPtr->command string ! * as the second obj element. Append the pair (as an ! * element) to the end of the result object list. ! */ ! ! elemObjPtr = Tcl_NewStringObj(ops, -1); ! Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); ! elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); ! Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); ! Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); ! } ! Tcl_SetObjResult(interp, resultListPtr); ! break; ! } ! #endif /* TCL_REMOVE_OBSOLETE_TRACES */ ! default: { ! panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); ! } ! } ! return TCL_OK; ! ! badVarOps: ! Tcl_AppendResult(interp, "bad operations \"", flagOps, ! "\": should be one or more of rwu", (char *) NULL); ! return TCL_ERROR; ! } ! ! int ! TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) ! Tcl_Interp *interp; /* Current interpreter. */ ! int optionIndex; /* Add, list or remove */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument objects. */ ! { ! char *flagOps; ! Interp* iPtr = (Interp *)interp; ! TraceExecutionInfo *loopPtr, *prevPtr; ! Tcl_Command cmdPtr; ! enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; ! ! ExecutionTrace *traceInfoPtr = iPtr->executionTracePtr; ! if (traceInfoPtr == NULL) { ! /* ! * This is the first time we've dealing with execution traces in ! * this interpreter. We allocate the storage space for all future ! * execution traces. It will be freed when the interpreter is deleted ! */ ! iPtr->executionTracePtr = ! (ExecutionTrace *) ckalloc(sizeof(ExecutionTrace)); ! traceInfoPtr = iPtr->executionTracePtr; ! /* There are no current traces */ ! traceInfoPtr->traces = NULL; ! } ! ! switch ((enum traceOptions) optionIndex) { ! case TRACE_ADD: ! case TRACE_REMOVE: { ! int flags = 0; ! int min, max, truncate, relativeDepth, c; ! int i, listLen, result; ! Tcl_Obj **elemPtrs; ! if (objc < 5) { ! Tcl_WrongNumArgs(interp, 3, objv, "name ops ?options...?"); ! return TCL_ERROR; ! } ! /* ! * Make sure the ops argument is a list object and get its length and ! * a pointer to its array of element pointers. ! */ ! ! result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); ! if (result != TCL_OK) { ! return result; ! } ! if (listLen == 0) { ! flagOps = ""; ! goto badExecOps; ! } ! for (i=0;icmdPtr = cmdPtr; ! Tcl_DStringInit(&loopPtr->traceDetails); ! loopPtr->flags = flags; ! loopPtr->tracePtr = Tcl_CreateTraceObj(interp,objv[3],flags, ! max,min, ! TraceExecutionProc, ! (ClientData)loopPtr); ! loopPtr->truncationLength = truncate; ! loopPtr->relativeDepth = relativeDepth; ! loopPtr->nextPtr = traceInfoPtr->traces; ! traceInfoPtr->traces = loopPtr; ! } else { ! prevPtr = NULL; ! for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) { ! if(loopPtr->cmdPtr == cmdPtr && loopPtr->flags == flags) { ! Tcl_DeleteTrace(interp,loopPtr->tracePtr); ! Tcl_DStringFree(&loopPtr->traceDetails); ! if(prevPtr != NULL) { ! prevPtr->nextPtr = loopPtr->nextPtr; ! } else { ! traceInfoPtr->traces = NULL; ! } ! ckfree((char*)loopPtr); ! return TCL_OK; ! } ! prevPtr = loopPtr; } + Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[3]), + "\"", (char *) NULL); + return TCL_ERROR; + } + break; + } + case TRACE_LIST: { + Tcl_Obj *resultListPtr; + if (objc == 3) { + Tcl_Obj *resObj; + resultListPtr = Tcl_GetObjResult(interp); + resObj = Tcl_NewListObj(0,NULL); + for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) { + Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, loopPtr->cmdPtr, objPtr); + Tcl_ListObjAppendElement(interp,resObj,objPtr); + } + Tcl_SetObjResult(interp,resObj); + return TCL_OK; + } else { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + cmdPtr = Tcl_GetCommandFromObj(interp, objv[3]); + if(cmdPtr == NULL) { + Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[3]), + "\": must be the name of an existing command or procedure", + (char *) NULL); + return TCL_ERROR; + } + for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) { + if(loopPtr->cmdPtr == cmdPtr) { + Tcl_DStringResult(interp,&loopPtr->traceDetails); + return TCL_OK; + } + } + Tcl_AppendResult(interp, "There is no existing trace on \"", Tcl_GetString(objv[3]), + "\"", (char *) NULL); + return TCL_ERROR; + } + break; + } + } + return TCL_OK; + + badExecOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be a list of one or more of 'before', 'after'", (char *) NULL); + return TCL_ERROR; + } ! int ! TclTraceCommandObjCmd(interp, optionIndex, objc, objv) ! Tcl_Interp *interp; /* Current interpreter. */ ! int optionIndex; /* Add, list or remove */ ! int objc; /* Number of arguments. */ ! Tcl_Obj *CONST objv[]; /* Argument objects. */ ! { ! int commandLength; ! char *name, *command, *flagOps; ! size_t length; ! enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; ! ! switch ((enum traceOptions) optionIndex) { ! case TRACE_ADD: ! case TRACE_REMOVE: { ! int flags = 0; ! int i, listLen, result; ! Tcl_Obj **elemPtrs; ! if (objc < 6) { ! Tcl_WrongNumArgs(interp, 3, objv, "name ops ?--? ?-count? ?command?"); ! return TCL_ERROR; ! } ! /* ! * Make sure the ops argument is a list object and get its length and ! * a pointer to its array of element pointers. ! */ ! ! result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); ! if (result != TCL_OK) { ! return result; ! } ! if (listLen == 0) { ! flagOps = ""; ! goto badCmdOps; ! } ! for (i=0;icommand) ! + length + 1)); ! tcmdPtr->flags = flags; ! tcmdPtr->errMsg = NULL; ! tcmdPtr->count = 0; ! tcmdPtr->length = length; ! flags |= TCL_TRACE_DELETE; ! strcpy(tcmdPtr->command, command); ! name = Tcl_GetString(objv[3]); ! if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, ! (ClientData) tcmdPtr) != TCL_OK) { ! ckfree((char *) tcmdPtr); ! return TCL_ERROR; ! } ! } else { ! /* ! * Search through all of our traces on this command to ! * see if there's one with the given command. If so, then ! * delete the first one that matches. ! */ ! ! TraceCommandInfo *tcmdPtr; ! ClientData clientData; ! command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[3]); + 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; + } + } + } + break; + } + case TRACE_LIST: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Build a list with the ops list as + * the first obj element, the tcmdPtr->command string + * as the second obj element, and the count as the + * third obj element. Append the triplet (as an + * element) to the end of the result object list. + * + * If the TCL_TRACE_COUNT flag is not given, we + * do not provide the counting information. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("rename",6)); + } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("delete",6)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + if (tcmdPtr->flags & TCL_TRACE_COUNT) { + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, Tcl_NewStringObj("-count",6)); + } + + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + if (tcmdPtr->flags & TCL_TRACE_COUNT) { + elemObjPtr = Tcl_NewIntObj(tcmdPtr->count); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + } + Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; + + badCmdOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be a list of one or more of 'rename', 'delete'", (char *) NULL); + return TCL_ERROR; + } + + int + TclTraceVariableObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, list or remove */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ + { + int commandLength; + char *name, *flagOps, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc < 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name ops ?--? ?-count? ?command?"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object and get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + flagOps = ""; + goto badVarOps; + } + for (i=0;icommand) + length + 1)); tvarPtr->flags = flags; tvarPtr->errMsg = NULL; tvarPtr->length = length; + tvarPtr->count = 0; flags |= TCL_TRACE_UNSETS; strcpy(tvarPtr->command, command); ! name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } ! } else { /* * Search through all of our traces on this variable to * see if there's one with the given command. If so, then * delete the first one that matches. */ ! TraceVarInfo *tvarPtr; ! ClientData clientData; ! if (objc == 6) { ! command = Tcl_GetStringFromObj(objv[5], &commandLength); ! length = (size_t) commandLength; ! } else { ! command = ""; ! length = (size_t) 0; ! } clientData = 0; ! name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; *************** *** 2602,2669 **** break; } } - break; } ! case TRACE_VINFO: { ! ClientData clientData; ! char ops[4]; ! Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; ! if (objc != 3) { ! Tcl_WrongNumArgs(interp, 2, objv, "name"); ! return TCL_ERROR; ! } ! resultListPtr = Tcl_GetObjResult(interp); ! clientData = 0; ! name = Tcl_GetString(objv[2]); ! while ((clientData = Tcl_VarTraceInfo(interp, name, 0, ! TraceVarProc, clientData)) != 0) { ! TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; ! pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); ! p = ops; ! if (tvarPtr->flags & TCL_TRACE_READS) { ! *p = 'r'; ! p++; ! } ! if (tvarPtr->flags & TCL_TRACE_WRITES) { ! *p = 'w'; ! p++; ! } ! if (tvarPtr->flags & TCL_TRACE_UNSETS) { ! *p = 'u'; ! p++; ! } ! *p = '\0'; ! /* ! * Build a pair (2-item list) with the ops string as ! * the first obj element and the tvarPtr->command string ! * as the second obj element. Append the pair (as an ! * element) to the end of the result object list. ! */ ! elemObjPtr = Tcl_NewStringObj(ops, -1); ! Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); ! elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); ! Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); ! Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); } ! Tcl_SetObjResult(interp, resultListPtr); ! break; ! } ! default: { ! panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); } } return TCL_OK; ! badOps: ! Tcl_AppendResult(interp, "bad operations \"", rwuOps, ! "\": should be one or more of rwu", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- --- 3270,3744 ---- break; } } } ! break; ! } ! case TRACE_LIST: { ! ClientData clientData; ! Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; ! if (objc != 4) { ! Tcl_WrongNumArgs(interp, 3, objv, "name"); ! return TCL_ERROR; ! } ! resultListPtr = Tcl_GetObjResult(interp); ! clientData = 0; ! name = Tcl_GetString(objv[3]); ! while ((clientData = Tcl_VarTraceInfo(interp, name, 0, ! TraceVarProc, clientData)) != 0) { ! TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; ! eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); ! /* ! * Build a list with the ops list as ! * the first obj element, the tcmdPtr->command string ! * as the second obj element, and the count as the ! * third obj element. Append the triplet (as an ! * element) to the end of the result object list. ! * ! * If the TCL_TRACE_COUNT flag is not given, we ! * do not provide the counting information. ! */ ! elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); ! if (tvarPtr->flags & TCL_TRACE_READS) { ! Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("read",4)); ! } ! if (tvarPtr->flags & TCL_TRACE_WRITES) { ! Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("write",5)); ! } ! if (tvarPtr->flags & TCL_TRACE_UNSETS) { ! Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset",5)); ! } ! Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); ! if (tvarPtr->flags & TCL_TRACE_COUNT) { ! Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, Tcl_NewStringObj("-count",6)); } ! ! elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); ! Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); ! if (tvarPtr->flags & TCL_TRACE_COUNT) { ! elemObjPtr = Tcl_NewIntObj(tvarPtr->count); ! Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); ! } ! Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } + Tcl_SetObjResult(interp, resultListPtr); + break; + } } return TCL_OK; ! badVarOps: ! Tcl_AppendResult(interp, "bad operations \"", flagOps, ! "\": should be a list of one or more of 'read', 'write' or 'unset'", (char *) NULL); return TCL_ERROR; } + + + /* + *---------------------------------------------------------------------- + * + * Tcl_CommandTraceInfo -- + * + * Return the clientData value associated with a trace on a + * command. This procedure can also be used to step through + * all of the traces on a particular command that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given command. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the command + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + ClientData + Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + char *cmdName; /* Name of command. */ + int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ + { + Command *cmdPtr; + register CommandTrace *tracePtr; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = cmdPtr->tracePtr; + 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; + } + } + return NULL; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_TraceCommand -- + * + * Arrange for rename/deletes to a command to cause a + * procedure to be invoked, which can monitor the operations. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the command given by cmdName, such that + * future changes to the command will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + + int + Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which command is + * 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. */ + { + Command *cmdPtr; + register CommandTrace *tracePtr; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + 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; + } + + /* + *---------------------------------------------------------------------- + * + * Tcl_UntraceCommand -- + * + * Remove a previously-created trace for a command. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the command given by cmdName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + + void + Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) + 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. */ + { + register CommandTrace *tracePtr; + CommandTrace *prevPtr; + 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; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + cmdPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); + } + + /* + *---------------------------------------------------------------------- + * + * TclFreeTraceExecutionInfo -- + * + * This procedure is invoked when an interpreter is being deleted + * to free up any memory allocated by execution traces. + * + * Results: + * None. + * + * Side effects: + * Frees all memory associated with execution traces, sets the + * interpreter's executionTracePtr to NULL. + * + *---------------------------------------------------------------------- + */ + void TclFreeTraceExecutionInfo(Interp *iPtr) { + TraceExecutionInfo *loopPtr, *prevPtr; + ExecutionTrace *traceInfoPtr = iPtr->executionTracePtr; + if (traceInfoPtr != NULL) { + for(loopPtr = traceInfoPtr->traces; loopPtr != NULL; loopPtr = loopPtr->nextPtr) { + Tcl_DStringFree(&loopPtr->traceDetails); + Tcl_DeleteTrace((Tcl_Interp*)iPtr,loopPtr->tracePtr); + prevPtr= loopPtr; + loopPtr = loopPtr->nextPtr; + ckfree((char*)prevPtr); + } + ckfree((char*)traceInfoPtr); + iPtr->executionTracePtr = NULL; + } + } + + /* + *---------------------------------------------------------------------- + * + * TraceExecutionProc -- + * + * This procedure is invoked whenever code relevant to a + * 'trace execution' command is executed. + * + * Results: + * None. + * + * Side effects: + * Stores information about what is currently executing in the + * Tcl_DString associated with this execution trace. + * + *---------------------------------------------------------------------- + */ + void TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, + int level, int startLevel, int flags, int code, + char* command, int length, Tcl_Command cmdInfo, + int objc, struct Tcl_Obj *CONST objv[]) { + Tcl_DString ds; + TraceExecutionInfo* traceInfoPtr = (TraceExecutionInfo*)clientData; + /* Cut-off anything deeper than this */ + if (traceInfoPtr->relativeDepth > 0 && (level-startLevel > traceInfoPtr->relativeDepth)) { + return; + } + if (flags & TCL_CMD_TRACE_BEFORE) { + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, "'", 1); + Tcl_DStringAppend(&ds, command, length); + Tcl_DStringAppend(&ds, "'", 1); + Tcl_DStringAppend(&ds, "\n", 1); + TraceExecAddIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds); + Tcl_DStringFree(&ds); + } + if (flags & TCL_CMD_TRACE_AFTER) { + int i; + Tcl_DStringInit(&ds); + for (i = 0; i < objc; i++) { + char* str; + int len; + str = Tcl_GetStringFromObj(objv[i],&len); + Tcl_DStringAppend(&ds, str, len); + Tcl_DStringAppend(&ds, " ", 1); + } + Tcl_DStringAppend(&ds, "\n", 1); + TraceExecAddIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds); + Tcl_DStringFree(&ds); + } + if (flags & TCL_CMD_TRACE_AFTER) { + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, code == TCL_ERROR ? "ERROR: " : "OK: ", -1); + Tcl_DStringAppend(&ds, Tcl_GetStringResult(interp), -1); + Tcl_DStringAppend(&ds, "\n", 1); + TraceExecAddIndentTruncate(&traceInfoPtr->traceDetails,level-startLevel,traceInfoPtr->truncationLength,&ds); + Tcl_DStringFree(&ds); + } + } + + /* + *---------------------------------------------------------------------- + * + * TraceExecAddIndentTruncate -- + * + * Helper procedure to ensure proper formatting of execution + * traces. Called by TraceExecutionProc + * + * Results: + * None. + * + * Side effects: + * Stores information in the Tcl_DString passed in. + * + *---------------------------------------------------------------------- + */ + void TraceExecAddIndentTruncate(Tcl_DString *ds, int indent, int truncate, Tcl_DString *add) { + int i; + for (i = 1; i < indent; i++) { + Tcl_DStringAppend(ds, " ", 1); + } + if(truncate > 0 && (truncate - indent < Tcl_DStringLength(add))) { + Tcl_DStringAppend(ds, Tcl_DStringValue(add), truncate - indent); + Tcl_DStringAppend(ds,"...\n",4); + } else { + Tcl_DStringAppend(ds, Tcl_DStringValue(add), Tcl_DStringLength(add)); + } + } + + /* + *---------------------------------------------------------------------- + * + * TraceCommandProc -- + * + * This procedure is called to handle command changes that have + * been traced using the "trace" command. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ + static void + TraceCommandProc(clientData, interp, oldName, newName, flags) + ClientData clientData; /* Information about the command trace. */ + Tcl_Interp *interp; /* Interpreter containing command. */ + char *oldName; /* Name of command being changed. */ + 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 + * information. */ + { + Tcl_SavedResult state; + 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)) { + /* Increment the counter for this trace */ + tcmdPtr->count++; + + /* + * Generate a command to execute by appending list elements + * for the old and new command name and the operation. + */ + + if (newName == NULL) { + newName = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, newName); + if (flags & TCL_TRACE_RENAME) { + Tcl_DStringAppend(&cmd, " rename", 7); + } else if (flags & TCL_TRACE_DELETE) { + Tcl_DStringAppend(&cmd, " delete", 7); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + } + ckfree((char *) tcmdPtr); + } + return; + } /* *---------------------------------------------------------------------- *************** *** 2706,2755 **** tvarPtr->errMsg = NULL; } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { ! ! /* ! * Generate a command to execute by appending list elements ! * for the two variable names and the operation. The five ! * extra characters are for three space, the opcode character, ! * and the terminating null. ! */ ! if (name2 == NULL) { ! name2 = ""; ! } ! Tcl_DStringInit(&cmd); ! Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); ! Tcl_DStringAppendElement(&cmd, name1); ! Tcl_DStringAppendElement(&cmd, name2); ! if (flags & TCL_TRACE_READS) { ! Tcl_DStringAppend(&cmd, " r", 2); ! } else if (flags & TCL_TRACE_WRITES) { ! Tcl_DStringAppend(&cmd, " w", 2); ! } else if (flags & TCL_TRACE_UNSETS) { ! Tcl_DStringAppend(&cmd, " u", 2); ! } ! /* ! * Execute the command. Save the interp's result used for ! * the command. We discard any object result the command returns. ! */ ! Tcl_SaveResult(interp, &state); ! code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); ! if (code != TCL_OK) { /* copy error msg to result */ ! char *string; ! int length; ! ! string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); ! tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); ! memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); ! result = tvarPtr->errMsg; ! } ! Tcl_RestoreResult(interp, &state); ! Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { result = NULL; --- 3781,3846 ---- tvarPtr->errMsg = NULL; } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { ! /* Increment the counter for this trace */ ! tvarPtr->count++; ! if (tvarPtr->length != (size_t) 0) { ! /* ! * Generate a command to execute by appending list elements ! * for the two variable names and the operation. ! */ ! if (name2 == NULL) { ! name2 = ""; ! } ! Tcl_DStringInit(&cmd); ! Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); ! Tcl_DStringAppendElement(&cmd, name1); ! Tcl_DStringAppendElement(&cmd, name2); ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { ! if (flags & TCL_TRACE_READS) { ! Tcl_DStringAppend(&cmd, " r", 2); ! } else if (flags & TCL_TRACE_WRITES) { ! Tcl_DStringAppend(&cmd, " w", 2); ! } else if (flags & TCL_TRACE_UNSETS) { ! Tcl_DStringAppend(&cmd, " u", 2); ! } ! } else { ! #endif ! if (flags & TCL_TRACE_READS) { ! Tcl_DStringAppend(&cmd, " read", 5); ! } else if (flags & TCL_TRACE_WRITES) { ! Tcl_DStringAppend(&cmd, " write", 6); ! } else if (flags & TCL_TRACE_UNSETS) { ! Tcl_DStringAppend(&cmd, " unset", 6); ! } ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! } ! #endif ! ! /* ! * Execute the command. Save the interp's result used for ! * the command. We discard any object result the command returns. ! */ ! Tcl_SaveResult(interp, &state); ! code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); ! if (code != TCL_OK) { /* copy error msg to result */ ! char *string; ! int length; ! ! string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); ! tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); ! memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); ! result = tvarPtr->errMsg; ! } ! Tcl_RestoreResult(interp, &state); ! Tcl_DStringFree(&cmd); ! } } if (flags & TCL_TRACE_DESTROYED) { result = NULL; Index: generic/tclDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclDecls.h,v retrieving revision 1.36 diff -c -3 -r1.36 tclDecls.h *** tclDecls.h 2000/05/08 21:59:59 1.36 --- tclDecls.h 2000/06/30 17:31:13 *************** *** 1254,1259 **** --- 1254,1280 ---- EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_(( CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); + /* 403 */ + EXTERN Tcl_Trace Tcl_CreateTraceObj _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* insideCmd, int traceFlags, + int maxLevel, int minLevel, + Tcl_CmdTraceObjProc * proc, + ClientData clientData)); + /* 404 */ + EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_(( + Tcl_Interp * interp, char * varName, + int flags, Tcl_CommandTraceProc * procPtr, + ClientData prevClientData)); + /* 405 */ + EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); + /* 406 */ + EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; *************** *** 1724,1729 **** --- 1745,1754 ---- int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 400 */ int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 401 */ int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 402 */ + Tcl_Trace (*tcl_CreateTraceObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* insideCmd, int traceFlags, int maxLevel, int minLevel, Tcl_CmdTraceObjProc * proc, ClientData clientData)); /* 403 */ + ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 404 */ + int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 405 */ + void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 406 */ } TclStubs; #ifdef __cplusplus *************** *** 3380,3385 **** --- 3405,3426 ---- #ifndef Tcl_UniCharCaseMatch #define Tcl_UniCharCaseMatch \ (tclStubsPtr->tcl_UniCharCaseMatch) /* 402 */ + #endif + #ifndef Tcl_CreateTraceObj + #define Tcl_CreateTraceObj \ + (tclStubsPtr->tcl_CreateTraceObj) /* 403 */ + #endif + #ifndef Tcl_CommandTraceInfo + #define Tcl_CommandTraceInfo \ + (tclStubsPtr->tcl_CommandTraceInfo) /* 404 */ + #endif + #ifndef Tcl_TraceCommand + #define Tcl_TraceCommand \ + (tclStubsPtr->tcl_TraceCommand) /* 405 */ + #endif + #ifndef Tcl_UntraceCommand + #define Tcl_UntraceCommand \ + (tclStubsPtr->tcl_UntraceCommand) /* 406 */ #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.14 diff -c -3 -r1.14 tclExecute.c *** tclExecute.c 2000/06/06 19:34:52 1.14 --- tclExecute.c 2000/06/30 17:31:15 *************** *** 210,216 **** 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, --- 210,216 ---- static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, Trace *tracePtr, Command *cmdPtr, char *command, int numChars, ! int objc, Tcl_Obj *CONST objv[])); static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, *************** *** 734,739 **** --- 734,741 ---- 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]; *************** *** 791,813 **** */ 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(); ! } ! } ! } } /* --- 793,803 ---- */ if (iPtr->tracePtr != NULL) { ! command = GetSrcInfoForPc(pc, codePtr, &numChars); ! DECACHE_STACK_INFO(); ! TclCheckTraces(interp,command,numChars,cmdPtr,TCL_OK, ! TCL_CMD_TRACE_BEFORE,objc,objv); ! CACHE_STACK_INFO(); } /* *************** *** 864,869 **** --- 854,869 ---- } /* + * Call 'after' command traces. + */ + if (iPtr->tracePtr != NULL) { + DECACHE_STACK_INFO(); + TclCheckTraces(interp,command,numChars,cmdPtr,result, + TCL_CMD_TRACE_AFTER,objc,objv); + CACHE_STACK_INFO(); + } + + /* * Pop the objc top stack elements and decrement their ref * counts. */ *************** *** 3299,3304 **** --- 3299,3407 ---- /* *---------------------------------------------------------------------- * + * TclCheckTraces -- + * + * 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 + TclCheckTraces(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; + int curLevel; + + if (command == NULL) { + return; + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + for (tracePtr = iPtr->tracePtr;tracePtr != NULL;tracePtr = tracePtr->nextPtr) { + if (tracePtr->level != 0 && curLevel > tracePtr->level) { + continue; + } + if (tracePtr->traceFlags != 0) { + /* The trace was created with Tcl_CreateTraceObj */ + if (curLevel < tracePtr->minLevel) { + continue; + } + + if (traceFlags & TCL_CMD_TRACE_BEFORE) { + if (tracePtr->cmdPtr != NULL) { + if (tracePtr->tracingCmdDepth == 0) { + if (cmdPtr == (Command*)tracePtr->cmdPtr) { + tracePtr->tracingInitialDepth = curLevel; + } else { + continue; + } + } + /* If we reach here, we are inside the command + * we wish to trace. */ + tracePtr->tracingCmdDepth++; + } + if (tracePtr->traceFlags & TCL_CMD_TRACE_BEFORE) { + (*tracePtr->proc.objProc)(tracePtr->clientData, interp, + curLevel, tracePtr->tracingInitialDepth, + TCL_CMD_TRACE_BEFORE, 0, + command, numChars, (Tcl_Command)cmdPtr, + objc, objv); + } + } else { + if (tracePtr->cmdPtr != NULL) { + if (tracePtr->tracingCmdDepth == 0) { + continue; + } + /* If we reach here, we are inside the command + * we wish to trace. */ + tracePtr->tracingCmdDepth--; + } + if (tracePtr->traceFlags & TCL_CMD_TRACE_AFTER) { + (*tracePtr->proc.objProc)(tracePtr->clientData, interp, + curLevel, tracePtr->tracingInitialDepth, + tracePtr->traceFlags & TCL_CMD_TRACE_AFTER, + result, command, numChars, (Tcl_Command)cmdPtr, + objc, objv); + } + } + } else { + /* The trace was created with Tcl_CreateTrace */ + /* These traces only trigger before the command is executed */ + if (traceFlags & TCL_CMD_TRACE_BEFORE) { + CallTraceProcedure(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); + } + } + } + } + + + /* + *---------------------------------------------------------------------- + * * CallTraceProcedure -- * * Invokes a trace procedure registered with an interpreter. These *************** *** 3325,3331 **** 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; --- 3428,3434 ---- 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; *************** *** 3357,3363 **** * 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); --- 3460,3466 ---- * 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); Index: generic/tclInt.decls =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.decls,v retrieving revision 1.21 diff -c -3 -r1.21 tclInt.decls *** tclInt.decls 2000/05/19 21:30:16 1.21 --- tclInt.decls 2000/06/30 17:31:15 *************** *** 607,613 **** declare 161 generic { void TclChannelEventScriptInvoker(ClientData clientData, int mask) } ! ############################################################################## # Define the platform specific internal Tcl interface. These functions are --- 607,620 ---- declare 161 generic { void TclChannelEventScriptInvoker(ClientData clientData, int mask) } ! declare 162 generic { ! void TclCheckTraces (Tcl_Interp *interp, char *command, int numChars, \ ! Command *cmdPtr, int result, int traceFlags, int objc, \ ! Tcl_Obj *CONST objv[]) ! } ! declare 163 generic { ! void TclFreeTraceExecutionInfo(Interp *iPtr) ! } ############################################################################## # Define the platform specific internal Tcl interface. These functions are Index: generic/tclInt.h =================================================================== RCS file: /cvsroot/tcl/generic/tclInt.h,v retrieving revision 1.45 diff -c -3 -r1.45 tclInt.h *** tclInt.h 2000/05/26 08:51:44 1.45 --- tclInt.h 2000/06/30 17:31:16 *************** *** 270,275 **** --- 270,304 ---- } VarTrace; /* + * The following structure defines a command trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a command. + */ + + typedef struct CommandTrace { + Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on command. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + struct CommandTrace *nextPtr; /* Next in list of traces associated with + * 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 + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ + } ActiveCommandTrace; + + /* * When a variable trace is active (i.e. its associated procedure is * executing), one of the following structures is linked into a list * associated with the variable's interpreter. The information in *************** *** 290,295 **** --- 319,334 ---- } ActiveVarTrace; /* + * Each interpreter may have any number of execution traces + * active. This structure is used to contain a list of all such + * traces. + */ + + typedef struct ExecutionTrace { + struct TraceExecutionInfo* traces; + } ExecutionTrace; + + /* * The following structure describes an enumerative search in progress on * an array variable; this are invoked with options to the "array" * command. *************** *** 612,622 **** */ 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; /* --- 651,676 ---- */ 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 traceFlags; /* If zero, then this is an old trace ! * strcture, and the following fields are ! * ignored. Otherwise it is an or'd ! * combination of TCL_CMD_TRACE_ flags. ! * Old trace structures use the 'proc' ! * above, new ones use 'objProc'. */ ! int minLevel; /* Only trace commands at nesting level ! * greater than or equal to this. */ ! Tcl_Command cmdPtr; /* Only trace inside this command */ ! int tracingCmdDepth; /* Used to keep track of depth. */ ! int tracingInitialDepth; /* Used to keep track of depth. */ } Trace; /* *************** *** 1020,1029 **** /* Procedure invoked when deleting command * to, e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ ! int deleted; /* Means that the command is in the process ! * of being deleted (its deleteProc is ! * currently executing). Other attempts to ! * delete the command should be ignored. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands --- 1074,1081 ---- /* Procedure invoked when deleting command * to, e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ ! int flags; /* Miscellaneous bits of information about ! * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands *************** *** 1031,1039 **** --- 1083,1113 ---- * command. The list is used to remove all * those imported commands when deleting * this "real" command. */ + CommandTrace *tracePtr; /* First in list of all traces set for this + * command. */ } Command; /* + * Flag bits for commands. + * + * CMD_IS_DELETED - Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Other attempts to + * delete the command should be ignored. + * CMD_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a rename/delete change. + * See the two flags below for which is + * currently being processed. + * 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 + * recursive deletes will not be traced. + * (these last two flags are defined in tcl.h) + */ + #define CMD_IS_DELETED 0x1 + #define CMD_TRACE_ACTIVE 0x2 + + /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- *************** *** 1248,1253 **** --- 1322,1334 ---- * accessed directly; see comment above. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + ExecutionTrace *executionTracePtr; + /* First in list of execution traces + * for interp, or NULL if no execution + * traces. */ + ActiveCommandTrace *activeCmdTracePtr; + /* First in list of active command traces for + * interp, or NULL if no active traces. */ /* * Statistical information about the bytecode compiler and interpreter's * operation. Index: generic/tclIntDecls.h =================================================================== RCS file: /cvsroot/tcl/generic/tclIntDecls.h,v retrieving revision 1.20 diff -c -3 -r1.20 tclIntDecls.h *** tclIntDecls.h 2000/05/19 21:30:16 1.20 --- tclIntDecls.h 2000/06/30 17:31:16 *************** *** 527,532 **** --- 527,539 ---- /* 161 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int mask)); + /* 162 */ + EXTERN void TclCheckTraces _ANSI_ARGS_((Tcl_Interp * interp, + char * command, int numChars, + Command * cmdPtr, int result, int traceFlags, + int objc, Tcl_Obj *CONST objv[])); + /* 163 */ + EXTERN void TclFreeTraceExecutionInfo _ANSI_ARGS_((Interp * iPtr)); typedef struct TclIntStubs { int magic; *************** *** 726,731 **** --- 733,740 ---- 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 (*tclCheckTraces) _ANSI_ARGS_((Tcl_Interp * interp, char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 162 */ + void (*tclFreeTraceExecutionInfo) _ANSI_ARGS_((Interp * iPtr)); /* 163 */ } TclIntStubs; #ifdef __cplusplus *************** *** 1376,1381 **** --- 1385,1398 ---- #ifndef TclChannelEventScriptInvoker #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 161 */ + #endif + #ifndef TclCheckTraces + #define TclCheckTraces \ + (tclIntStubsPtr->tclCheckTraces) /* 162 */ + #endif + #ifndef TclFreeTraceExecutionInfo + #define TclFreeTraceExecutionInfo \ + (tclIntStubsPtr->tclFreeTraceExecutionInfo) /* 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 -3 -r1.13 tclParse.c *** tclParse.c 1999/11/10 02:51:57 1.13 --- tclParse.c 2000/06/30 17:31: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 ---- *************** *** 880,923 **** * 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); } /* --- 878,886 ---- * Call trace procedures if needed. */ ! if (iPtr->tracePtr != NULL) { ! TclCheckTraces(interp, command, length, cmdPtr, TCL_OK, ! TCL_CMD_TRACE_BEFORE, objc, objv); } /* *************** *** 946,951 **** --- 909,922 ---- (void) Tcl_GetObjResult(interp); } + /* + * Call 'after' command traces + */ + if (iPtr->tracePtr != NULL) { + TclCheckTraces(interp,command, length, cmdPtr, code, + TCL_CMD_TRACE_AFTER, 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 --- 965,975 ---- /* * EvalObjv will increment numLevels so use "<" rather than "<=" */ ! if ((tracePtr->level == 0 || (iPtr->numLevels < tracePtr->level)) ! && !(tracePtr->traceFlags != 0 ! && (iPtr->numLevels < (tracePtr->minLevel - 1)))) { ! /* It's either an old-style trace, or a new-style trace ! * whose level is acceptable. */ 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; } --- 1362,1377 ---- } /* ! * 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.38 diff -c -3 -r1.38 tclStubInit.c *** tclStubInit.c 2000/05/19 21:30:16 1.38 --- tclStubInit.c 2000/06/30 17:31:16 *************** *** 237,242 **** --- 237,244 ---- TclGetStartupScriptFileName, /* 159 */ TclpMatchFilesTypes, /* 160 */ TclChannelEventScriptInvoker, /* 161 */ + TclCheckTraces, /* 162 */ + TclFreeTraceExecutionInfo, /* 163 */ }; TclIntPlatStubs tclIntPlatStubs = { *************** *** 801,806 **** --- 803,812 ---- Tcl_IsChannelExisting, /* 400 */ Tcl_UniCharNcasecmp, /* 401 */ Tcl_UniCharCaseMatch, /* 402 */ + Tcl_CreateTraceObj, /* 403 */ + Tcl_CommandTraceInfo, /* 404 */ + Tcl_TraceCommand, /* 405 */ + Tcl_UntraceCommand, /* 406 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclVar.c =================================================================== RCS file: /cvsroot/tcl/generic/tclVar.c,v retrieving revision 1.19 diff -c -3 -r1.19 tclVar.c *** tclVar.c 2000/06/01 00:33:27 1.19 --- tclVar.c 2000/06/30 17:31:17 *************** *** 2310,2316 **** Var *varPtr, *arrayPtr; register VarTrace *tracePtr; ! varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; --- 2310,2323 ---- Var *varPtr, *arrayPtr; register VarTrace *tracePtr; ! /* ! * We strip 'flags' down to just the parts which are relevant to ! * TclLookupVar, to avoid conflicts between trace flags and ! * internal namespace flags such as 'FIND_ONLY_NS'. This can ! * now occur since we have trace flags with values 0x1000 and higher. ! */ ! varPtr = TclLookupVar(interp, part1, part2, ! (flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY) | TCL_LEAVE_ERR_MSG), "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; *************** *** 2325,2331 **** tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | ! TCL_TRACE_ARRAY); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; --- 2332,2342 ---- tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | ! TCL_TRACE_ARRAY | ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! TCL_TRACE_OLD_STYLE | ! #endif ! TCL_TRACE_COUNT); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; *************** *** 2413,2419 **** } flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | ! TCL_TRACE_ARRAY); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { --- 2424,2434 ---- } flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | ! TCL_TRACE_ARRAY | ! #ifndef TCL_REMOVE_OBSOLETE_TRACES ! TCL_TRACE_OLD_STYLE | ! #endif ! TCL_TRACE_COUNT); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { Index: tests/trace.test =================================================================== RCS file: /cvsroot/tcl/tests/trace.test,v retrieving revision 1.6 diff -c -3 -r1.6 trace.test *** trace.test 2000/04/10 17:19:05 1.6 --- trace.test 2000/06/30 17:31:21 *************** *** 52,108 **** proc traceCrtElement {value name1 name2 op} { uplevel set ${name1}($name2) $value } ! # Read-tracing on variables test trace-1.1 {trace variable reads} { catch {unset x} set info {} ! trace var x r traceScalar list [catch {set x} msg] $msg $info ! } {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { catch {unset x} set x 123 set info {} ! trace var x r traceScalar list [catch {set x} msg] $msg $info ! } {0 123 {x {} r 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} ! trace var x r traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} ! trace var x(2) r traceArray list [catch {set x(2)} msg] $msg $info ! } {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { catch {unset x} set x(2) zzz set info {} ! trace var x(2) r traceArray list [catch {set x(2)} msg] $msg $info ! } {0 zzz {x 2 r 0 zzz}} test trace-1.6 {trace array element reads} { catch {unset x} set info {} ! trace variable x r traceArray2 proc p {} { global x set x(2) willi return $x(2) } list [catch {p} msg] $msg $info ! } {0 willi {x 2 r}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { catch {unset x} set info {} ! trace variable x r q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] --- 52,111 ---- proc traceCrtElement {value name1 name2 op} { uplevel set ${name1}($name2) $value } ! proc traceCommand {oldName newName op} { ! global info ! set info [list $oldName $newName $op] ! } # Read-tracing on variables test trace-1.1 {trace variable reads} { catch {unset x} set info {} ! trace add variable x read traceScalar list [catch {set x} msg] $msg $info ! } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { catch {unset x} set x 123 set info {} ! trace add variable x read traceScalar list [catch {set x} msg] $msg $info ! } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} ! trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} ! trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info ! } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { catch {unset x} set x(2) zzz set info {} ! trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info ! } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { catch {unset x} set info {} ! trace add variable x read traceArray2 proc p {} { global x set x(2) willi return $x(2) } list [catch {p} msg] $msg $info ! } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { catch {unset x} set info {} ! trace add variable x read q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] *************** *** 115,139 **** return $x(Y) } list [catch {p} msg] $msg $info ! } {0 wolf {x Y r}} test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} ! trace var x r traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { catch {unset x} set x(2) zzz set info {} ! trace var x r traceArray list [catch {set x(2)} msg] $msg $info ! } {0 zzz {x 2 r 0 zzz}} test trace-1.10 {trace variable reads} { catch {unset x} set x 444 set info {} ! trace var x r traceScalar unset x set info } {} --- 118,142 ---- return $x(Y) } list [catch {p} msg] $msg $info ! } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} ! trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { catch {unset x} set x(2) zzz set info {} ! trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info ! } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { catch {unset x} set x 444 set info {} ! trace add variable x read traceScalar unset x set info } {} *************** *** 143,171 **** test trace-2.1 {trace variable writes} { catch {unset x} set info {} ! trace var x w traceScalar set x 123 set info ! } {x {} w 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} ! trace var x(33) w traceArray set x(33) 444 set info ! } {x 33 w 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} ! trace var x w traceArray set x(abc) qq set info ! } {x abc w 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} ! trace var x w traceScalar set x set info } {} --- 146,174 ---- test trace-2.1 {trace variable writes} { catch {unset x} set info {} ! trace add variable x write traceScalar set x 123 set info ! } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} ! trace add variable x(33) write traceArray set x(33) 444 set info ! } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} ! trace add variable x write traceArray set x(abc) qq set info ! } {x abc write 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} ! trace add variable x write traceScalar set x set info } {} *************** *** 173,179 **** catch {unset x} set x 1234 set info {} ! trace var x w traceScalar unset x set info } {} --- 176,182 ---- catch {unset x} set x 1234 set info {} ! trace add variable x write traceScalar unset x set info } {} *************** *** 186,227 **** test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace var x r traceScalarAppend append x 123 append x 456 lappend x 789 set info ! } {x {} r 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace var x rw traceScalarAppend append x 123 lappend x 456 set info ! } {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { catch {unset x} set info {} ! trace var x u traceScalar catch {unset x} set info ! } {x {} u 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} ! trace var x u traceScalar unset x set info ! } {x {} u 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} ! trace var x u traceScalar set x 44 set x set info --- 189,230 ---- test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace add variable x read traceScalarAppend append x 123 append x 456 lappend x 789 set info ! } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace add variable x {read write} traceScalarAppend append x 123 lappend x 456 set info ! } {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { catch {unset x} set info {} ! trace add variable x unset traceScalar catch {unset x} set info ! } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} ! trace add variable x unset traceScalar unset x set info ! } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} ! trace add variable x unset traceScalar set x 44 set x set info *************** *** 230,260 **** catch {unset x} set x(0) 18 set info {} ! trace var x(1) u traceArray catch {unset x(1)} set info ! } {x 1 u 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} ! trace var x(1) u traceArray unset x(1) set info ! } {x 1 u 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} ! trace var x(1) u traceArray unset x set info ! } {x 1 u 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} ! trace var x u traceProc catch {unset x(0)} set info } {} --- 233,263 ---- catch {unset x} set x(0) 18 set info {} ! trace add variable x(1) unset traceArray catch {unset x(1)} set info ! } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} ! trace add variable x(1) unset traceArray unset x(1) set info ! } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} ! trace add variable x(1) unset traceArray unset x set info ! } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} ! trace add variable x unset traceProc catch {unset x(0)} set info } {} *************** *** 264,301 **** set x(2) 144 set x(3) 14 set info {} ! trace var x u traceProc unset x(1) set info ! } {x 1 u} test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} ! trace var x u traceProc unset x set info ! } {x {} u} # Trace multiple trace types at once. test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} ! trace var x rwu traceProc catch {set x} set x 22 set x set x 33 unset x set info ! } {x {} r x {} w x {} r x {} w x {} u} test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} ! trace var x(0) rwu traceProc catch {set x(0)} set x(0) 22 set x(0) --- 267,304 ---- set x(2) 144 set x(3) 14 set info {} ! trace add variable x unset traceProc unset x(1) set info ! } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} ! trace add variable x unset traceProc unset x set info ! } {x {} unset} # Trace multiple trace types at once. test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} ! trace add variable x {read write unset} traceProc catch {set x} set x 22 set x set x 33 unset x set info ! } {x {} read x {} write x {} read x {} write x {} unset} test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} ! trace add variable x(0) {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) *************** *** 303,313 **** unset x(0) unset x set info ! } {x 0 r x 0 w x 0 r x 0 w x 0 u} test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} ! trace var x rwu traceProc catch {set x(0)} set x(0) 22 set x(0) --- 306,316 ---- unset x(0) unset x set info ! } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} ! trace add variable x {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) *************** *** 315,330 **** unset x(0) unset x set info ! } {x 0 w x 0 r x 0 w x 0 u x {} u} # Check order of invocation of traces test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} ! trace var x r "traceTag 1" ! trace var x r "traceTag 2" ! trace var x r "traceTag 3" catch {set x} set x 22 set x --- 318,333 ---- unset x(0) unset x set info ! } {x 0 write x 0 read x 0 write x 0 unset x {} unset} # Check order of invocation of traces test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} ! trace add variable x read "traceTag 1" ! trace add variable x read "traceTag 2" ! trace add variable x read "traceTag 3" catch {set x} set x 22 set x *************** *** 334,342 **** catch {unset x} set x(0) 44 set info {} ! trace var x(0) r "traceTag 1" ! trace var x(0) r "traceTag 2" ! trace var x(0) r "traceTag 3" set x(0) set info } {3 2 1} --- 337,345 ---- catch {unset x} set x(0) 44 set info {} ! trace add variable x(0) read "traceTag 1" ! trace add variable x(0) read "traceTag 2" ! trace add variable x(0) read "traceTag 3" set x(0) set info } {3 2 1} *************** *** 344,355 **** catch {unset x} set x(0) 44 set info {} ! trace var x(0) r "traceTag 1" ! trace var x r "traceTag A1" ! trace var x(0) r "traceTag 2" ! trace var x r "traceTag A2" ! trace var x(0) r "traceTag 3" ! trace var x r "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} --- 347,358 ---- catch {unset x} set x(0) 44 set info {} ! trace add variable x(0) read "traceTag 1" ! trace add variable x read "traceTag A1" ! trace add variable x(0) read "traceTag 2" ! trace add variable x read "traceTag A2" ! trace add variable x(0) read "traceTag 3" ! trace add variable x read "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} *************** *** 360,406 **** catch {unset x} set x 123 set info {} ! trace var x r "traceTag 1" ! trace var x r traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace var x w "traceTag 1" ! trace var x w traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace var x w traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace var x u "traceTag 1" ! trace var x u traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} ! trace var x(0) r "traceTag 1" ! trace var x r "traceTag 2" ! trace var x r traceError ! trace var x r "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-7.6 {error returns from traces} { catch {unset x} set x 123 ! trace var x u traceError list [catch {unset x} msg] $msg } {0 {}} test trace-7.7 {error returns from traces} { --- 363,409 ---- catch {unset x} set x 123 set info {} ! trace add variable x read "traceTag 1" ! trace add variable x read traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace add variable x write "traceTag 1" ! trace add variable x write traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} ! trace add variable x unset "traceTag 1" ! trace add variable x unset traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} ! trace add variable x(0) read "traceTag 1" ! trace add variable x read "traceTag 2" ! trace add variable x read traceError ! trace add variable x read "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-7.6 {error returns from traces} { catch {unset x} set x 123 ! trace add variable x unset traceError list [catch {unset x} msg] $msg } {0 {}} test trace-7.7 {error returns from traces} { *************** *** 409,418 **** # when the trace is deleted. catch {unset x} set x 123 ! trace var x r traceError catch {set x} catch {set x} ! trace vdelete x r traceError } {} # Check to see that variables are expunged before trace --- 412,421 ---- # when the trace is deleted. catch {unset x} set x 123 ! trace add variable x read traceError catch {set x} catch {set x} ! trace remove variable x read traceError } {} # Check to see that variables are expunged before trace *************** *** 423,429 **** catch {unset x} set x 33 set info {} ! trace var x u {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} --- 426,432 ---- catch {unset x} set x 33 set info {} ! trace add variable x unset {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} *************** *** 431,437 **** catch {unset x} set x 33 set info {} ! trace var x u {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} --- 434,440 ---- catch {unset x} set x 33 set info {} ! trace add variable x unset {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} *************** *** 439,445 **** catch {unset x} set x 33 set info {} ! trace var x u {traceCheck {uplevel trace vinfo x}} unset x set info } {0 {}} --- 442,448 ---- catch {unset x} set x 33 set info {} ! trace add variable x unset {traceCheck {uplevel trace list variable x}} unset x set info } {0 {}} *************** *** 447,462 **** catch {unset x} set x 33 set info {} ! trace var x u {traceCheck {global x; trace var x u traceProc}} unset x ! concat $info [trace vinfo x] ! } {0 {} {u traceProc}} test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} ! trace var x(0) u {traceCheck {uplevel set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} --- 450,465 ---- catch {unset x} set x 33 set info {} ! trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} unset x ! concat $info [trace list variable x] ! } {0 {} {unset traceProc}} test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} ! trace add variable x(0) unset {traceCheck {uplevel set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} *************** *** 464,470 **** catch {unset x} set x(0) 33 set info {} ! trace var x(0) u {traceCheck {uplevel set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} --- 467,473 ---- catch {unset x} set x(0) 33 set info {} ! trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} *************** *** 472,478 **** catch {unset x} set x(0) 33 set info {} ! trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} unset x(0) set info } {0 {}} --- 475,481 ---- catch {unset x} set x(0) 33 set info {} ! trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}} unset x(0) set info } {0 {}} *************** *** 480,495 **** catch {unset x} set x(0) 33 set info {} ! trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} catch {unset x(0)} ! concat $info [trace vinfo x(0)] ! } {0 {} {r {}}} test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} ! trace var x u {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} --- 483,498 ---- catch {unset x} set x(0) 33 set info {} ! trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} catch {unset x(0)} ! concat $info [trace list variable x(0)] ! } {0 {} {read {}}} test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} ! trace add variable x unset {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} *************** *** 497,503 **** catch {unset x} set x(y) 33 set info {} ! trace var x u {traceCheck {uplevel set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} --- 500,506 ---- catch {unset x} set x(y) 33 set info {} ! trace add variable x unset {traceCheck {uplevel set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} *************** *** 505,511 **** catch {unset x} set x(y) 33 set info {} ! trace var x u {traceCheck {uplevel array exists x}} unset x set info } {0 0} --- 508,514 ---- catch {unset x} set x(y) 33 set info {} ! trace add variable x unset {traceCheck {uplevel array exists x}} unset x set info } {0 0} *************** *** 513,520 **** catch {unset x} set x(y) 33 set info {} ! set cmd {traceCheck {uplevel {trace vinfo x}}} ! trace var x u $cmd unset x set info } {0 {}} --- 516,523 ---- catch {unset x} set x(y) 33 set info {} ! set cmd {traceCheck {uplevel {trace list variable x}}} ! trace add variable x unset $cmd unset x set info } {0 {}} *************** *** 522,536 **** catch {unset x} set x(y) 33 set info {} ! trace var x u {traceCheck {global x; trace var x r {}}} unset x ! concat $info [trace vinfo x] ! } {0 {} {r {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} ! trace var x u {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} --- 525,539 ---- catch {unset x} set x(y) 33 set info {} ! trace add variable x unset {traceCheck {global x; trace add variable x read {}}} unset x ! concat $info [trace list variable x] ! } {0 {} {read {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} ! trace add variable x unset {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} *************** *** 540,591 **** test trace-11.1 {creating array when setting variable traces} { catch {unset x} set info {} ! trace var x(0) w traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-11.2 {creating array when setting variable traces} { catch {unset x} set info {} ! trace var x(0) w traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-11.3 {creating array when setting variable traces} { catch {unset x} set info {} ! trace var x(0) w traceProc set x(0) 22 set info ! } {x 0 w} test trace-11.4 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace var x w traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-11.5 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace var x w traceProc set x 22 set info ! } {x {} w} test trace-11.6 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace var x w traceProc set x(0) 22 set info ! } {x 0 w} test trace-11.7 {create array element during read trace} { catch {unset x} set x(2) zzz ! trace var x r {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 ! list [catch {trace var x(0) w traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check deleting one trace from another. --- 543,594 ---- test trace-11.1 {creating array when setting variable traces} { catch {unset x} set info {} ! trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-11.2 {creating array when setting variable traces} { catch {unset x} set info {} ! trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-11.3 {creating array when setting variable traces} { catch {unset x} set info {} ! trace add variable x(0) write traceProc set x(0) 22 set info ! } {x 0 write} test trace-11.4 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-11.5 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace add variable x write traceProc set x 22 set info ! } {x {} write} test trace-11.6 {creating variable when setting variable traces} { catch {unset x} set info {} ! trace add variable x write traceProc set x(0) 22 set info ! } {x 0 write} test trace-11.7 {create array element during read trace} { catch {unset x} set x(2) zzz ! trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 ! list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check deleting one trace from another. *************** *** 593,611 **** test trace-12.1 {delete one trace from another} { proc delTraces {args} { global x ! trace vdel x r {traceTag 2} ! trace vdel x r {traceTag 3} ! trace vdel x r {traceTag 4} } catch {unset x} set x 44 set info {} ! trace var x r {traceTag 1} ! trace var x r {traceTag 2} ! trace var x r {traceTag 3} ! trace var x r {traceTag 4} ! trace var x r delTraces ! trace var x r {traceTag 5} set x set info } {5 1} --- 596,614 ---- test trace-12.1 {delete one trace from another} { proc delTraces {args} { global x ! trace remove variable x read {traceTag 2} ! trace remove variable x read {traceTag 3} ! trace remove variable x read {traceTag 4} } catch {unset x} set x 44 set info {} ! trace add variable x read {traceTag 1} ! trace add variable x read {traceTag 2} ! trace add variable x read {traceTag 3} ! trace add variable x read {traceTag 4} ! trace add variable x read delTraces ! trace add variable x read {traceTag 5} set x set info } {5 1} *************** *** 617,718 **** } {1 {wrong # args: should be "trace option [arg arg ...]"}} test trace-13.2 {trace command (overall)} { list [catch {trace gorp} msg] $msg ! } {1 {bad option "gorp": must be variable, vdelete, or vinfo}} ! test trace-13.3 {trace command ("variable" option)} { list [catch {trace variable x y} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} ! test trace-13.4 {trace command ("variable" option)} { ! list [catch {trace var x y z z2} msg] $msg ! } {1 {wrong # args: should be "trace variable name ops command"}} ! test trace-13.5 {trace command ("variable" option)} { ! list [catch {trace var x y z} msg] $msg ! } {1 {bad operations "y": should be one or more of rwu}} ! test trace-13.6 {trace command ("vdelete" option)} { ! list [catch {trace vdelete x y} msg] $msg ! } {1 {wrong # args: should be "trace vdelete name ops command"}} ! test trace-13.7 {trace command ("vdelete" option)} { ! list [catch {trace vdelete x y z foo} msg] $msg ! } {1 {wrong # args: should be "trace vdelete name ops command"}} ! test trace-13.8 {trace command ("vdelete" option)} { ! list [catch {trace vdelete x y z} msg] $msg ! } {1 {bad operations "y": should be one or more of rwu}} ! test trace-13.9 {trace command ("vdelete" option)} { catch {unset x} set info {} ! trace var x w traceProc ! trace vdelete x w traceProc } {} ! test trace-13.10 {trace command ("vdelete" option)} { catch {unset x} set info {} ! trace var x w traceProc ! trace vdelete x w traceProc set x 12345 set info } {} ! test trace-13.11 {trace command ("vdelete" option)} { catch {unset x} set info {} ! trace var x w {traceTag 1} ! trace var x w traceProc ! trace var x w {traceTag 2} set x yy ! trace vdelete x w traceProc set x 12345 ! trace vdelete x w {traceTag 1} set x foo ! trace vdelete x w {traceTag 2} set x gorp set info ! } {2 x {} w 1 2 1 2} ! test trace-13.12 {trace command ("vdelete" option)} { catch {unset x} set info {} ! trace var x w {traceTag 1} ! trace vdelete x w non_existent set x 12345 set info } {1} ! test trace-13.13 {trace command ("vinfo" option)} { ! list [catch {trace vinfo} msg] $msg] ! } {1 {wrong # args: should be "trace vinfo name"]}} ! test trace-13.14 {trace command ("vinfo" option)} { ! list [catch {trace vinfo x y} msg] $msg] ! } {1 {wrong # args: should be "trace vinfo name"]}} ! test trace-13.15 {trace command ("vinfo" option)} { ! catch {unset x} ! trace var x w {traceTag 1} ! trace var x w traceProc ! trace var x w {traceTag 2} ! trace vinfo x ! } {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}} ! test trace-13.16 {trace command ("vinfo" option)} { catch {unset x} ! trace vinfo x } {} ! test trace-13.17 {trace command ("vinfo" option)} { catch {unset x} ! trace vinfo x(0) } {} ! test trace-13.18 {trace command ("vinfo" option)} { catch {unset x} set x 44 ! trace vinfo x(0) } {} ! test trace-13.19 {trace command ("vinfo" option)} { catch {unset x} set x 44 ! trace var x w {traceTag 1} ! proc check {} {global x; trace vinfo x} check ! } {{w {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-14.1 {long trace command} { catch {unset x} set info {} ! trace var x w {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ --- 620,742 ---- } {1 {wrong # args: should be "trace option [arg arg ...]"}} test trace-13.2 {trace command (overall)} { list [catch {trace gorp} msg] $msg ! } {1 {bad option "gorp": must be add, list, remove, variable, vdelete, or vinfo}} ! test trace-13.3.1 {trace add command ("command" option)} { ! list [catch {trace add command x y z w a} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'rename', 'delete'}} ! test trace-13.3.2 {trace remove command ("remove command" option)} { ! list [catch {trace remove command x y z z2} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'rename', 'delete'}} ! test trace-13.3.3 {trace command ("trace list command" option)} { ! list [catch {trace list command} msg] $msg] ! } {1 {wrong # args: should be "trace list command name"]}} ! test trace-13.3.4 {trace command ("trace list command" option)} { ! list [catch {trace list command x y} msg] $msg] ! } {1 {wrong # args: should be "trace list command name"]}} ! test trace-13.3.5 {trace command ("trace add execution" option)} { ! list [catch {trace add execution} msg] $msg] ! } {1 {wrong # args: should be "trace add execution name ops ?options...?"]}} ! test trace-13.3.6 {trace command ("trace remove execution" option)} { ! list [catch {trace remove execution} msg] $msg] ! } {1 {wrong # args: should be "trace remove execution name ops ?options...?"]}} ! test trace-13.3.7 {trace command ("trace list execution" option)} { ! list [catch {trace list execution x y} msg] $msg] ! } {1 {wrong # args: should be "trace list execution name"]}} ! test trace-13.3 {trace command ("add variable" option)} { list [catch {trace variable x y} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} ! test trace-13.4 {trace command ("add variable" option)} { ! list [catch {trace add variable x y z z2} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'read', 'write' or 'unset'}} ! test trace-13.5 {trace command ("add variable" option)} { ! list [catch {trace add variable x y z} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'read', 'write' or 'unset'}} ! test trace-13.6 {trace command ("remove variable" option)} { ! list [catch {trace remove variable x y z w} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'read', 'write' or 'unset'}} ! test trace-13.7 {trace command ("remove variable" option)} { ! list [catch {trace remove variable x y z foo} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'read', 'write' or 'unset'}} ! test trace-13.8 {trace command ("remove variable" option)} { ! list [catch {trace remove variable x y z} msg] $msg ! } {1 {bad operations "y": should be a list of one or more of 'read', 'write' or 'unset'}} ! test trace-13.9 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x write traceProc ! trace remove variable x write traceProc } {} ! test trace-13.10 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x write traceProc ! trace remove variable x write traceProc set x 12345 set info } {} ! test trace-13.11 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x write {traceTag 1} ! trace add variable x write traceProc ! trace add variable x write {traceTag 2} set x yy ! trace remove variable x write traceProc set x 12345 ! trace remove variable x write {traceTag 1} set x foo ! trace remove variable x write {traceTag 2} set x gorp set info ! } {2 x {} write 1 2 1 2} ! test trace-13.12 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x write {traceTag 1} ! trace remove variable x write non_existent set x 12345 set info } {1} ! test trace-13.13 {trace command ("list variable" option)} { ! list [catch {trace list variable} msg] $msg] ! } {1 {wrong # args: should be "trace list variable name"]}} ! test trace-13.14 {trace command ("list variable" option)} { ! list [catch {trace list variable x y} msg] $msg] ! } {1 {wrong # args: should be "trace list variable name"]}} ! test trace-13.15 {trace command ("list variable" option)} { ! catch {unset x} ! trace add variable x write {traceTag 1} ! trace add variable x write traceProc ! trace add variable x write {traceTag 2} ! trace list variable x ! } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} ! test trace-13.16 {trace command ("list variable" option)} { catch {unset x} ! trace list variable x } {} ! test trace-13.17 {trace command ("list variable" option)} { catch {unset x} ! trace list variable x(0) } {} ! test trace-13.18 {trace command ("list variable" option)} { catch {unset x} set x 44 ! trace list variable x(0) } {} ! test trace-13.19 {trace command ("list variable" option)} { catch {unset x} set x 44 ! trace add variable x write {traceTag 1} ! proc check {} {global x; trace list variable x} check ! } {{write {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-14.1 {long trace command} { catch {unset x} set info {} ! trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ *************** *** 729,735 **** generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} catch {unset x} ! trace var x w longResult set x 44 set x 5 set x abcde --- 753,759 ---- generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} catch {unset x} ! trace add variable x write longResult set x 44 set x 5 set x abcde *************** *** 738,747 **** catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} ! trace var "x y z(a\n\{)" w traceProc set "x y z(a\n\{)" 33 set info ! } "{x y z} a\\n\\{ w" # Check for proper handling of unsets during traces. --- 762,771 ---- catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} ! trace add variable "x y z(a\n\{)" write traceProc set "x y z(a\n\{)" 33 set info ! } "{x y z} a\\n\\{ write" # Check for proper handling of unsets during traces. *************** *** 769,930 **** catch {unset y} set y 1234 set info {} ! trace var y r {traceUnset y} ! trace var y u {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-15.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} ! trace var y r {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} ! trace var y w {traceUnset y} ! trace var y u {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) w {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) w {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} ! trace var y w {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) w {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) w {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) w {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} ! trace var y u {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-15.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) u {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-15.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) u {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} ! trace var y u {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-15.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) u {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-15.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) u {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} ! trace var y r {traceAppend first} ! trace var y r {traceUnset y} ! trace var y r {traceAppend third} ! trace var y u {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} ! trace var y(0) r {traceAppend first} ! trace var y(0) r {traceUnset y} ! trace var y(0) r {traceAppend third} ! trace var y(0) u {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} --- 793,954 ---- catch {unset y} set y 1234 set info {} ! trace add variable y read {traceUnset y} ! trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-15.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} ! trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} ! trace add variable y write {traceUnset y} ! trace add variable y unset {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} ! trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} ! trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-15.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-15.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} ! trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-15.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-15.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} ! trace add variable y read {traceAppend first} ! trace add variable y read {traceUnset y} ! trace add variable y read {traceAppend third} ! trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} ! trace add variable y(0) read {traceAppend first} ! trace add variable y(0) read {traceUnset y} ! trace add variable y(0) read {traceAppend third} ! trace add variable y(0) unset {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} *************** *** 933,962 **** test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} ! trace var x u {traceProc} list [catch {unset x} msg] $msg $info ! } {1 {can't unset "x": no such variable} {x {} u}} test trace-16.2 {traced variables must survive procedure exits} { catch {unset x} ! proc p1 {} {global x; trace var x w traceProc} p1 ! trace vinfo x ! } {{w traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} ! proc p1 {} {global x; trace var x w traceProc} p1 set x 44 set info ! } {x {} w} # Be sure that procedure frames are released before unset traces # are invoked. test trace-17.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} ! proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info --- 957,986 ---- test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} ! trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info ! } {1 {can't unset "x": no such variable} {x {} unset}} test trace-16.2 {traced variables must survive procedure exits} { catch {unset x} ! proc p1 {} {global x; trace add variable x write traceProc} p1 ! trace list variable x ! } {{write traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} ! proc p1 {} {global x; trace add variable x write traceProc} p1 set x 44 set info ! } {x {} write} # Be sure that procedure frames are released before unset traces # are invoked. test trace-17.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} ! proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info *************** *** 967,972 **** --- 991,1446 ---- catch {unset x} catch {unset y} + + test trace-17.2 {trace add command (command existence)} { + # Just in case! + catch {rename nosuchname ""} + list [catch {trace add command nosuchname rename traceCommand} msg] $msg + } {1 {unknown command "nosuchname"}} + test trace-17.3 {trace add command (command existence in ns)} { + list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg + } {1 {unknown command "nosuchns::nosuchname"}} + + proc foo {} {} + catch {rename bar {}} + + test trace-18.1 {trace add command (rename option)} { + trace add command foo rename traceCommand + rename foo bar + set info + } {foo bar rename} + test trace-18.2 {trace add command rename back again} { + rename bar foo + set info + } {bar foo rename} + test trace-18.2.1 {trace add command rename trace exists} { + trace list command foo + } {{rename traceCommand}} + test trace-18.3 {trace add command rename doesn't trace delete} { + set info {} + rename foo {} + set info + } {} + test trace-18.4 {trace add command rename doesn't trace recreated commands} { + catch {rename foo {}} + proc foo {} {} + rename foo bar + set info + } {} + test trace-18.5 {trace add command deleted removes traces} { + proc foo {} {} + trace list command foo + } {} + catch {rename bar {}} + namespace eval tc {} + proc tc::tcfoo {} {} + test trace-18.5 {trace add command rename in namespace} { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tc::tcbar + set info + } {tc::tcfoo tc::tcbar rename} + test trace-18.6 {trace add command rename in namespace back again} { + rename tc::tcbar tc::tcfoo + set info + } {tc::tcbar tc::tcfoo rename} + test trace-18.7 {trace add command rename in namespace to out of namespace} { + rename tc::tcfoo tcbar + set info + } {tc::tcfoo tcbar rename} + test trace-18.8 {trace add command rename back into namespace} { + rename tcbar tc::tcfoo + set info + } {tcbar tc::tcfoo rename} + test trace-18.8 {trace add command failed rename doesn't trigger trace} { + set info {} + proc foo {} {} + proc bar {} {} + trace add command foo {rename delete} traceCommand + catch {rename foo bar} + set info + } {} + catch {rename foo {}} + catch {rename bar {}} + + # Make sure it exists again + proc foo {} {} + + test trace-19.1 {trace add command (delete option)} { + trace add command foo delete traceCommand + rename foo "" + set info + } {foo {} delete} + test trace-19.2 {trace add command delete doesn't trace recreated commands} { + set info {} + proc foo {} {} + rename foo "" + set info + } {} + test trace-19.2.1 {trace add command delete trace info} { + proc foo {} {} + trace add command foo delete traceCommand + trace list command foo + } {{delete traceCommand}} + test trace-19.3 {trace add command implicit delete} { + proc foo {} {} + trace add command foo delete traceCommand + proc foo {} {} + set info + } {foo {} delete} + test trace-19.3.1 {trace add command delete trace info} { + proc foo {} {} + trace list command foo + } {} + test trace-19.4 {trace add command rename followed by delete} { + set infotemp {} + proc foo {} {} + trace add command foo {rename delete} traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info + } {{foo bar rename} {bar {} delete}} + catch {rename foo {}} + catch {rename bar {}} + + test trace-19.5 {trace add command rename and delete} { + set infotemp {} + set info {} + proc foo {} {} + trace add command foo {rename delete} traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info + } {{foo bar rename} {bar {} delete}} + + test trace-19.6 {trace add command rename and delete in subinterp} { + set tc [interp create] + foreach p {traceCommand} { + $tc eval [list proc $p [info args $p] [info body $p]] + } + $tc eval [list set infotemp {}] + $tc eval [list set info {}] + $tc eval [list proc foo {} {}] + $tc eval [list trace add command foo {rename delete} traceCommand] + $tc eval [list rename foo bar] + $tc eval {lappend infotemp $info} + $tc eval [list rename bar {}] + $tc eval {lappend infotemp $info} + $tc eval {set info $infotemp} + $tc eval [list unset infotemp] + set info [$tc eval [list set info]] + interp delete $tc + set info + } {{foo bar rename} {bar {} delete}} + + # I'd like it if this test could give 'foo {} d' as a result, + # but interp deletion means there is no interp to evaluate + # the trace in. + test trace-19.7 {trace add command delete in subinterp while being deleted} { + set info {} + set tc [interp create] + interp alias $tc traceCommand {} traceCommand + $tc eval [list proc foo {} {}] + $tc eval [list trace add command foo {rename delete} traceCommand] + interp delete $tc + set info + } {} + + proc traceDelete {cmd old new op} { + eval trace remove command $cmd [lindex [trace list command $cmd] 0] + global info + set info [list $old $new $op] + } + proc traceCmdrename {cmd old new op} { + rename $old someothername + } + proc traceCmddelete {cmd old new op} { + rename $old "" + } + test trace-19.8 {trace delete while trace is active} { + set info {} + proc foo {} {} + catch {rename bar {}} + trace add command foo {rename delete} [list traceDelete foo] + rename foo bar + list [set info] [trace list command bar] + } {{foo bar rename} {}} + + test trace-19.9 {rename trace deletes command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo rename [list traceCmddelete foo] + rename foo bar + list [info commands foo] [info commands bar] [info commands someothername] + } {{} {} {}} + + test trace-19.10 {rename trace renames command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo rename [list traceCmdrename foo] + rename foo bar + set info [list [info commands foo] [info commands bar] [info commands someothername]] + rename someothername {} + set info + } {{} {} someothername} + + test trace-19.11 {delete trace deletes command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo delete [list traceCmddelete foo] + rename foo {} + list [info commands foo] [info commands bar] [info commands someothername] + } {{} {} {}} + + test trace-19.12 {delete trace renames command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo delete [list traceCmdrename foo] + rename foo bar + rename bar {} + # None of these should exist. + list [info commands foo] [info commands bar] [info commands someothername] + } {{} {} {}} + + proc foo {b} { set a $b } + + test trace-20.1 {trace execution} { + trace add execution foo {before after} + foo hello + set info [trace list execution foo] + trace remove execution foo {before after} + set info + } {'foo hello' + 'set a $b ' + set a hello + OK: hello + foo hello + OK: hello + } + + test trace-20.2 {trace execution} { + trace add execution foo after + foo hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {set a hello + OK: hello + foo hello + OK: hello + } + + test trace-20.3 {trace execution} { + trace add execution foo after -minlevel 10 + uplevel \#0 foo hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {} + + proc bar {b} { foo $b } + proc foobar {b} { bar $b } + + test trace-20.4 {trace execution} { + trace add execution foo after -minlevel [info level] -maxlevel 10 + foobar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {set a hello + OK: hello + foo hello + OK: hello + } + + #proc foobar {b} { puts stdout [info level] ; bar $b } + + test trace-20.4.1 {trace execution -minlevel} { + set level [info level] + incr level 2 + trace add execution foo after -minlevel $level -maxlevel 100 + foobar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {set a hello + OK: hello + foo hello + OK: hello + } + + #proc foo {b} { set a $b ; set a [info level]} + + test trace-20.4.2 {trace execution -minlevel} { + set level [info level] + incr level 7 + trace add execution foo after -minlevel $level -maxlevel 100 + foobar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {} + + test trace-20.4.3 {trace execution -minlevel} { + set level [info level] + incr level 1 + trace add execution foo after -minlevel $level -maxlevel 100 + bar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {set a hello + OK: hello + foo hello + OK: hello + } + + proc foo {b} { set a $b ; set a [info level]} + + test trace-20.4.4 {trace execution -minlevel} { + set level [info level] + incr level 2 + trace add execution foo after -minlevel $level -maxlevel 100 + bar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {} + + proc foo {b} { set a $b } + + #proc foobar {b} { bar $b } + + test trace-20.4.2 {trace execution -maxlevel} { + trace add execution foo after -maxlevel 1 + foobar hello + set info [trace list execution foo] + trace remove execution foo after + set info + } {} + + test trace-20.5 {trace execution -maxlevel} { + trace add execution foobar after -maxlevel 100 + foobar hello + set info [trace list execution foobar] + trace remove execution foobar after + set info + } { set a hello + OK: hello + foo hello + OK: hello + bar hello + OK: hello + foobar hello + OK: hello + } + + test trace-20.6 {trace execution -depth} { + trace add execution foobar after -depth 1 + foobar hello + set info [trace list execution foobar] + trace remove execution foobar after + set info + } {bar hello + OK: hello + foobar hello + OK: hello + } + + test trace-20.7 {trace execution} { + trace add execution foobar {after before} + foobar hello + set info [trace list execution foobar] + trace remove execution foobar {after before} + set info + } {'foobar hello' + 'bar $b ' + 'foo $b ' + 'set a $b ' + set a hello + OK: hello + foo hello + OK: hello + bar hello + OK: hello + foobar hello + OK: hello + } + + test trace-20.8 {trace execution} { + trace add execution foobar {after before} -depth 1 + foobar hello + set info [trace list execution foobar] + trace remove execution foobar {after before} + set info + } {'foobar hello' + 'bar $b ' + bar hello + OK: hello + foobar hello + OK: hello + } + + # Delete arrays when done, so they can be re-used as scalars + # elsewhere. + + catch {unset x} + catch {unset y} + + test trace-21.1 {trace count} { + set x 5 + trace add variable x read -count + set info {} + for {set y 0} {$y < 5} {incr y} { + set x + lappend info [trace list variable x] + } + trace remove variable x read -count + set info + } {{{read -count {} 1}} {{read -count {} 2}} {{read -count {} 3}} {{read -count {} 4}} {{read -count {} 5}}} + + test trace-21.2 {trace count} { + catch {rename foo {}} + catch {rename bar {}} + proc foo {} {} + trace add command foo rename -count + set info {} + for {set y 0} {$y < 5} {incr y} { + rename foo bar + rename bar foo + lappend info [trace list command foo] + } + trace remove command foo rename -count + set info + } {{{rename -count {} 2}} {{rename -count {} 4}} {{rename -count {} 6}} {{rename -count {} 8}} {{rename -count {} 10}}} + + # 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 {}} + + # Delete arrays when done, so they can be re-used as scalars + # elsewhere. + + catch {unset x} + catch {unset y} + # cleanup ::tcltest::cleanupTests