? 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/20 22:49:15 *************** *** 20,29 **** .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 --- 20,73 ---- .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are ! invoked. At present, only variable and command tracing is 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' 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 \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 consists of ! one or more of the following letters: ! .TP ! \fBr\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 '\fBr\fR'. ! .TP ! \fBw\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 \fBr\fR, \fBd\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 \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array *************** *** 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 --- 175,181 ---- 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,160 **** 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 elements, which are the \fIops\fR and \fIcommand\fR associated 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 --- 184,248 ---- This command returns an empty string. .RE .TP ! \fBtrace remove \fItype name ops command\fR ! Where \fItype\fR is either 'command' 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' 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 elements, which are the \fIops\fR and \fIcommand\fR associated 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 + .TP + \fBtrace execution \fI..\fR + + .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. .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/20 22:49:15 *************** *** 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.71 diff -c -3 -r1.71 tcl.h *** tcl.h 2000/05/03 00:15:06 1.71 --- tcl.h 2000/06/20 22:49:16 *************** *** 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,942 ---- #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 + + /* + * Flag values passed to command-related procedures. + */ + + #define TCL_TRACE_RENAME 0x1000 + #define TCL_TRACE_DELETE 0x2000 + + /* + * 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/20 22:49:16 *************** *** 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 = minLevel; + 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/20 22:49:17 *************** *** 55,67 **** --- 55,120 ---- } 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 { + 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_ObjCmdProc TraceExecutionProc; + + static Tcl_CmdTraceObjProc TraceStandardExecutionProc; + 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. - * *---------------------------------------------------------------------- */ --- 2522,2539 ---- * * 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) { --- 2546,2567 ---- 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; --- 2574,3118 ---- 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; ! } ! ! 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_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; ! } ! ! /* ! * 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. */ ! { ! 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, min, max, truncate, relativeDepth, c; ! if (objc < 4) { ! Tcl_WrongNumArgs(interp, 3, objv, "name ?options...?"); ! 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; ! } ! if ((enum traceOptions) optionIndex == TRACE_ADD) { ! flags = min = max = truncate = relativeDepth = 0; ! c = 4; ! while(c < objc) { ! int len; ! char* str = Tcl_GetStringFromObj(objv[c],&len); ! if(str[0] == '-' && c != objc-1) { ! if (len == 9 && !strncmp(str,"-minlevel",9)) { ! if (Tcl_GetIntFromObj(interp,objv[c+1],&min) == TCL_ERROR) { ! return TCL_ERROR; ! } ! c++; ! } else if (len == 9 && !strncmp(str,"-maxlevel",9)) { ! if (Tcl_GetIntFromObj(interp,objv[c+1],&max) == TCL_ERROR) { ! return TCL_ERROR; ! } ! c++; ! } else if (len == 9 && !strncmp(str,"-truncate",9)) { ! if (Tcl_GetIntFromObj(interp,objv[c+1],&truncate) == TCL_ERROR) { ! return TCL_ERROR; ! } ! c++; ! } else if (len == 6 && !strncmp(str,"-depth",6)) { ! if (Tcl_GetIntFromObj(interp,objv[c+1],&relativeDepth) == TCL_ERROR) { ! return TCL_ERROR; ! } ! c++; ! } else { ! goto bad_args; ! } ! } else if (len == 6 && !strncmp(str,"before",6)) { ! flags |= TCL_CMD_TRACE_BEFORE; ! } else if (len == 5 && !strncmp(str,"after",5)) { ! flags |= TCL_CMD_TRACE_AFTER; } else { ! bad_args: ! Tcl_AppendResult(interp, "Bad argument \"", Tcl_GetString(objv[c]), ! "\": should be before, after -minlevel n, -maxlevel n, -depth n or -truncate n", ! (char *) NULL); ! return TCL_ERROR; } + c++; } ! loopPtr = (TraceExecutionInfo*) ckalloc(sizeof(TraceExecutionInfo)); ! loopPtr->cmdPtr = cmdPtr; ! Tcl_DStringInit(&loopPtr->traceDetails); ! loopPtr->tracePtr = Tcl_CreateTraceObj(interp,objv[3],flags, ! max,min, ! TraceStandardExecutionProc, ! (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) { ! 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; + } ! 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, *p, *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; ! if (objc != 6) { ! Tcl_WrongNumArgs(interp, 3, objv, "name ops command"); ! return TCL_ERROR; ! } ! flagOps = Tcl_GetString(objv[4]); ! for (p = flagOps; *p != 0; p++) { ! if (*p == 'r') { ! flags |= TCL_TRACE_RENAME; ! } else if (*p == 'd') { ! flags |= TCL_TRACE_DELETE; ! } else { ! goto badCmdOps; ! } ! } ! if (flags == 0) { ! goto badCmdOps; ! } ! if ((enum traceOptions) optionIndex == TRACE_ADD) { ! TraceCommandInfo *tvarPtr; ! command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; ! tvarPtr = (TraceCommandInfo *) ckalloc((unsigned) ! (sizeof(TraceCommandInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; tvarPtr->errMsg = NULL; tvarPtr->length = length; ! flags |= TCL_TRACE_DELETE; strcpy(tvarPtr->command, command); ! name = Tcl_GetString(objv[3]); ! if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); 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 *tvarPtr; 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) { ! tvarPtr = (TraceCommandInfo *) clientData; ! if ((tvarPtr->length == length) && (tvarPtr->flags == flags) ! && (strncmp(command, tvarPtr->command, ! (size_t) length) == 0)) { ! Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, ! TraceCommandProc, clientData); ! if (tvarPtr->errMsg != NULL) { ! ckfree(tvarPtr->errMsg); ! } ! ckfree((char *) tvarPtr); ! break; ! } } + } + break; + } + case TRACE_LIST: { + ClientData clientData; + char ops[4]; + Tcl_Obj *resultListPtr, *pairObjPtr, *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 *tvarPtr = (TraceCommandInfo *) clientData; ! ! pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); ! p = ops; ! if (tvarPtr->flags & TCL_TRACE_RENAME) { ! *p = 'r'; ! p++; } ! if (tvarPtr->flags & TCL_TRACE_DELETE) { ! *p = 'd'; ! 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; + } + } + return TCL_OK; + + badCmdOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be one or more of rd", (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, *p; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name ops command"); + return TCL_ERROR; + } + flagOps = Tcl_GetString(objv[4]); + 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; + } + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceVarInfo *tvarPtr; + command = Tcl_GetStringFromObj(objv[5], &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[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; ! command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; clientData = 0; ! name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; *************** *** 2602,2668 **** 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; } /* --- 3128,3595 ---- break; } } } ! break; ! } ! case TRACE_LIST: { ! ClientData clientData; ! char ops[4]; ! Tcl_Obj *resultListPtr, *pairObjPtr, *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; ! 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; ! } } return TCL_OK; ! badVarOps: ! Tcl_AppendResult(interp, "bad operations \"", flagOps, "\": should be one or more of rwu", (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; + } + } + + /* + *---------------------------------------------------------------------- + * + * TraceStandardExecutionProc -- + * + * 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 TraceStandardExecutionProc(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 TraceStandardExecutionProc + * + * 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 variable accesses that have + * been traced using the "trace" command. + * + * Results: + * Normally returns NULL. If the trace command returns an error, + * then this procedure returns an error string. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ + static void + TraceCommandProc(clientData, interp, oldName, newName, flags) + ClientData clientData; /* Information about the variable trace. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *oldName; /* Name of variable or array. */ + char *newName; /* Name of element within array; NULL means + * scalar variable is being referenced. */ + int flags; /* OR-ed bits giving operation and other + * information. */ + { + Tcl_SavedResult state; + TraceCommandInfo *tvarPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + 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 (newName == NULL) { + newName = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, newName); + if (flags & TCL_TRACE_RENAME) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_DELETE) { + Tcl_DStringAppend(&cmd, " d", 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) { + /* we ignore errors in these commands */ + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + if (flags & TCL_TRACE_DESTROYED) { + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + } + return; } /* 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/20 22:49:17 *************** *** 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.13 diff -c -3 -r1.13 tclExecute.c *** tclExecute.c 2000/05/26 08:53:42 1.13 --- tclExecute.c 2000/06/20 22:49:18 *************** *** 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. */ *************** *** 3295,3300 **** --- 3295,3400 ---- /* *---------------------------------------------------------------------- * + * 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; + + if (command == NULL) { + return; + } + + for (tracePtr = iPtr->tracePtr;tracePtr != NULL;tracePtr = tracePtr->nextPtr) { + if (tracePtr->level != 0 && iPtr->numLevels > tracePtr->level) { + continue; + } + if (tracePtr->traceFlags != 0) { + /* The trace was created with Tcl_CreateTraceObj */ + if (iPtr->numLevels < tracePtr->minLevel) { + continue; + } + + if (traceFlags & TCL_CMD_TRACE_BEFORE) { + if (tracePtr->cmdPtr != NULL) { + if (tracePtr->tracingCmdDepth == 0) { + if (cmdPtr == (Command*)tracePtr->cmdPtr) { + tracePtr->tracingInitialDepth = iPtr->numLevels; + } 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, + iPtr->numLevels, 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, + iPtr->numLevels, 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 *************** *** 3321,3327 **** 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; --- 3421,3427 ---- 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; *************** *** 3353,3359 **** * 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); --- 3453,3459 ---- * 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/20 22:49:18 *************** *** 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/20 22:49:18 *************** *** 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,332 ---- } ActiveVarTrace; /* + * TODO + */ + + 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; /* --- 649,674 ---- */ 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 --- 1072,1079 ---- /* 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 **** --- 1081,1111 ---- * 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 **** --- 1320,1332 ---- * 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/20 22:49:18 *************** *** 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/20 22:49:19 *************** *** 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,924 **** * Call trace procedures if needed. */ ! argv = NULL; ! commandCopy = command; ! ! for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { ! nextPtr = tracePtr->nextPtr; ! if (iPtr->numLevels > tracePtr->level) { ! continue; ! } ! ! /* ! * This is a bit messy because we have to emulate the old trace ! * interface, which uses strings for everything. ! */ ! ! if (argv == NULL) { ! argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); ! for (i = 0; i < objc; i++) { ! argv[i] = Tcl_GetString(objv[i]); ! } ! argv[objc] = 0; ! ! if (length < 0) { ! length = strlen(command); ! } else if ((size_t)length < strlen(command)) { ! commandCopy = (char *) ckalloc((unsigned) (length + 1)); ! strncpy(commandCopy, command, (size_t) length); ! commandCopy[length] = 0; ! } ! } ! (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, ! commandCopy, cmdPtr->proc, cmdPtr->clientData, ! objc, argv); } - if (argv != NULL) { - ckfree((char *) argv); - } - if (commandCopy != command) { - ckfree((char *) commandCopy); - } /* * Finally, invoke the command's Tcl_ObjCmdProc. --- 878,887 ---- * Call trace procedures if needed. */ ! if (iPtr->tracePtr != NULL) { ! TclCheckTraces(interp, command, length, cmdPtr, TCL_OK, ! TCL_CMD_TRACE_BEFORE, objc, objv); } /* * Finally, invoke the command's Tcl_ObjCmdProc. *************** *** 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 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/20 22:49:19 *************** *** 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: 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/20 22:49:21 *************** *** 52,91 **** 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} { --- 52,94 ---- 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 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 add variable 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 add variable x r traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} ! trace add variable 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 add variable 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} { *************** *** 119,139 **** 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 } {} --- 122,142 ---- test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} ! trace add variable 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 add variable 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 add variable x r traceScalar unset x set info } {} *************** *** 143,163 **** 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} --- 146,166 ---- test trace-2.1 {trace variable writes} { catch {unset x} set info {} ! trace add variable 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 add variable 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 add variable x w traceArray set x(abc) qq set info } {x abc w 0 qq} *************** *** 165,171 **** catch {unset x} set x 1234 set info {} ! trace var x w traceScalar set x set info } {} --- 168,174 ---- catch {unset x} set x 1234 set info {} ! trace add variable x w 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 w traceScalar unset x set info } {} *************** *** 186,192 **** 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 --- 189,195 ---- test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace add variable x r traceScalarAppend append x 123 append x 456 lappend x 789 *************** *** 195,201 **** 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 --- 198,204 ---- test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} ! trace add variable x rw traceScalarAppend append x 123 lappend x 456 set info *************** *** 206,212 **** 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}} --- 209,215 ---- test trace-4.1 {trace variable unsets} { catch {unset x} set info {} ! trace add variable x u traceScalar catch {unset x} set info } {x {} u 1 {can't read "x": no such variable}} *************** *** 214,227 **** 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 --- 217,230 ---- catch {unset x} set x 1234 set info {} ! trace add variable 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 add variable x u traceScalar set x 44 set x set info *************** *** 230,236 **** 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}} --- 233,239 ---- catch {unset x} set x(0) 18 set info {} ! trace add variable x(1) u traceArray catch {unset x(1)} set info } {x 1 u 1 {can't read "x(1)": no such element in array}} *************** *** 238,244 **** 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}} --- 241,247 ---- catch {unset x} set x(1) 18 set info {} ! trace add variable x(1) u traceArray unset x(1) set info } {x 1 u 1 {can't read "x(1)": no such element in array}} *************** *** 246,252 **** 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}} --- 249,255 ---- catch {unset x} set x(1) 18 set info {} ! trace add variable x(1) u traceArray unset x set info } {x 1 u 1 {can't read "x(1)": no such variable}} *************** *** 254,260 **** catch {unset x} set x(1) 18 set info {} ! trace var x u traceProc catch {unset x(0)} set info } {} --- 257,263 ---- catch {unset x} set x(1) 18 set info {} ! trace add variable x u traceProc catch {unset x(0)} set info } {} *************** *** 264,270 **** set x(2) 144 set x(3) 14 set info {} ! trace var x u traceProc unset x(1) set info } {x 1 u} --- 267,273 ---- set x(2) 144 set x(3) 14 set info {} ! trace add variable x u traceProc unset x(1) set info } {x 1 u} *************** *** 274,280 **** set x(2) 144 set x(3) 14 set info {} ! trace var x u traceProc unset x set info } {x {} u} --- 277,283 ---- set x(2) 144 set x(3) 14 set info {} ! trace add variable x u traceProc unset x set info } {x {} u} *************** *** 284,290 **** 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 --- 287,293 ---- test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} ! trace add variable x rwu traceProc catch {set x} set x 22 set x *************** *** 295,301 **** 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) --- 298,304 ---- test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} ! trace add variable x(0) rwu traceProc catch {set x(0)} set x(0) 22 set x(0) *************** *** 307,313 **** 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) --- 310,316 ---- test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} ! trace add variable x rwu traceProc catch {set x(0)} set x(0) 22 set x(0) *************** *** 322,330 **** 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 --- 325,333 ---- test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} ! trace add variable x r "traceTag 1" ! trace add variable x r "traceTag 2" ! trace add variable x r "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) r "traceTag 1" ! trace add variable x(0) r "traceTag 2" ! trace add variable x(0) r "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) r "traceTag 1" ! trace add variable x r "traceTag A1" ! trace add variable x(0) r "traceTag 2" ! trace add variable x r "traceTag A2" ! trace add variable x(0) r "traceTag 3" ! trace add variable x r "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 r "traceTag 1" ! trace add variable 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 add variable x w "traceTag 1" ! trace add variable 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 add variable 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 add variable x u "traceTag 1" ! trace add variable 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 add variable x(0) r "traceTag 1" ! trace add variable x r "traceTag 2" ! trace add variable x r traceError ! trace add variable 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 add variable x u 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 r traceError catch {set x} catch {set x} ! trace remove variable x r 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 u {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 u {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 u {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 u {traceCheck {global x; trace add variable x u traceProc}} unset x ! concat $info [trace list variable 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 add variable x(0) u {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) u {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) u {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) u {traceCheck {uplevel {trace variable x(0) r {}}}} catch {unset x(0)} ! concat $info [trace list variable 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 add variable x u {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 u {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 u {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 u $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 u {traceCheck {global x; trace add variable x r {}}} unset x ! concat $info [trace list variable x] } {0 {} {r {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} ! trace add variable x u {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) 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable x(0) w 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 r {traceTag 2} ! trace remove variable x r {traceTag 3} ! trace remove variable x r {traceTag 4} } catch {unset x} set x 44 set info {} ! trace add variable x r {traceTag 1} ! trace add variable x r {traceTag 2} ! trace add variable x r {traceTag 3} ! trace add variable x r {traceTag 4} ! trace add variable x r delTraces ! trace add variable x r {traceTag 5} set x set info } {5 1} *************** *** 617,709 **** } {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}}} --- 620,733 ---- } {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} msg] $msg ! } {1 {wrong # args: should be "trace add command name ops command"}} ! test trace-13.3.2 {trace remove command ("remove command" option)} { ! list [catch {trace remove command x y z z2} msg] $msg ! } {1 {wrong # args: should be "trace remove command name ops command"}} ! 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 ?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 ?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 {wrong # args: should be "trace add variable name ops command"}} ! 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 one or more of rwu}} ! test trace-13.6 {trace command ("remove variable" option)} { ! list [catch {trace remove variable x y} msg] $msg ! } {1 {wrong # args: should be "trace remove variable name ops command"}} ! test trace-13.7 {trace command ("remove variable" option)} { ! list [catch {trace remove variable x y z foo} msg] $msg ! } {1 {wrong # args: should be "trace remove variable name ops command"}} ! 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 one or more of rwu}} ! test trace-13.9 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x w traceProc ! trace remove variable x w traceProc } {} ! test trace-13.10 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x w traceProc ! trace remove variable x w traceProc set x 12345 set info } {} ! test trace-13.11 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x w {traceTag 1} ! trace add variable x w traceProc ! trace add variable x w {traceTag 2} set x yy ! trace remove variable x w traceProc set x 12345 ! trace remove variable x w {traceTag 1} set x foo ! trace remove variable x w {traceTag 2} set x gorp set info } {2 x {} w 1 2 1 2} ! test trace-13.12 {trace command ("remove variable" option)} { catch {unset x} set info {} ! trace add variable x w {traceTag 1} ! trace remove variable x w 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 w {traceTag 1} ! trace add variable x w traceProc ! trace add variable x w {traceTag 2} ! trace list variable x } {{w {traceTag 2}} {w traceProc} {w {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 w {traceTag 1} ! proc check {} {global x; trace list variable x} check } {{w {traceTag 1}}} *************** *** 712,718 **** 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 \ --- 736,742 ---- test trace-14.1 {long trace command} { catch {unset x} set info {} ! trace add variable 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 \ *************** *** 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 w longResult set x 44 set x 5 set x abcde *************** *** 738,744 **** 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" --- 762,768 ---- catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} ! trace add variable "x y z(a\n\{)" w traceProc set "x y z(a\n\{)" 33 set info } "{x y z} a\\n\\{ w" *************** *** 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 r {traceUnset y} ! trace add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable y w {traceUnset y} ! trace add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable 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 add variable y r {traceAppend first} ! trace add variable y r {traceUnset y} ! trace add variable y r {traceAppend third} ! trace add variable 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 add variable y(0) r {traceAppend first} ! trace add variable y(0) r {traceUnset y} ! trace add variable y(0) r {traceAppend third} ! trace add variable 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}} *************** *** 933,951 **** 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 --- 957,975 ---- test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} ! trace add variable 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 add variable x w traceProc} p1 ! trace list variable x } {{w traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} ! proc p1 {} {global x; trace add variable x w traceProc} p1 set x 44 set info *************** *** 956,962 **** 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 --- 980,986 ---- 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 u {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info *************** *** 967,972 **** --- 991,1230 ---- 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 r 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 r 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 r traceCommand + rename foo bar + set info + } {foo bar r} + test trace-18.2 {trace add command rename back again} { + rename bar foo + set info + } {bar foo r} + test trace-18.2.1 {trace add command rename trace exists} { + trace list command foo + } {{r 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 r traceCommand + rename tc::tcfoo tc::tcbar + set info + } {tc::tcfoo tc::tcbar r} + test trace-18.6 {trace add command rename in namespace back again} { + rename tc::tcbar tc::tcfoo + set info + } {tc::tcbar tc::tcfoo r} + test trace-18.7 {trace add command rename in namespace to out of namespace} { + rename tc::tcfoo tcbar + set info + } {tc::tcfoo tcbar r} + test trace-18.8 {trace add command rename back into namespace} { + rename tcbar tc::tcfoo + set info + } {tcbar tc::tcfoo r} + test trace-18.8 {trace add command failed rename doesn't trigger trace} { + set info {} + proc foo {} {} + proc bar {} {} + trace add command foo rd 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 d traceCommand + rename foo "" + set info + } {foo {} d} + 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 d traceCommand + trace list command foo + } {{d traceCommand}} + test trace-19.3 {trace add command implicit delete} { + proc foo {} {} + trace add command foo d traceCommand + proc foo {} {} + set info + } {foo {} d} + 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 rd traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info + } {{foo bar r} {bar {} d}} + 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 rd traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info + } {{foo bar r} {bar {} d}} + + 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 rd 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 r} {bar {} d}} + + # 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 rd 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 rd [list traceDelete foo] + rename foo bar + list [set info] [trace list command bar] + } {{foo bar r} {}} + + test trace-19.9 {rename trace deletes command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo r [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 r [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 d [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 d [list traceCmdrename foo] + rename foo bar + rename bar {} + # None of these should exist. + list [info commands foo] [info commands bar] [info commands someothername] + } {{} {} {}} + + + + # Delete arrays when done, so they can be re-used as scalars + # elsewhere. + + catch {unset x} + catch {unset y} + # cleanup ::tcltest::cleanupTests Index: win/makefile.vc =================================================================== RCS file: /cvsroot/tcl/win/makefile.vc,v retrieving revision 1.52 diff -c -3 -r1.52 makefile.vc *** makefile.vc 2000/05/03 00:15:11 1.52 --- makefile.vc 2000/06/20 22:49:22 *************** *** 44,50 **** #THREADDEFINES = -DTCL_THREADS=1 # Set NODEBUG to 0 to compile with symbols ! NODEBUG = 1 # The following defines can be used to control the amount of debugging # code that is added to the compilation. --- 44,50 ---- #THREADDEFINES = -DTCL_THREADS=1 # Set NODEBUG to 0 to compile with symbols ! NODEBUG = 0 # The following defines can be used to control the amount of debugging # code that is added to the compilation.