diff options
| -rw-r--r-- | ChangeLog | 31 | ||||
| -rw-r--r-- | doc/trace.n | 247 | ||||
| -rw-r--r-- | generic/tcl.decls | 14 | ||||
| -rw-r--r-- | generic/tcl.h | 15 | ||||
| -rw-r--r-- | generic/tclBasic.c | 126 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 1019 | ||||
| -rw-r--r-- | generic/tclDecls.h | 32 | ||||
| -rw-r--r-- | generic/tclInt.h | 62 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 5 | ||||
| -rw-r--r-- | generic/tclVar.c | 56 | ||||
| -rw-r--r-- | tests/trace.test | 807 |
11 files changed, 1921 insertions, 493 deletions
@@ -1,3 +1,34 @@ +2000-08-24 Eric Melski <ericm@ajubasolutions.com> + + Overall change: Added support for command rename/delete traces + and new trace syntax, from patch from Vince Darley. Added support + for array traces for variables. + + * doc/trace.n: Updated documentation for new syntax; flagged old + syntax as deprecated; added documentation for command + rename/delete traces and variable array traces. + + * tests/trace.test: Updated tests for new trace syntax; new tests + for command rename/delete traces; new tests for array traces. + + * generic/tclVar.c: Support for new trace syntax; support for + TCL_TRACE_ARRAY. + + * generic/tclStubInit.c: + * generic/tclDecls.h: + * generic/tcl.decls: Stub functions for command rename/delete traces. + + * generic/tcl.h: + * generic/tclInt.h: + * generic/tclBasic.c: Support for command traces. + + * generic/tclCmdMZ.c (TclTraceVariableObjCmd): Patched to support + new [trace] syntax: + trace {add|remove|list} {variable|command} name ops command + Added support for command traces (rename, delete operations). + Added support for TCL_TRACE_ARRAY at Tcl level (array operation + for variable traces). + 2000-08-20 Eric Melski <ericm@ajubasolutions.com> * generic/tclVar.c: Added check for non-arrays for [array statistics] diff --git a/doc/trace.n b/doc/trace.n index 7266bac..bf04299 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -5,14 +5,14 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: trace.n,v 1.3 2000/01/26 21:36:35 ericm Exp $ +'\" RCS: @(#) $Id: trace.n,v 1.4 2000/08/25 02:04:27 ericm Exp $ '\" .so man.macros -.TH trace n "" Tcl "Tcl Built-In Commands" +.TH trace n "8.4" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -trace \- Monitor variable accesses +trace \- Monitor variable accesses and command usages .SH SYNOPSIS \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE @@ -20,12 +20,55 @@ trace \- Monitor variable accesses .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: +invoked. The legal \fIoption\fR's (which may be abbreviated) are: .TP -\fBtrace variable \fIname ops command\fR +\fBtrace add \fItype name ops ?args?\fR +Where \fItype\fR is \fBcommand\fR, or \fBvariable\fR. +.RS +.TP +\fBtrace add command\fR \fIname ops command\fR +Arrange for \fIcommand\fR to be executed whenever command \fIname\fR +is modified in one of the ways given by the list \fIops\fR. \fIName\fR will be +resolved using the usual namespace resolution rules used by +procedures. If the command does not exist, an error will be thrown. +.RS +.PP +\fIOps\fR indicates which operations are of interest, and is a list of +one or more of the following items: +.TP +\fBrename\fR +Invoke \fIcommand\fR whenever the command is renamed. Note that +renaming to the empty string is considered deletion, and will not +be traced with '\fBrename\fR'. +.TP +\fBdelete\fR +Invoke \fIcommand\fR when the command is deleted. Commands can be +deleted explicitly by using the \fBrename\fR command to rename the +command to an empty string. Commands are also deleted when the +interpreter is deleted, but traces will not be invoked because there is no +interpreter in which to execute them. +.PP +When the trace triggers, three arguments are appended to +\fIcommand\fR so that the actual command is as follows: +.CS +\fIcommand oldName newName op\fR +.CE +\fIOldName\fR and \fInewName\fR give the traced command's current +(old) namename, and the name to which it is being renamed (the empty +string if this is a 'delete' operation). +\fIOp\fR indicates what operation is being performed on the +variable, and is one of \fBrename\fR or \fBdelete\fR as +defined above. The trace operation cannot be used to stop a command +from being deleted. Tcl will always remove the command once the trace +is complete. Recursive renaming or deleting will not cause further traces +of the same type to be evaluated, so a delete trace which itself +deletes the command, or a rename trace which itself renames the +command will not cause further trace evaluations to occur. +.RE +.TP +\fBtrace add variable\fI name 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 +is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array as a whole (i.e. \fIname\fR may be just the name of an array, with no parenthesized index). If \fIname\fR refers to a whole array, then @@ -35,16 +78,19 @@ will not be given a value, so it will be visible to \fBnamespace which\fR queries, but not to \fBinfo exists\fR queries. .RS .PP -\fIOps\fR indicates which operations are of interest, and consists of -one or more of the following letters: +\fIOps\fR indicates which operations are of interest, and is a list of +one or more of the following items: .TP -\fBr\fR +\fBarray\fR +Invoke \fIcommand\fR whenever the variable is accessed or modified via +the \fBarray\fR command. +\fBread\fR Invoke \fIcommand\fR whenever the variable is read. .TP -\fBw\fR +\fBwrite\fR Invoke \fIcommand\fR whenever the variable is written. .TP -\fBu\fR +\fBunset\fR Invoke \fIcommand\fR whenever the variable is unset. Variables can be unset explicitly with the \fBunset\fR command, or implicitly when procedures return (all of their local variables @@ -70,91 +116,124 @@ name used in the \fBtrace variable\fR command: the \fBupvar\fR command allows a procedure to reference a variable under a different name. \fIOp\fR indicates what operation is being performed on the -variable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as +variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as defined above. .PP \fICommand\fR executes in the same context as the code that invoked -the traced operation: if the variable was accessed as part of a -Tcl procedure, then \fIcommand\fR will have access to the same -local variables as code in the procedure. This context may be -different than the context in which the trace was created. -If \fIcommand\fR invokes a procedure (which it normally does) then -the procedure will have to use \fBupvar\fR or \fBuplevel\fR if it -wishes to access the traced variable. -Note also that \fIname1\fR may not necessarily be the same as the name -used to set the trace on the variable; differences can occur if -the access is made through a variable defined with the \fBupvar\fR -command. +the traced operation: if the variable was accessed as part of a Tcl +procedure, then \fIcommand\fR will have access to the same local +variables as code in the procedure. This context may be different +than the context in which the trace was created. If \fIcommand\fR +invokes a procedure (which it normally does) then the procedure will +have to use \fBupvar\fR or \fBuplevel\fR if it wishes to access the +traced variable. Note also that \fIname1\fR may not necessarily be +the same as the name used to set the trace on the variable; +differences can occur if the access is made through a variable defined +with the \fBupvar\fR command. .PP -For read and write traces, \fIcommand\fR can modify -the variable to affect the result of the traced operation. -If \fIcommand\fR modifies the value of a variable during a -read or write trace, then the new value will be returned as the -result of the traced operation. -The return value from \fIcommand\fR is ignored except that -if it returns an error of any sort then the traced operation -also returns an error with -the same error message returned by the trace command -(this mechanism can be used to implement read-only variables, for -example). -For write traces, \fIcommand\fR is invoked after the variable's -value has been changed; it can write a new value into the variable -to override the original value specified in the write operation. -To implement read-only variables, \fIcommand\fR will have to restore -the old value of the variable. +For read and write traces, \fIcommand\fR can modify the variable to +affect the result of the traced operation. If \fIcommand\fR modifies +the value of a variable during a read or write trace, then the new +value will be returned as the result of the traced operation. The +return value from \fIcommand\fR is ignored except that if it returns +an error of any sort then the traced operation also returns an error +with the same error message returned by the trace command (this +mechanism can be used to implement read-only variables, for example). +For write traces, \fIcommand\fR is invoked after the variable's value +has been changed; it can write a new value into the variable to +override the original value specified in the write operation. To +implement read-only variables, \fIcommand\fR will have to restore the +old value of the variable. .PP While \fIcommand\fR is executing during a read or write trace, traces -on the variable are temporarily disabled. -This means that reads and writes invoked by -\fIcommand\fR will occur directly, without invoking \fIcommand\fR -(or any other traces) again. -However, if \fIcommand\fR unsets the variable then unset traces -will be invoked. +on the variable are temporarily disabled. This means that reads and +writes invoked by \fIcommand\fR will occur directly, without invoking +\fIcommand\fR (or any other traces) again. However, if \fIcommand\fR +unsets the variable then unset traces will be invoked. .PP -When an unset trace is invoked, the variable has already been -deleted: it will appear to be undefined with no traces. -If an unset occurs because of a procedure return, then the -trace will be invoked in the variable context of the procedure -being returned to: the stack frame of the returning procedure -will no longer exist. -Traces are not disabled during unset traces, so if an unset trace -command creates a new trace and accesses the variable, the -trace will be invoked. -Any errors in unset traces are ignored. +When an unset trace is invoked, the variable has already been deleted: +it will appear to be undefined with no traces. If an unset occurs +because of a procedure return, then the trace will be invoked in the +variable context of the procedure being returned to: the stack frame +of the returning procedure will no longer exist. Traces are not +disabled during unset traces, so if an unset trace command creates a +new trace and accesses the variable, the trace will be invoked. Any +errors in unset traces are ignored. .PP -If there are multiple traces on a variable they are invoked -in order of creation, most-recent first. -If one trace returns an error, then no further traces are -invoked for the variable. -If an array element has a trace set, and there is also a trace -set on the array as a whole, the trace on the overall array -is invoked before the one on the element. +If there are multiple traces on a variable they are invoked in order +of creation, most-recent first. If one trace returns an error, then +no further traces are invoked for the variable. If an array element +has a trace set, and there is also a trace set on the array as a +whole, the trace on the overall array 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 -element, but will not remove traces on the overall array. +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 element, +but will not remove traces on the overall array. .PP This command returns an empty string. .RE .TP +\fBtrace remove \fItype name opList command\fR +Where \fItype\fR is either \fBcommand\fR or \fBvariable\fR. +.RS +.TP +\fBtrace remove command\fI name opList command\fR +If there is a trace set on command \fIname\fR with the operations and +command given by \fIopList\fR and \fIcommand\fR, then the trace is +removed, so that \fIcommand\fR will never again be invoked. Returns +an empty string. If \fIname\fR doesn't exist, the command will throw +an error. +.TP +\fBtrace remove variable\fI name opList command\fR +If there is a trace set on variable \fIname\fR with the operations and +command given by \fIopList\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 \fBcommand\fR or \fBvariable\fR. +.RS +.TP +\fBtrace list command\fI name\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 \fIopList\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. +.TP +\fBtrace list variable\fI name\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 \fIopList\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 +.PP +For backwards compatibility, three other subcommands are available: +.RS +.TP +\fBtrace variable \fIname ops command\fR +This is equivalent to \fBtrace add variable \fIname ops command\fR. +.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. +This is equivalent to \fBtrace remove variable \fIname ops command\fR +.TP +\fBtrace vinfo \fIname\fR +This is equivalent to \fBtrace list variable \fIname\fR +.RE +.PP +These subcommands are deprecated and will likely be removed in a +future version of Tcl. They use an older syntax in which \fBarray\fR, +\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR, +\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a +list, but simply a string concatenation of the operations, such as +\fBrwua\fR. .SH KEYWORDS -read, variable, write, trace, unset +read, command, rename, variable, write, trace, unset diff --git a/generic/tcl.decls b/generic/tcl.decls index ea5b6d2..e71c6ee 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.38 2000/07/22 01:53:23 ericm Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.39 2000/08/25 02:04:27 ericm Exp $ library tcl @@ -1406,6 +1406,18 @@ declare 405 generic { declare 406 generic { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } +declare 407 generic { + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, char *varName, \ + int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData) +} +declare 408 generic { + int Tcl_TraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) +} +declare 409 generic { + void Tcl_UntraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) +} ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index eb8329a..b0b74a4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.76 2000/08/15 00:08:36 ericm Exp $ + * RCS: @(#) $Id: tcl.h,v 1.77 2000/08/25 02:04:27 ericm Exp $ */ #ifndef _TCL @@ -603,6 +603,8 @@ typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, 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)); @@ -926,6 +928,17 @@ typedef struct Tcl_DString { #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 +#ifndef TCL_REMOVE_OBSOLETE_TRACES +/* Required to support old variable/vdelete/vinfo traces */ +#define TCL_TRACE_OLD_STYLE 0x1000 +#endif + +/* + * Flag values passed to command-related procedures. + */ + +#define TCL_TRACE_RENAME 0x2000 +#define TCL_TRACE_DELETE 0x4000 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e9a52e6..47862de 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.28 2000/05/23 22:10:49 ericm Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.29 2000/08/25 02:04:28 ericm Exp $ */ #include "tclInt.h" @@ -25,6 +25,9 @@ * 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,6 +338,7 @@ Tcl_CreateInterp() iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; + iPtr->activeCmdTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ @@ -447,8 +451,9 @@ Tcl_CreateInterp() } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } @@ -1498,8 +1503,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1659,8 +1665,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1975,6 +1982,8 @@ TclRenameCommand(interp, oldName, newName) 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,7 +2290,7 @@ Tcl_DeleteCommandFromToken(interp, cmd) * flag allows us to detect these cases and skip nested deletes. */ - if (cmdPtr->deleted) { + 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,6 +2302,33 @@ Tcl_DeleteCommandFromToken(interp, cmd) 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,7 +2342,6 @@ Tcl_DeleteCommandFromToken(interp, cmd) iPtr->compileEpoch++; } - cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command @@ -2381,6 +2416,75 @@ Tcl_DeleteCommandFromToken(interp, cmd) 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; +} + /* *---------------------------------------------------------------------- @@ -3870,11 +3974,11 @@ Tcl_CreateTrace(interp, level, proc, clientData) iPtr->flags |= DONT_COMPILE_CMDS_INLINE; tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->nextPtr = iPtr->tracePtr; - iPtr->tracePtr = tracePtr; + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cc17067..2421158 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.27 2000/05/26 08:51:11 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.28 2000/08/25 02:04:28 ericm Exp $ */ #include "tclInt.h" @@ -55,12 +55,43 @@ typedef struct { } TraceVarInfo; /* + * The same structure is used for command traces at present + */ + +typedef TraceVarInfo TraceCommandInfo; + +/* * 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 TclTraceVariableObjCmd; +Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; + +/* + * Each subcommand has a number of 'types' to which it can apply. + * Currently 'command' 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", "variable", (char*) NULL +}; +static Tcl_TraceTypeObjCmd* traceSubCmds[] = { + TclTraceCommandObjCmd, + 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)); + /* *---------------------------------------------------------------------- @@ -2469,13 +2500,17 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) * * 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 + * * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. - * *---------------------------------------------------------------------- */ @@ -2488,17 +2523,26 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex, commandLength; - char *name, *rwuOps, *command, *p; + char *name, *flagOps, *command, *p; size_t length; + /* Main sub commands to 'trace' */ static char *traceOptions[] = { - "variable", "vdelete", "vinfo", (char *) NULL + "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_VARIABLE, TRACE_VDELETE, TRACE_VINFO + TRACE_ADD, TRACE_LIST, TRACE_REMOVE, +#ifndef TCL_REMOVE_OBSOLETE_TRACES + TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO +#endif }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -2507,33 +2551,449 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) 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; + 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, "type ?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 if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; + 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; - 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 (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 if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; + } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + break; + } + case TRACE_OLD_VINFO: { + ClientData clientData; + char ops[5]; + 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++; + } + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + *p = 'a'; + 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 */ + } + return TCL_OK; + + badVarOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be one or more of rwua", (char *) NULL); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceCommandObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|list} command ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or list) being performed; + * may add or remove command traces on a command. + * + *---------------------------------------------------------------------- + */ + +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, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; + static char *opStrings[] = { "delete", "rename", (char *) NULL }; + enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of delete or rename", TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_CMD_RENAME: + flags |= TCL_TRACE_RENAME; + break; + case TRACE_CMD_DELETE: + flags |= TCL_TRACE_DELETE; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->errMsg = NULL; + tcmdPtr->length = length; + flags |= TCL_TRACE_DELETE; + strcpy(tcmdPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) tcmdPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this command to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + TraceCommandInfo *tcmdPtr; + ClientData clientData; + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + tcmdPtr = (TraceCommandInfo *) clientData; + if ((tcmdPtr->length == length) + && (tcmdPtr->flags == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceCommand(interp, name, + flags | TCL_TRACE_DELETE, + TraceCommandProc, clientData); + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + } + ckfree((char *) tcmdPtr); + break; } } - if (flags == 0) { - goto badOps; + } + break; + } + case TRACE_LIST: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("rename",6)); } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("delete",6)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceVariableObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|list} variable ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or list) being performed; + * may add or remove variable traces on a variable. + * + *---------------------------------------------------------------------- + */ + +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, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE }; + static char *opStrings[] = { "array", "read", "unset", "write", + (char *) NULL }; + enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, + TRACE_VAR_WRITE }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of array, read, unset, or write", + TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen ; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_VAR_ARRAY: + flags |= TCL_TRACE_ARRAY; + break; + case TRACE_VAR_READ: + flags |= TCL_TRACE_READS; + break; + case TRACE_VAR_UNSET: + flags |= TCL_TRACE_UNSETS; + break; + case TRACE_VAR_WRITE: + flags |= TCL_TRACE_WRITES; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); @@ -2542,55 +3002,27 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[2]); + name = Tcl_GetString(objv[3]); 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; - } - + } 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. */ - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; - clientData = 0; - name = Tcl_GetString(objv[2]); + TraceVarInfo *tvarPtr; + ClientData clientData = 0; + name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + if ((tvarPtr->length == length) + && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, @@ -2602,67 +3034,339 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) break; } } - break; } - case TRACE_VINFO: { - ClientData clientData; - char ops[4]; - Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + break; + } + case TRACE_LIST: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("array", 5)); } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; - name = Tcl_GetString(objv[2]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { + if (tvarPtr->flags & TCL_TRACE_READS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("read", 4)); + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("write", 5)); + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("unset", 5)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} - 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'; + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - /* - * 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. - */ +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; - 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); + 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; } - default: { - panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); - } + } } + 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. + * + *---------------------------------------------------------------------- + */ - badOps: - Tcl_AppendResult(interp, "bad operations \"", rwuOps, - "\": should be one or more of rwu", (char *) NULL); - return TCL_ERROR; +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); +} + +/* + *---------------------------------------------------------------------- + * + * TraceCommandProc -- + * + * This procedure is called to handle command changes that have + * been traced using the "trace" command. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TraceCommandProc(clientData, interp, oldName, newName, flags) + ClientData clientData; /* Information about the command trace. */ + Tcl_Interp *interp; /* Interpreter containing command. */ + char *oldName; /* Name of command being changed. */ + char *newName; /* New name of command. Empty string + * or NULL means command is being deleted + * (renamed to ""). */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + Tcl_SavedResult state; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + tcmdPtr->errMsg = NULL; + } + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + /* + * Generate a command to execute by appending list elements + * for the old and new command name and the operation. + */ + + if (newName == NULL) { + newName = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, newName); + if (flags & TCL_TRACE_RENAME) { + Tcl_DStringAppend(&cmd, " rename", 7); + } else if (flags & TCL_TRACE_DELETE) { + Tcl_DStringAppend(&cmd, " delete", 7); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + } + ckfree((char *) tcmdPtr); + } + return; } /* @@ -2706,50 +3410,67 @@ TraceVarProc(clientData, interp, name1, name2, flags) tvarPtr->errMsg = NULL; } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if (tvarPtr->length != (size_t) 0) { + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. + */ - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. The five - * extra characters are for three space, the opcode character, - * and the terminating null. - */ + if (name2 == NULL) { + name2 = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, name2); +#ifndef TCL_REMOVE_OBSOLETE_TRACES + if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " a", 2); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " w", 2); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " u", 2); + } + } else { +#endif + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " array", 6); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " read", 5); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " write", 6); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " unset", 6); + } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + } +#endif + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ - if (name2 == NULL) { - name2 = ""; - } - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); - Tcl_DStringAppendElement(&cmd, name1); - Tcl_DStringAppendElement(&cmd, name2); - if (flags & TCL_TRACE_READS) { - Tcl_DStringAppend(&cmd, " r", 2); - } else if (flags & TCL_TRACE_WRITES) { - Tcl_DStringAppend(&cmd, " w", 2); - } else if (flags & TCL_TRACE_UNSETS) { - Tcl_DStringAppend(&cmd, " u", 2); - } + Tcl_SaveResult(interp, &state); - /* - * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. - */ + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { /* copy error msg to result */ + char *string; + int length; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); + result = tvarPtr->errMsg; + } - Tcl_SaveResult(interp, &state); + Tcl_RestoreResult(interp, &state); - code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); - if (code != TCL_OK) { /* copy error msg to result */ - char *string; - int length; - - string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); - tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); - memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); - result = tvarPtr->errMsg; + Tcl_DStringFree(&cmd); } - - Tcl_RestoreResult(interp, &state); - - Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { result = NULL; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8b041c7..fd355df 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.39 2000/07/22 01:53:24 ericm Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.40 2000/08/25 02:04:28 ericm Exp $ */ #ifndef _TCLDECLS @@ -1268,6 +1268,21 @@ EXTERN void Tcl_InitHashTableEx _ANSI_ARGS_(( /* 406 */ EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); +/* 407 */ +EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_(( + Tcl_Interp * interp, char * varName, + int flags, Tcl_CommandTraceProc * procPtr, + ClientData prevClientData)); +/* 408 */ +EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); +/* 409 */ +EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1742,6 +1757,9 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 404 */ void (*tcl_InitHashTableEx) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 405 */ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 406 */ + ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 407 */ + int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 408 */ + void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 409 */ } TclStubs; #ifdef __cplusplus @@ -3415,6 +3433,18 @@ extern TclStubs *tclStubsPtr; #define Tcl_InitObjHashTable \ (tclStubsPtr->tcl_InitObjHashTable) /* 406 */ #endif +#ifndef Tcl_CommandTraceInfo +#define Tcl_CommandTraceInfo \ + (tclStubsPtr->tcl_CommandTraceInfo) /* 407 */ +#endif +#ifndef Tcl_TraceCommand +#define Tcl_TraceCommand \ + (tclStubsPtr->tcl_TraceCommand) /* 408 */ +#endif +#ifndef Tcl_UntraceCommand +#define Tcl_UntraceCommand \ + (tclStubsPtr->tcl_UntraceCommand) /* 409 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index bb3e32d..c4858d4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.49 2000/08/10 18:25:15 davidg Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.50 2000/08/25 02:04:29 ericm Exp $ */ #ifndef _TCLINT @@ -270,6 +270,35 @@ typedef struct VarTrace { } 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 @@ -1020,10 +1049,8 @@ typedef struct Command { /* 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. */ + 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,9 +1058,31 @@ typedef struct Command { * 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,6 +1297,9 @@ typedef struct Interp { * accessed directly; see comment above. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + 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. diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7a76c9b..c927969 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.42 2000/07/26 01:30:59 davidg Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.43 2000/08/25 02:04:29 ericm Exp $ */ #include "tclInt.h" @@ -809,6 +809,9 @@ TclStubs tclStubs = { Tcl_CreateHashEntry, /* 404 */ Tcl_InitHashTableEx, /* 405 */ Tcl_InitObjHashTable, /* 406 */ + Tcl_CommandTraceInfo, /* 407 */ + Tcl_TraceCommand, /* 408 */ + Tcl_UntraceCommand, /* 409 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index 8e431c7..48fd89a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.21 2000/08/21 01:37:51 ericm Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.22 2000/08/25 02:04:29 ericm Exp $ */ #include "tclInt.h" @@ -2309,8 +2309,17 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; - - varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + int flagMask; + + /* + * We strip 'flags' down to just the parts which are relevant to + * TclLookupVar, to avoid conflicts between trace flags and + * internal namespace flags such as 'FIND_ONLY_NS'. This can + * now occur since we have trace flags with values 0x1000 and higher. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, + (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -2320,14 +2329,17 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) * Set up trace information. */ - tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + flagMask = (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY); - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & flagMask; + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; return TCL_OK; } @@ -2403,17 +2415,31 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - - varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), + int flagMask; + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + flags &= flagMask; for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { diff --git a/tests/trace.test b/tests/trace.test index f5d1d0f..11da1a9 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.7 2000/07/31 18:03:50 ericm Exp $ +# RCS: @(#) $Id: trace.test,v 1.8 2000/08/25 02:04:29 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -52,57 +52,60 @@ proc traceCheck {cmd args} { 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 var x r traceScalar + trace add variable x read 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}}} +} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { catch {unset x} set x 123 set info {} - trace var x r traceScalar + trace add variable x read traceScalar list [catch {set x} msg] $msg $info -} {0 123 {x {} r 0 123}} +} {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} - trace var x r traceScalar + trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} - trace var x(2) r traceArray + trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info -} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}} +} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { catch {unset x} set x(2) zzz set info {} - trace var x(2) r traceArray + trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info -} {0 zzz {x 2 r 0 zzz}} +} {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { catch {unset x} set info {} - trace variable x r traceArray2 + trace add variable x read traceArray2 proc p {} { global x set x(2) willi return $x(2) } list [catch {p} msg] $msg $info -} {0 willi {x 2 r}} +} {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { catch {unset x} set info {} - trace variable x r q + trace add variable x read q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] @@ -115,25 +118,25 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista return $x(Y) } list [catch {p} msg] $msg $info -} {0 wolf {x Y r}} +} {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} - trace var x r traceArray + trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { catch {unset x} set x(2) zzz set info {} - trace var x r traceArray + trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info -} {0 zzz {x 2 r 0 zzz}} +} {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { catch {unset x} set x 444 set info {} - trace var x r traceScalar + trace add variable x read traceScalar unset x set info } {} @@ -143,29 +146,29 @@ test trace-1.10 {trace variable reads} { test trace-2.1 {trace variable writes} { catch {unset x} set info {} - trace var x w traceScalar + trace add variable x write traceScalar set x 123 set info -} {x {} w 0 123} +} {x {} write 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} - trace var x(33) w traceArray + trace add variable x(33) write traceArray set x(33) 444 set info -} {x 33 w 0 444} +} {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} - trace var x w traceArray + trace add variable x write traceArray set x(abc) qq set info -} {x abc w 0 qq} +} {x abc write 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} - trace var x w traceScalar + trace add variable x write traceScalar set x set info } {} @@ -173,7 +176,7 @@ test trace-2.5 {trace variable writes} { catch {unset x} set x 1234 set info {} - trace var x w traceScalar + trace add variable x write traceScalar unset x set info } {} @@ -186,42 +189,42 @@ test trace-2.5 {trace variable writes} { test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} - trace var x r traceScalarAppend + trace add variable x read traceScalarAppend append x 123 append x 456 lappend x 789 set info -} {x {} r 0 123456} +} {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} - trace var x rw traceScalarAppend + trace add variable x {read write} traceScalarAppend append x 123 lappend x 456 set info -} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} +} {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { catch {unset x} set info {} - trace var x u traceScalar + trace add variable x unset traceScalar catch {unset x} set info -} {x {} u 1 {can't read "x": no such variable}} +} {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} - trace var x u traceScalar + trace add variable x unset traceScalar unset x set info -} {x {} u 1 {can't read "x": no such variable}} +} {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} - trace var x u traceScalar + trace add variable x unset traceScalar set x 44 set x set info @@ -230,31 +233,31 @@ test trace-4.4 {trace unsets on array elements} { catch {unset x} set x(0) 18 set info {} - trace var x(1) u traceArray + trace add variable x(1) unset traceArray catch {unset x(1)} set info -} {x 1 u 1 {can't read "x(1)": no such element in array}} +} {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} - trace var x(1) u traceArray + trace add variable x(1) unset traceArray unset x(1) set info -} {x 1 u 1 {can't read "x(1)": no such element in array}} +} {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} - trace var x(1) u traceArray + trace add variable x(1) unset traceArray unset x set info -} {x 1 u 1 {can't read "x(1)": no such variable}} +} {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} - trace var x u traceProc + trace add variable x unset traceProc catch {unset x(0)} set info } {} @@ -264,38 +267,74 @@ test trace-4.8 {trace unsets on whole arrays} { set x(2) 144 set x(3) 14 set info {} - trace var x u traceProc + trace add variable x unset traceProc unset x(1) set info -} {x 1 u} +} {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} - trace var x u traceProc + trace add variable x unset traceProc + unset x + set info +} {x {} unset} + +# Array tracing on variables +test trace-5.1 {array traces fire on accesses via [array]} { + catch {unset x} + trace add variable x array traceArray2 + set ::info {} + array set x {a 1} + set info +} {x {} array} +test trace-5.2 {array traces do not fire on normal accesses} { + catch {unset x} + trace add variable x array traceArray2 + set ::info {} + set x(a) 1 + set x(b) $x(a) + set info +} {} +test trace-5.3 {array traces outlive variable} { + catch {unset x} + trace add variable x array traceArray2 + set ::info {} + set x(a) 1 unset x + array set x {a 1} set info -} {x {} u} +} {} +test trace-5.4 {array traces properly listed in trace information} { + catch {unset x} + trace add variable x array traceArray2 + trace list variable x +} [list [list array traceArray2]] +test trace-5.5 {array traces properly listed in trace information} { + catch {unset x} + trace variable x a traceArray2 + trace vinfo x +} [list [list a traceArray2]] # Trace multiple trace types at once. test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} - trace var x rwu traceProc + trace add variable x {read write unset} traceProc catch {set x} set x 22 set x set x 33 unset x set info -} {x {} r x {} w x {} r x {} w x {} u} +} {x {} read x {} write x {} read x {} write x {} unset} test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} - trace var x(0) rwu traceProc + trace add variable x(0) {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) @@ -303,11 +342,11 @@ test trace-5.2 {multiple ops traced on array element} { unset x(0) unset x set info -} {x 0 r x 0 w x 0 r x 0 w x 0 u} +} {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} - trace var x rwu traceProc + trace add variable x {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) @@ -315,16 +354,16 @@ test trace-5.3 {multiple ops traced on whole array} { unset x(0) unset x set info -} {x 0 w x 0 r x 0 w x 0 u x {} u} +} {x 0 write x 0 read x 0 write x 0 unset x {} unset} # Check order of invocation of traces test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} - trace var x r "traceTag 1" - trace var x r "traceTag 2" - trace var x r "traceTag 3" + trace add variable x read "traceTag 1" + trace add variable x read "traceTag 2" + trace add variable x read "traceTag 3" catch {set x} set x 22 set x @@ -334,9 +373,9 @@ test trace-6.2 {order of invocation of traces} { 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" + trace add variable x(0) read "traceTag 1" + trace add variable x(0) read "traceTag 2" + trace add variable x(0) read "traceTag 3" set x(0) set info } {3 2 1} @@ -344,12 +383,12 @@ test trace-6.3 {order of invocation of traces} { 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" + trace add variable x(0) read "traceTag 1" + trace add variable x read "traceTag A1" + trace add variable x(0) read "traceTag 2" + trace add variable x read "traceTag A2" + trace add variable x(0) read "traceTag 3" + trace add variable x read "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} @@ -360,47 +399,47 @@ test trace-7.1 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x r "traceTag 1" - trace var x r traceError + trace add variable x read "traceTag 1" + trace add variable x read traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x w "traceTag 1" - trace var x w traceError + trace add variable x write "traceTag 1" + trace add variable x write traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x w traceError + trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x u "traceTag 1" - trace var x u traceError + trace add variable x unset "traceTag 1" + trace add variable x unset traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} - trace var x(0) r "traceTag 1" - trace var x r "traceTag 2" - trace var x r traceError - trace var x r "traceTag 3" + trace add variable x(0) read "traceTag 1" + trace add variable x read "traceTag 2" + trace add variable x read traceError + trace add variable x read "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-7.6 {error returns from traces} { catch {unset x} set x 123 - trace var x u traceError + trace add variable x unset traceError list [catch {unset x} msg] $msg } {0 {}} test trace-7.7 {error returns from traces} { @@ -409,10 +448,10 @@ test trace-7.7 {error returns from traces} { # when the trace is deleted. catch {unset x} set x 123 - trace var x r traceError + trace add variable x read traceError catch {set x} catch {set x} - trace vdelete x r traceError + trace remove variable x read traceError } {} # Check to see that variables are expunged before trace @@ -423,7 +462,7 @@ test trace-8.1 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel set x}} + trace add variable x unset {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} @@ -431,7 +470,7 @@ test trace-8.2 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel set x 22}} + trace add variable x unset {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} @@ -439,7 +478,7 @@ test trace-8.3 {be sure traces are cleared before unset trace called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel trace vinfo x}} + trace add variable x unset {traceCheck {uplevel trace list variable x}} unset x set info } {0 {}} @@ -447,16 +486,16 @@ test trace-8.4 {set new trace during unset trace} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {global x; trace var x u traceProc}} + trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} unset x - concat $info [trace vinfo x] -} {0 {} {u traceProc}} + concat $info [trace list variable x] +} {0 {} {unset traceProc}} test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {uplevel set x(0)}} + trace add variable x(0) unset {traceCheck {uplevel set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} @@ -464,7 +503,7 @@ test trace-9.2 {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) zzz}} + trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} @@ -472,7 +511,7 @@ test trace-9.3 {array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} + trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}} unset x(0) set info } {0 {}} @@ -480,16 +519,16 @@ test trace-9.4 {set new array element trace during unset trace} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} + trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} catch {unset x(0)} - concat $info [trace vinfo x(0)] -} {0 {} {r {}}} + concat $info [trace list variable x(0)] +} {0 {} {read {}}} test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x u {traceCheck {uplevel set x(0)}} + trace add variable x unset {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} @@ -497,7 +536,7 @@ test trace-10.2 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {uplevel set x(y) 22}} + trace add variable x unset {traceCheck {uplevel set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} @@ -505,7 +544,7 @@ test trace-10.3 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {uplevel array exists x}} + trace add variable x unset {traceCheck {uplevel array exists x}} unset x set info } {0 0} @@ -513,8 +552,8 @@ test trace-10.4 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - set cmd {traceCheck {uplevel {trace vinfo x}}} - trace var x u $cmd + set cmd {traceCheck {uplevel {trace list variable x}}} + trace add variable x unset $cmd unset x set info } {0 {}} @@ -522,15 +561,15 @@ test trace-10.5 {set new array trace during unset trace} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {global x; trace var x r {}}} + trace add variable x unset {traceCheck {global x; trace add variable x read {}}} unset x - concat $info [trace vinfo x] -} {0 {} {r {}}} + concat $info [trace list variable x] +} {0 {} {read {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {global x; set x 44}} + trace add variable x unset {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} @@ -540,52 +579,52 @@ test trace-10.6 {create scalar during array unset trace} { test trace-11.1 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-11.2 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-11.3 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + trace add variable x(0) write traceProc set x(0) 22 set info -} {x 0 w} +} {x 0 write} test trace-11.4 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-11.5 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc set x 22 set info -} {x {} w} +} {x {} write} test trace-11.6 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc set x(0) 22 set info -} {x 0 w} +} {x 0 write} test trace-11.7 {create array element during read trace} { catch {unset x} set x(2) zzz - trace var x r {traceCrtElement xyzzy} + trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 - list [catch {trace var x(0) w traceProc} msg] $msg + list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check deleting one trace from another. @@ -593,126 +632,185 @@ test trace-11.8 {errors when setting variable traces} { 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} + trace remove variable x read {traceTag 2} + trace remove variable x read {traceTag 3} + trace remove variable x read {traceTag 4} } catch {unset x} set x 44 set info {} - trace 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} + trace add variable x read {traceTag 1} + trace add variable x read {traceTag 2} + trace add variable x read {traceTag 3} + trace add variable x read {traceTag 4} + trace add variable x read delTraces + trace add variable x read {traceTag 5} set x set info } {5 1} # Check operation and syntax of "trace" command. -test trace-13.1 {trace command (overall)} { +# Syntax for adding/removing variable and command traces is basically the +# same: +# trace add variable name opList command +# trace remove variable name opList command +# +# The following loops just get all the common "wrong # args" tests done. + +set i 0 +set start "wrong # args:" +foreach type {variable command} { + foreach op {add remove} { + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace $op $type} msg] $msg + } [list 1 "$start should be \"trace $op $type name opList command\""] + test trace-13.0.[incr i] "trace command wrong # args errors" { + list [catch {trace $op $type foo} msg] $msg + } [list 1 "$start should be \"trace $op $type name opList command\""] + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace $op $type foo bar} msg] $msg + } [list 1 "$start should be \"trace $op $type name opList command\""] + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace $op $type foo bar baz boo} msg] $msg + } [list 1 "$start should be \"trace $op $type name opList command\""] + } + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace list $type foo bar} msg] $msg + } [list 1 "$start should be \"trace list $type name\""] + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace list $type} msg] $msg + } [list 1 "$start should be \"trace list $type name\""] +} + +test trace-13.1 "trace command, wrong # args errors" { list [catch {trace} msg] $msg -} {1 {wrong # args: should be "trace option [arg arg ...]"}} -test trace-13.2 {trace command (overall)} { +} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""] +test trace-13.2 "trace command, wrong # args errors" { + list [catch {trace add} msg] $msg +} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""] +test trace-13.3 "trace command, wrong # args errors" { + list [catch {trace remove} msg] $msg +} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""] +test trace-13.4 "trace command, wrong # args errors" { + list [catch {trace list} msg] $msg +} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""] + +test trace-13.5 {trace command, invalid option} { 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 1 "bad option \"gorp\": must be add, list, remove, variable, vdelete, or vinfo"] + +# Again, [trace ... command] and [trace ... variable] share syntax and +# error message styles for their opList options; these loops test those +# error messages. + +set i 0 +set errs [list "array, read, unset, or write" "delete or rename"] +set abbvs [list {a r u w} {d r}] +foreach type {variable command} err $errs abbvlist $abbvs { + foreach op {add remove} { + test trace-13.6.[incr i] "trace $op $type errors" { + list [catch {trace $op $type x {y z w} a} msg] $msg + } [list 1 "bad operation \"y\": must be $err"] + foreach abbv $abbvlist { + test trace-13.6.[incr i] "trace $op $type rejects abbreviations" { + list [catch {trace $op $type x $abbv a} msg] $msg + } [list 1 "bad operation \"$abbv\": must be $err"] + } + test trace-13.6.[incr i] "trace $op $type rejects null opList" { + list [catch {trace $op $type x {} a} msg] $msg + } [list 1 "bad operation list \"\": must be one or more of $err"] + } +} + +test trace-13.7 {trace command, "trace variable" errors} { + list [catch {trace variable} msg] $msg +} [list 1 "wrong # args: should be \"trace variable name ops command\""] +test trace-13.8 {trace command, "trace variable" errors} { + list [catch {trace variable x} msg] $msg +} [list 1 "wrong # args: should be \"trace variable name ops command\""] +test trace-13.9 {trace command, "trace variable" errors} { 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 +} [list 1 "wrong # args: should be \"trace variable name ops command\""] +test trace-13.10 {trace command, "trace variable" errors} { + list [catch {trace variable x y z w} msg] $msg +} [list 1 "wrong # args: should be \"trace variable name ops command\""] +test trace-13.11 {trace command, "trace variable" errors} { + list [catch {trace variable x y z} msg] $msg +} [list 1 "bad operations \"y\": should be one or more of rwua"] + + +test trace-13.9 {trace command ("remove variable" option)} { + catch {unset x} + set info {} + trace add variable x write traceProc + trace remove variable x write traceProc } {} -test trace-13.10 {trace command ("vdelete" option)} { +test trace-13.10 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w traceProc - trace vdelete x w traceProc + trace add variable x write traceProc + trace remove variable x write traceProc set x 12345 set info } {} -test trace-13.11 {trace command ("vdelete" option)} { +test trace-13.11 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w {traceTag 1} - trace var x w traceProc - trace var x w {traceTag 2} + trace add variable x write {traceTag 1} + trace add variable x write traceProc + trace add variable x write {traceTag 2} set x yy - trace vdelete x w traceProc + trace remove variable x write traceProc set x 12345 - trace vdelete x w {traceTag 1} + trace remove variable x write {traceTag 1} set x foo - trace vdelete x w {traceTag 2} + trace remove variable x write {traceTag 2} set x gorp set info -} {2 x {} w 1 2 1 2} -test trace-13.12 {trace command ("vdelete" option)} { +} {2 x {} write 1 2 1 2} +test trace-13.12 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w {traceTag 1} - trace vdelete x w non_existent + trace add variable x write {traceTag 1} + trace remove variable x write non_existent set x 12345 set info } {1} -test trace-13.13 {trace command ("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)} { +test trace-13.15 {trace command ("list variable" option)} { catch {unset x} - trace vinfo x + trace add variable x write {traceTag 1} + trace add variable x write traceProc + trace add variable x write {traceTag 2} + trace list variable x +} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} +test trace-13.16 {trace command ("list variable" option)} { + catch {unset x} + trace list variable x } {} -test trace-13.17 {trace command ("vinfo" option)} { +test trace-13.17 {trace command ("list variable" option)} { catch {unset x} - trace vinfo x(0) + trace list variable x(0) } {} -test trace-13.18 {trace command ("vinfo" option)} { +test trace-13.18 {trace command ("list variable" option)} { catch {unset x} set x 44 - trace vinfo x(0) + trace list variable x(0) } {} -test trace-13.19 {trace command ("vinfo" option)} { +test trace-13.19 {trace command ("list variable" option)} { catch {unset x} set x 44 - trace var x w {traceTag 1} - proc check {} {global x; trace vinfo x} + trace add variable x write {traceTag 1} + proc check {} {global x; trace list variable x} check -} {{w {traceTag 1}}} +} {{write {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-14.1 {long trace command} { catch {unset x} set info {} - trace var x w {traceTag {This is a very very long argument. It's \ + trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ @@ -729,7 +827,7 @@ test trace-14.2 {long trace command result to ignore} { 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 + trace add variable x write longResult set x 44 set x 5 set x abcde @@ -738,10 +836,10 @@ test trace-14.3 {special list-handling in trace commands} { catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} - trace var "x y z(a\n\{)" w traceProc + trace add variable "x y z(a\n\{)" write traceProc set "x y z(a\n\{)" 33 set info -} "{x y z} a\\n\\{ w" +} "{x y z} a\\n\\{ write" # Check for proper handling of unsets during traces. @@ -769,162 +867,162 @@ test trace-15.1 {unsets during read traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceUnset y} - trace var y u {traceAppend unset} + trace add variable y read {traceUnset y} + trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceUnset y(0)} + trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-15.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceUnset y} + trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceReset y y} + trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset y(0) y(0)} + trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset y y(0)} + trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset2 y y(0)} + trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} - trace var y w {traceUnset y} - trace var y u {traceAppend unset} + trace add variable y write {traceUnset y} + trace add variable y unset {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceUnset y(0)} + trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceUnset y} + trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} - trace var y w {traceReset y y} + trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset y(0) y(0)} + trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset y y(0)} + trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset2 y y(0)} + trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} - trace var y u {traceUnset y} + trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-15.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceUnset y(0)} + trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-15.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceUnset y} + trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} - trace var y u {traceReset2 y y} + trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-15.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceReset2 y(0) y(0)} + trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-15.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceReset2 y y(0)} + trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceAppend first} - trace var y r {traceUnset y} - trace var y r {traceAppend third} - trace var y u {traceAppend unset} + trace add variable y read {traceAppend first} + trace add variable y read {traceUnset y} + trace add variable y read {traceAppend third} + trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} - trace 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} + trace add variable y(0) read {traceAppend first} + trace add variable y(0) read {traceUnset y} + trace add variable y(0) read {traceAppend third} + trace add variable y(0) unset {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} @@ -933,30 +1031,30 @@ test trace-15.22 {unsets cancelling traces} { test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} - trace var x u {traceProc} + trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info -} {1 {can't unset "x": no such variable} {x {} u}} +} {1 {can't unset "x": no such variable} {x {} unset}} test trace-16.2 {traced variables must survive procedure exits} { catch {unset x} - proc p1 {} {global x; trace var x w traceProc} + proc p1 {} {global x; trace add variable x write traceProc} p1 - trace vinfo x -} {{w traceProc}} + trace list variable x +} {{write traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} - proc p1 {} {global x; trace var x w traceProc} + proc p1 {} {global x; trace add variable x write traceProc} p1 set x 44 set info -} {x {} w} +} {x {} write} # Be sure that procedure frames are released before unset traces # are invoked. test trace-17.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info @@ -968,6 +1066,265 @@ test trace-17.1 {unset traces on procedure returns} { catch {unset x} catch {unset y} +test trace-17.2 {trace add command (command existence)} { + # Just in case! + catch {rename nosuchname ""} + list [catch {trace add command nosuchname rename traceCommand} msg] $msg +} {1 {unknown command "nosuchname"}} +test trace-17.3 {trace add command (command existence in ns)} { + list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg +} {1 {unknown command "nosuchns::nosuchname"}} + + +test trace-18.1 {trace add command (rename option)} { + proc foo {} {} + catch {rename bar {}} + trace add command foo rename traceCommand + rename foo bar + set info +} {foo bar rename} +test trace-18.2 {traces stick with renamed commands} { + proc foo {} {} + catch {rename bar {}} + trace add command foo rename traceCommand + rename foo bar + rename bar foo + set info +} {bar foo rename} +test trace-18.2.1 {trace add command rename trace exists} { + proc foo {} {} + trace add command foo rename traceCommand + trace list command foo +} {{rename traceCommand}} +test trace-18.3 {command rename traces don't fire on command deletion} { + proc foo {} {} + set info {} + trace add command foo rename traceCommand + rename foo {} + set info +} {} +test trace-18.4 {trace add command rename doesn't trace recreated commands} { + proc foo {} {} + catch {rename bar {}} + trace add command foo rename traceCommand + proc foo {} {} + rename foo bar + set info +} {} +test trace-18.5 {trace add command deleted removes traces} { + proc foo {} {} + trace add command foo rename traceCommand + proc foo {} {} + trace list command foo +} {} + +namespace eval tc {} +proc tc::tcfoo {} {} +test trace-18.6 {trace add command rename in namespace} { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tc::tcbar + set info +} {tc::tcfoo tc::tcbar rename} +test trace-18.7 {trace add command rename in namespace back again} { + rename tc::tcbar tc::tcfoo + set info +} {tc::tcbar tc::tcfoo rename} +test trace-18.8 {trace add command rename in namespace to out of namespace} { + rename tc::tcfoo tcbar + set info +} {tc::tcfoo tcbar rename} +test trace-18.9 {trace add command rename back into namespace} { + rename tcbar tc::tcfoo + set info +} {tcbar tc::tcfoo rename} +test trace-18.10 {trace add command failed rename doesn't trigger trace} { + set info {} + proc foo {} {} + proc bar {} {} + trace add command foo {rename delete} traceCommand + catch {rename foo bar} + set info +} {} +catch {rename foo {}} +catch {rename bar {}} + +# Make sure it exists again +proc foo {} {} + +test trace-19.1 {trace add command (delete option)} { + trace add command foo delete traceCommand + rename foo "" + set info +} {foo {} delete} +test trace-19.2 {trace add command delete doesn't trace recreated commands} { + set info {} + proc foo {} {} + rename foo "" + set info +} {} +test trace-19.2.1 {trace add command delete trace info} { + proc foo {} {} + trace add command foo delete traceCommand + trace list command foo +} {{delete traceCommand}} +test trace-19.3 {trace add command implicit delete} { + proc foo {} {} + trace add command foo delete traceCommand + proc foo {} {} + set info +} {foo {} delete} +test trace-19.3.1 {trace add command delete trace info} { + proc foo {} {} + trace list command foo +} {} +test trace-19.4 {trace add command rename followed by delete} { + set infotemp {} + proc foo {} {} + trace add command foo {rename delete} traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info +} {{foo bar rename} {bar {} delete}} +catch {rename foo {}} +catch {rename bar {}} + +test trace-19.5 {trace add command rename and delete} { + set infotemp {} + set info {} + proc foo {} {} + trace add command foo {rename delete} traceCommand + rename foo bar + lappend infotemp $info + rename bar {} + lappend infotemp $info + set info $infotemp + unset infotemp + set info +} {{foo bar rename} {bar {} delete}} + +test trace-19.6 {trace add command rename and delete in subinterp} { + set tc [interp create] + foreach p {traceCommand} { + $tc eval [list proc $p [info args $p] [info body $p]] + } + $tc eval [list set infotemp {}] + $tc eval [list set info {}] + $tc eval [list proc foo {} {}] + $tc eval [list trace add command foo {rename delete} traceCommand] + $tc eval [list rename foo bar] + $tc eval {lappend infotemp $info} + $tc eval [list rename bar {}] + $tc eval {lappend infotemp $info} + $tc eval {set info $infotemp} + $tc eval [list unset infotemp] + set info [$tc eval [list set info]] + interp delete $tc + set info +} {{foo bar rename} {bar {} delete}} + +# I'd like it if this test could give 'foo {} d' as a result, +# but interp deletion means there is no interp to evaluate +# the trace in. +test trace-19.7 {trace add command delete in subinterp while being deleted} { + set info {} + set tc [interp create] + interp alias $tc traceCommand {} traceCommand + $tc eval [list proc foo {} {}] + $tc eval [list trace add command foo {rename delete} traceCommand] + interp delete $tc + set info +} {} + +proc traceDelete {cmd old new op} { + eval trace remove command $cmd [lindex [trace list command $cmd] 0] + global info + set info [list $old $new $op] +} +proc traceCmdrename {cmd old new op} { + rename $old someothername +} +proc traceCmddelete {cmd old new op} { + rename $old "" +} +test trace-19.8 {trace delete while trace is active} { + set info {} + proc foo {} {} + catch {rename bar {}} + trace add command foo {rename delete} [list traceDelete foo] + rename foo bar + list [set info] [trace list command bar] +} {{foo bar rename} {}} + +test trace-19.9 {rename trace deletes command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo rename [list traceCmddelete foo] + rename foo bar + list [info commands foo] [info commands bar] [info commands someothername] +} {{} {} {}} + +test trace-19.10 {rename trace renames command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo rename [list traceCmdrename foo] + rename foo bar + set info [list [info commands foo] [info commands bar] [info commands someothername]] + rename someothername {} + set info +} {{} {} someothername} + +test trace-19.11 {delete trace deletes command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo delete [list traceCmddelete foo] + rename foo {} + list [info commands foo] [info commands bar] [info commands someothername] +} {{} {} {}} + +test trace-19.12 {delete trace renames command} { + set info {} + proc foo {} {} + catch {rename bar {}} + catch {rename someothername {}} + trace add command foo delete [list traceCmdrename foo] + rename foo bar + rename bar {} + # None of these should exist. + list [info commands foo] [info commands bar] [info commands someothername] +} {{} {} {}} + +proc foo {b} { set a $b } + + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} + +# Delete procedures when done, so we don't clash with other tests +# (e.g. foobar will clash with 'unknown' tests). +catch {rename foobar {}} +catch {rename foo {}} +catch {rename bar {}} + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} + + # cleanup ::tcltest::cleanupTests return |