diff options
| -rw-r--r-- | ChangeLog | 34 | ||||
| -rw-r--r-- | doc/CrtTrace.3 | 6 | ||||
| -rw-r--r-- | doc/trace.n | 127 | ||||
| -rw-r--r-- | generic/tcl.h | 10 | ||||
| -rw-r--r-- | generic/tclBasic.c | 197 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 775 | ||||
| -rw-r--r-- | generic/tclCompile.c | 3 | ||||
| -rw-r--r-- | generic/tclExecute.c | 13 | ||||
| -rw-r--r-- | generic/tclInt.decls | 14 | ||||
| -rw-r--r-- | generic/tclInt.h | 46 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 24 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | generic/tclVar.c | 64 | ||||
| -rw-r--r-- | tests/trace.test | 405 | ||||
| -rw-r--r-- | unix/mkLinks | 4 |
15 files changed, 1530 insertions, 196 deletions
@@ -1,5 +1,21 @@ +2002-06-17 Jeff Hobbs <jeffh@ActiveState.com> + + * doc/CrtTrace.3: Added TIP#62 implementation of command + * doc/trace.n: execution tracing [FR #462580] (lavana). + * generic/tcl.h: This includes enter/leave tracing as well + * generic/tclBasic.c: as inter-procedure stepping. + * generic/tclCmdMZ.c: + * generic/tclCompile.c: + * generic/tclExecute.c: + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclStubInit.c: + * generic/tclVar.c: + * tests/trace.test: + 2002-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net> - + * win/tclWinPipe.c (BuildCommandLine): Fixed bug #554068 ([exec] on windows did not treat { in filenames well.). Bug reported by Vince Darley <vincentdarley@users.sourceforge.net>, patch @@ -53,17 +69,11 @@ * generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole optimisation of variables (INST_STORE, INST_INCR) and commands (INST_INVOKE); faster check for the existence of a catch. - -2002-06-14 Miguel Sofer <msofer@users.sourceforge.net> - - * generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole - optimisation of comparisons. - -2002-06-14 Miguel Sofer <msofer@users.sourceforge.net> - - * generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole - optimisation of INST_FOREACH - relies on peculiarities of the code - produced by the bytecode compiler. + (TclExecuteByteCode): runtime peep-hole optimisation of + comparisons. + (TclExecuteByteCode): runtime peep-hole optimisation of + INST_FOREACH - relies on peculiarities of the code produced by the + bytecode compiler. 2002-06-14 David Gravereaux <davygrvy@pobox.com> diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 164ffad..a1c80e3 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: CrtTrace.3,v 1.4 2002/03/25 16:35:14 msofer Exp $ +'\" RCS: @(#) $Id: CrtTrace.3,v 1.5 2002/06/17 22:52:50 hobbs Exp $ '\" .so man.macros .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" @@ -29,10 +29,12 @@ Tcl_Trace .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. .AP int level in -Only commands at or below this nesting level will be traced. 1 means +Only commands at or below this nesting level will be traced unless +0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are invoked as immediate consequences of executing top-level commands (procedure bodies, bracketed commands, etc.) and so on. +A value of 0 means that commands at any level are traced. .AP int flags in Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in diff --git a/doc/trace.n b/doc/trace.n index 27ecb35..117ee6e 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -6,14 +6,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.9 2002/06/14 13:17:17 dkf Exp $ +'\" RCS: @(#) $Id: trace.n,v 1.10 2002/06/17 22:52:51 hobbs Exp $ '\" .so man.macros .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 and command usages +trace \- Monitor variable accesses, command usages and command executions .SH SYNOPSIS \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE @@ -24,7 +24,7 @@ This command causes Tcl commands to be executed whenever certain operations are invoked. The legal \fIoption\fR's (which may be abbreviated) are: .TP \fBtrace add \fItype name ops ?args?\fR -Where \fItype\fR is \fBcommand\fR, or \fBvariable\fR. +Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP \fBtrace add command\fR \fIname ops command\fR @@ -49,8 +49,9 @@ 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: +When the trace triggers, depending on the operations being traced, a +number of arguments are appended to \fIcommand\fR so that the actual +command is as follows: .CS \fIcommand oldName newName op\fR .CE @@ -58,7 +59,7 @@ When the trace triggers, three arguments are appended to (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 +command, 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 @@ -67,6 +68,101 @@ deletes the command, or a rename trace which itself renames the command will not cause further trace evaluations to occur. .RE .TP +\fBtrace add execution\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 +\fBenter\fR +Invoke \fIcommand\fR whenever the command \fIname\fR is executed, +just before the actual execution takes place. +.TP +\fBleave\fR +Invoke \fIcommand\fR whenever the command \fIname\fR is executed, +just after the actual execution takes place. +.TP +\fBenterstep\fR +Invoke \fIcommand\fR for every tcl command which is executed +inside the procedure \fIname\fR, just before the actual execution +takes place. For example if we have 'proc foo {} { puts "hello" }', +then a \fIenterstep\fR trace would be +invoked just before \fIputs "hello"\fR is executed. +Setting a \fIenterstep\fR trace on a \fIcommand\fR +will not result in an error and is simply ignored. +.TP +\fBleavestep\fR +Invoke \fIcommand\fR for every tcl command which is executed +inside the procedure \fIname\fR, just after the actual execution +takes place. +Setting a \fIleavestep\fR trace on a \fIcommand\fR +will not result in an error and is simply ignored. +.PP +When the trace triggers, depending on the operations being traced, a +number of arguments are appended to \fIcommand\fR so that the actual +command is as follows: + +For \fBenter\fR and \fBenterstep\fR operations: +.CS +\fIcommand command-string op\fR +.CE +\fICommand-string\fR gives the complete current command being +executed (the traced command for a \fBenter\fR operation, an +arbitrary command for a \fBenterstep\fR operation), including +all arguments in their fully expanded form. +\fIOp\fR indicates what operation is being performed on the +command execution, and is one of \fBenter\fR or \fBenterstep\fR as +defined above. The trace operation can be used to stop the +command from executing, by deleting the command in question. Of +course when the command is subsequently executed, an 'invalid command' +error will occur. +.TP +For \fBleave\fR and \fBleavestep\fR operations: +.CS +\fIcommand command-string code result op\fR +.CE +\fICommand-string\fR gives the complete current command being +executed (the traced command for a \fBenter\fR operation, an +arbitrary command for a \fBenterstep\fR operation), including +all arguments in their fully expanded form. +\fICode\fR gives the result code of that execution, and \fIresult\fR +the result string. +\fIOp\fR indicates what operation is being performed on the +command execution, and is one of \fBleave\fR or \fBleavestep\fR as +defined above. +Note that the creation of many \fBenterstep\fR or +\fBleavestep\fR traces can lead to unintuitive results, since the +invoked commands from one trace can themselves lead to further +command invocations for other traces. + +\fICommand\fR executes in the same context as the code that invoked +the traced operation: thus the \fIcommand\fR, if invoked from a procedure, +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 upvar or uplevel commands if it wishes +to access the local variables of the code which invoked the trace operation. + +While \fIcommand\fR is executing during an execution trace, traces +on \fIname\fR are temporarily disabled. This allows the \fIcommand\fR +to execute \fIname\fR in its body without invoking any other traces again. +If an error occurs while executing the \fIcommand\fR body, then the +\fIcommand\fR name as a whole will return that same error. + +When multiple traces are set on \fIname\fR, then for \fIenter\fR +and \fIenterstep\fR operations, the traced commands are invoked +in the reverse order of how the traces were originally created; +and for \fIleave\fR and \fIleavestep\fR operations, the traced +commands are invoked in the original order of creation. + +The behavior of execution traces is currently undefined for a command +\fIname\fR imported into another namespace. +.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 the list \fIops\fR. \fIName\fR may @@ -183,7 +279,7 @@ 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. +Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace remove command\fI name opList command\fR @@ -193,6 +289,13 @@ 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 execution\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 @@ -201,7 +304,7 @@ an empty string. .RE .TP \fBtrace info \fItype name\fR -Where \fItype\fR is either \fBcommand\fR or \fBvariable\fR. +Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace info command\fI name\fR @@ -212,6 +315,14 @@ 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 info execution\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 info 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 diff --git a/generic/tcl.h b/generic/tcl.h index 2376e04..85e63c1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -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: tcl.h,v 1.126 2002/06/17 18:31:26 jenglish Exp $ + * RCS: @(#) $Id: tcl.h,v 1.127 2002/06/17 22:52:51 hobbs Exp $ */ #ifndef _TCL @@ -1028,6 +1028,14 @@ typedef struct Tcl_DString { #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* + * Flag values passed to Tcl_CreateObjTrace, and used internally + * by command execution traces. Slots 4,8,16 and 32 are + * used internally by execution traces (see tclCmdMZ.c) + */ +#define TCL_TRACE_ENTER_EXEC 1 +#define TCL_TRACE_LEAVE_EXEC 2 + +/* * The TCL_PARSE_PART1 flag is deprecated and has no effect. * The part1 is now always parsed whenever the part2 is NULL. * (This is to avoid a common error when converting code to diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 67456a2..32ff2d6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.59 2002/06/12 19:36:14 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.60 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -334,7 +334,7 @@ Tcl_CreateInterp() iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; - iPtr->activeTracePtr = NULL; + iPtr->activeVarTracePtr = NULL; iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; @@ -357,6 +357,7 @@ Tcl_CreateInterp() iPtr->tracePtr = NULL; iPtr->tracesForbiddingInline = 0; iPtr->activeCmdTracePtr = NULL; + iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ @@ -2501,15 +2502,15 @@ Tcl_DeleteCommandFromToken(interp, cmd) } static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) - Interp *iPtr; /* Interpreter containing variable. */ - Command *cmdPtr; /* Variable whose traces are to be + Interp *iPtr; /* Interpreter containing command. */ + Command *cmdPtr; /* Command whose traces are to be * invoked. */ CONST char *oldName; /* Command's old name, or NULL if we * must get the name from cmdPtr */ CONST 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, + * indicates what's happening to command, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ @@ -2540,6 +2541,9 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) active.nextPtr = iPtr->activeCmdTracePtr; iPtr->activeCmdTracePtr = &active; + if (flags & TCL_TRACE_DELETE) { + flags |= TCL_TRACE_DESTROYED; + } active.cmdPtr = cmdPtr; Tcl_Preserve((ClientData) iPtr); for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; @@ -2916,113 +2920,91 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) Interp *iPtr = (Interp *) interp; Tcl_Obj **newObjv; int i; - Trace *tracePtr, *nextPtr; - char *commandCopy; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ int code = TCL_OK; + int traceCode = TCL_OK; + int checkTraces = 1; if (objc == 0) { return TCL_OK; } /* - * Find the procedure to execute this command. If there isn't one, - * then see if there is a command "unknown". If so, create a new - * word array with "unknown" as the first word and the original - * command words as arguments. Then call ourselves recursively - * to execute it. + * If any execution traces rename or delete the current command, + * we may need (at most) two passes here. */ + while (1) { - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) + /* + * Find the procedure to execute this command. If there isn't one, + * then see if there is a command "unknown". If so, create a new + * word array with "unknown" as the first word and the original + * command words as arguments. Then call ourselves recursively + * to execute it. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) ckalloc((unsigned) ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("::unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid command name \"", Tcl_GetString(objv[0]), "\"", (char *) NULL); - code = TCL_ERROR; - } else if (TclInterpReady(interp) == TCL_ERROR) { - code = TCL_ERROR; - } else { - iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); - iPtr->numLevels--; - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - goto done; - } - - /* - * Call trace procedures if needed. - */ - - if ( command != NULL && iPtr->tracePtr != NULL ) { - commandCopy = command; - - /* - * Make a copy of the command if necessary, so that trace - * procs will see it. - */ - - if (length < 0) { - length = strlen(command); - } else if ((size_t)length < strlen(command)) { - commandCopy = (char *) ckalloc((unsigned) (length + 1)); - strncpy(commandCopy, command, (size_t) length); - commandCopy[length] = 0; - } - - /* - * Walk through the trace procs - */ - - for ( tracePtr = iPtr->tracePtr; - (code == TCL_OK) && (tracePtr != NULL); - tracePtr = nextPtr) { - nextPtr = tracePtr->nextPtr; - if (iPtr->numLevels > tracePtr->level) { - continue; + code = TCL_ERROR; + } else if (TclInterpReady(interp) == TCL_ERROR) { + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); + iPtr->numLevels--; } - - /* - * Invoke one trace proc - */ - - code = (tracePtr->proc)( tracePtr->clientData, - (Tcl_Interp*) iPtr, - iPtr->numLevels, - commandCopy, - (Tcl_Command) cmdPtr, - objc, - objv ); - } - - /* - * If we had to copy the command for the trace procs, free the - * copy. - */ - - if (commandCopy != command) { - ckfree((char *) commandCopy); - } - - } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + /* + * Call trace procedures if needed. + */ + if ((checkTraces) && (command != NULL)) { + int cmdEpoch = cmdPtr->cmdEpoch; + cmdPtr->refCount++; + /* If the first set of traces modifies/deletes the command or + * any existing traces, then the set checkTraces to 0 and + * go through this while loop one more time. + */ + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES && traceCode == TCL_OK) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + cmdPtr->refCount--; + if (cmdEpoch != cmdPtr->cmdEpoch) { + /* The command has been modified in some way */ + checkTraces = 0; + continue; + } + } + break; + } + /* * Finally, invoke the command's Tcl_ObjCmdProc. */ iPtr->cmdCount++; - if ( code == TCL_OK ) { + if ( code == TCL_OK && traceCode == TCL_OK) { savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; @@ -3035,6 +3017,29 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) } /* + * Call 'leave' command traces + */ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES && traceCode == TCL_OK) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + + /* + * If one of the trace invocation resulted in error, then + * change the result code accordingly. Note, that the + * interp->result should already be set correctly by the + * call to TraceExecutionProc. + */ + + if (traceCode != TCL_OK) { + code = traceCode; + } + + /* * If the interpreter has a non-empty string result, the result * object is either empty or stale because some procedure set * interp->result directly. If so, move the string result to the @@ -3095,8 +3100,7 @@ Tcl_EvalObjv(interp, objc, objv, flags) int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { - if (iPtr->numLevels <= tracePtr->level) { - + if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { /* * The command may be needed for an execution trace. Generate a * command string. @@ -4841,7 +4845,6 @@ Tcl_CreateTrace(interp, level, proc, clientData) * command. */ ClientData clientData; /* Arbitrary value word to pass to proc. */ { - StringTraceData* data; data = (StringTraceData*) ckalloc( sizeof( *data )); data->clientData = clientData; @@ -4901,15 +4904,13 @@ StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) * on two parameters for compatibility with legacy code; the code * MUST NOT modify either command or argv. */ - + ( data->proc )( data->clientData, interp, level, (char*) command, cmdPtr->proc, cmdPtr->clientData, objc, (char**) argv ); - ckfree( (char*) argv ); return TCL_OK; - } /* @@ -4974,7 +4975,7 @@ Tcl_DeleteTrace(interp, trace) return; } (*tracePtr2) = (*tracePtr2)->nextPtr; - + /* * If the trace forbids bytecode compilation, change the interpreter's * state. If bytecode compilation is now permitted, flag the fact and diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cf30805..59346b4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.71 2002/06/14 13:17:17 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.72 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -37,10 +37,49 @@ typedef struct { } TraceVarInfo; /* - * The same structure is used for command traces at present + * Structure used to hold information about command traces: */ -typedef TraceVarInfo TraceCommandInfo; +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + size_t length; /* Number of non-NULL chars. in command. */ + Tcl_Trace stepTrace; /* Used for execution traces, when tracing + * inside the given command */ + int startLevel; /* Used for bookkeeping with execution traces */ + int curFlags; /* Trace flags for the current command */ + int curCode; /* Return code for the current command */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to + * hold command. This field must be the + * last in the structure, so that it can + * be larger than 4 bytes. */ +} TraceCommandInfo; + +/* + * Used by command execution traces. Note that we assume in the code + * that the first two defines are exactly 4 times the + * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. + * + * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command + * currently being traced, before execution. + * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command + * currently being traced, after execution. + * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. + * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace + * is currently executing. Therefore we + * don't let further traces execute. + * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly + * by the command being traced, not because + * of an internal trace. + * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also + * be used in command execution traces. + */ +#define TCL_TRACE_ENTER_DURING_EXEC 4 +#define TCL_TRACE_LEAVE_DURING_EXEC 8 +#define TCL_TRACE_ANY_EXEC 15 +#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 +#define TCL_TRACE_EXEC_DIRECT 0x20 /* * Forward declarations for procedures defined in this file: @@ -51,29 +90,38 @@ typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; +Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; /* * 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! + * Currently 'execution', 'command' and 'variable' are the only + * types supported. These three arrays MUST be kept in sync! * In the future we may provide an API to add to the list of * supported trace types. */ static CONST char *traceTypeOptions[] = { - "command", "variable", (char*) NULL + "execution", "command", "variable", (char*) NULL }; static Tcl_TraceTypeObjCmd* traceSubCmds[] = { + TclTraceExecutionObjCmd, TclTraceCommandObjCmd, TclTraceVariableObjCmd, }; +/* + * Declarations for local procedures to this file: + */ +static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + char *command, int numChars, + int objc, Tcl_Obj *CONST objv[])); static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, CONST char *name2, int flags)); static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *oldName, CONST char *newName, int flags)); - +static Tcl_CmdObjTraceProc TraceExecutionProc; /* *---------------------------------------------------------------------- @@ -2976,7 +3024,7 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - ckfree((char *) tvarPtr); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } @@ -3049,6 +3097,215 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * TclTraceExecutionObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|info} execution ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or info) being performed; + * may add or remove command traces on a command. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, info or remove */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int commandLength, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + static CONST char *opStrings[] = { "enter", "leave", + "enterstep", "leavestep", (char *) NULL }; + enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, + TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; + + 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 execution"); + 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 enter, leave, enterstep, or leavestep", 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_EXEC_ENTER: + flags |= TCL_TRACE_ENTER_EXEC; + break; + case TRACE_EXEC_LEAVE: + flags |= TCL_TRACE_LEAVE_EXEC; + break; + case TRACE_EXEC_ENTER_STEP: + flags |= TCL_TRACE_ENTER_DURING_EXEC; + break; + case TRACE_EXEC_LEAVE_STEP: + flags |= TCL_TRACE_LEAVE_DURING_EXEC; + 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->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->length = length; + flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + 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; + /* + * In checking the 'flags' field we must remove any extraneous + * flags which may have been temporarily added by various pieces + * of the trace mechanism. + */ + if ((tcmdPtr->length == length) + && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | + TCL_TRACE_DELETE)) == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + Tcl_UntraceCommand(interp, name, + flags, TraceCommandProc, clientData); + if (tcmdPtr->stepTrace != NULL) { + /* + * We need to remove the interpreter-wide trace + * which we created to allow 'step' traces. + */ + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + /* Postpone deletion */ + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + tcmdPtr->flags = 0; + } else { + Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + 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_ENTER_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enter",6)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leave",5)); + } + if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enterstep",9)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leavestep",10)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * * TclTraceCommandObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the @@ -3330,7 +3587,7 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - ckfree((char *) tvarPtr); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } @@ -3470,6 +3727,9 @@ Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) * * Arrange for rename/deletes to a command to cause a * procedure to be invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command + * to cause a procedure to be invoked. * * Results: * A standard Tcl return value. @@ -3489,7 +3749,8 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) * to be traced. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ @@ -3510,9 +3771,13 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; - tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE); + tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE + | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; cmdPtr->tracePtr = tracePtr; + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + cmdPtr->flags |= CMD_HAS_EXEC_TRACES; + } return TCL_OK; } @@ -3539,7 +3804,8 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing command. */ CONST char *cmdName; /* Name of command. */ int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { @@ -3548,29 +3814,34 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) Command *cmdPtr; Interp *iPtr = (Interp *) interp; ActiveCommandTrace *activePtr; - + int hasExecTraces = 0; + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL) { return; } - flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE); + flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } - if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags) && (tracePtr->clientData == clientData)) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + hasExecTraces = 1; + } break; } } - + /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be - * processed by CallTraces. + * processed by CallCommandTraces. */ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; @@ -3584,7 +3855,22 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) } else { prevPtr->nextPtr = tracePtr->nextPtr; } - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + tracePtr->flags = 0; + Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC); + + if (hasExecTraces) { + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + return; + } + } + /* + * None of the remaining traces on this command are execution + * traces. We therefore remove this flag: + */ + cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; + } } /* @@ -3593,7 +3879,8 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) * TraceCommandProc -- * * This procedure is called to handle command changes that have - * been traced using the "trace" command. + * been traced using the "trace" command, when using the + * 'rename' or 'delete' options. * * Results: * None. @@ -3620,7 +3907,9 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; int code; Tcl_DString cmd; - + + Tcl_Preserve((ClientData) tcmdPtr); + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements @@ -3666,14 +3955,445 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) * because command deletes are unconditional, so the trace must go away. */ if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { - ckfree((char *) tcmdPtr); + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + /* Postpone deletion, until exec trace returns */ + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + tcmdPtr->flags = 0; + } else { + Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } } + Tcl_Release((ClientData) tcmdPtr); return; } /* *---------------------------------------------------------------------- * + * TclCheckExecutionTraces -- + * + * Checks on all current command execution traces, and invokes + * procedures which have been registered. This procedure can be + * used by other code which performs execution to unify the + * tracing system, so that execution traces will function for that + * other code. + * + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is called by 'TclEvalObjvInternal' + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ +int +TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + char *command; /* Pointer to beginning of the current + * command string. */ + int numChars; /* The number of characters in 'command' + * which are part of the command string. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int code; /* The current result code. */ + int traceFlags; /* Current tracing situation. */ + int objc; /* Number of arguments for the command. */ + Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + CommandTrace *tracePtr, *lastTracePtr; + ActiveCommandTrace active; + int curLevel; + int traceCode = TCL_OK; + TraceCommandInfo* tcmdPtr; + + if (command == NULL || cmdPtr->tracePtr == NULL) { + return(traceCode); + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + active.cmdPtr = cmdPtr; + lastTracePtr = NULL; + for ( tracePtr = cmdPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_LEAVE_EXEC) { + /* execute the trace command in order of creation for "leave" */ + active.nextTracePtr = NULL; + tracePtr = cmdPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.nextTracePtr = tracePtr->nextPtr; + } + tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + if (tcmdPtr->flags != 0) { + tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; + tcmdPtr->curCode = code; + traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, + curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + } + lastTracePtr = tracePtr; + } + iPtr->activeCmdTracePtr = active.nextPtr; + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckInterpTraces -- + * + * Checks on all current traces, and invokes procedures which + * have been registered. This procedure can be used by other + * code which performs execution to unify the tracing system. + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is called by 'TclEvalObjvInternal' + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ +int +TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + char *command; /* Pointer to beginning of the current + * command string. */ + int numChars; /* The number of characters in 'command' + * which are part of the command string. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int code; /* The current result code. */ + int traceFlags; /* Current tracing situation. */ + int objc; /* Number of arguments for the command. */ + Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + Trace *tracePtr, *lastTracePtr; + ActiveInterpTrace active; + int curLevel; + int traceCode = TCL_OK; + TraceCommandInfo* tcmdPtr; + + if (command == NULL || iPtr->tracePtr == NULL || + (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + return(traceCode); + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeInterpTracePtr; + iPtr->activeInterpTracePtr = &active; + + lastTracePtr = NULL; + for ( tracePtr = iPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_ENTER_EXEC) { + /* execute the trace command in reverse order of creation + * for "enterstep" operation. The order is changed for + * ""enterstep" instead of for "leavestep as was done in + * TclCheckExecutionTraces because for step traces, + * Tcl_CreateObjTrace creates one more linked list of traces + * which results in one more reversal of trace invocation. + */ + active.nextTracePtr = NULL; + tracePtr = iPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.nextTracePtr = tracePtr->nextPtr; + } + if (tracePtr->level > 0 && curLevel > tracePtr->level) { + continue; + } + if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { + tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) && + ((tracePtr->flags & traceFlags) != 0)) { + tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; + tcmdPtr->curCode = code; + traceCode = (tracePtr->proc)((ClientData)tcmdPtr, + (Tcl_Interp*)interp, + curLevel, command, + (Tcl_Command)cmdPtr, + objc, objv); + } else { + if (traceFlags & TCL_TRACE_ENTER_EXEC) { + /* + * Old-style interpreter-wide traces only trigger + * before the command is executed. + */ + traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); + } + } + tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + } + lastTracePtr = tracePtr; + } + iPtr->activeInterpTracePtr = active.nextPtr; + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * CallTraceProcedure -- + * + * Invokes a trace procedure registered with an interpreter. These + * procedures trace command execution. Currently this trace procedure + * is called with the address of the string-based Tcl_CmdProc for the + * command, not the Tcl_ObjCmdProc. + * + * Results: + * None. + * + * Side effects: + * Those side effects made by the trace procedure. + * + *---------------------------------------------------------------------- + */ + +static int +CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + register Trace *tracePtr; /* Describes the trace procedure to call. */ + Command *cmdPtr; /* Points to command's Command struct. */ + char *command; /* Points to the first character of the + * command's source before substitutions. */ + int numChars; /* The number of characters in the + * command's source. */ + register int objc; /* Number of arguments for the command. */ + Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + char *commandCopy; + int traceCode; + + /* + * Copy the command characters into a new string. + */ + + commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); + commandCopy[numChars] = '\0'; + + /* + * Call the trace procedure then free allocated storage. + */ + + traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, + iPtr->numLevels, commandCopy, + (Tcl_Command) cmdPtr, objc, objv ); + + ckfree((char *) commandCopy); + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * TraceExecutionProc -- + * + * This procedure is invoked whenever code relevant to a + * 'trace execution' command is executed. It is called in one + * of two ways in Tcl's core: + * + * (i) by the TclCheckExecutionTraces, when an execution trace has been + * triggered. + * (ii) by TclCheckInterpTraces, when a prior execution trace has + * created a trace of the internals of a procedure, passing in + * this procedure as the one to be called. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * May invoke an arbitrary Tcl procedure, and may create or + * delete an interpreter-wide trace. + * + *---------------------------------------------------------------------- + */ +int +TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, + int level, CONST char* command, Tcl_Command cmdInfo, + int objc, struct Tcl_Obj *CONST objv[]) { + int call = 0; + Interp *iPtr = (Interp *) interp; + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + int flags = tcmdPtr->curFlags; + int code = tcmdPtr->curCode; + int traceCode = TCL_OK; + + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* + * Inside any kind of execution trace callback, we do + * not allow any further execution trace callbacks to + * be called for the same trace. + */ + return(traceCode); + } + + if (!(flags & TCL_INTERP_DESTROYED)) { + /* + * Check whether the current call is going to eval arbitrary + * Tcl code with a generated trace, or whether we are only + * going to setup interpreter-wide traces to implement the + * 'step' traces. This latter situation can happen if + * we create a command trace without either before or after + * operations, but with either of the step operations. + */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } else { + call = 1; + } + /* + * First, if we have returned back to the level at which we + * created an interpreter trace, we remove it + */ + if (flags & TCL_TRACE_LEAVE_EXEC) { + if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + + } + + /* + * Second, create the tcl callback, if required. + */ + if (call) { + Tcl_SavedResult state; + Tcl_DString cmd; + Tcl_DString sub; + int i; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + /* Append command with arguments */ + Tcl_DStringInit(&sub); + for (i = 0; i < objc; i++) { + char* str; + int len; + str = Tcl_GetStringFromObj(objv[i],&len); + Tcl_DStringAppendElement(&sub, str); + } + Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); + Tcl_DStringFree(&sub); + + if (flags & TCL_TRACE_ENTER_EXEC) { + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "enter"); + } else { + Tcl_DStringAppendElement(&cmd, "enterstep"); + } + } else if (flags & TCL_TRACE_LEAVE_EXEC) { + Tcl_Obj* resultCode; + char* resultCodeStr; + + /* Append result code */ + resultCode = Tcl_NewIntObj(code); + resultCodeStr = Tcl_GetString(resultCode); + Tcl_DStringAppendElement(&cmd, resultCodeStr); + Tcl_DecrRefCount(resultCode); + + /* Append result string */ + Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "leave"); + } else { + Tcl_DStringAppendElement(&cmd, "leavestep"); + } + } else { + panic("TraceExecutionProc: bad flag combination"); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + Tcl_Preserve((ClientData)tcmdPtr); + /* + * This line can have quite arbitrary side-effects, + * including deleting the trace, the command being + * traced, or even the interpreter. + */ + traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + if (tcmdPtr->flags == 0) { + flags |= TCL_TRACE_DESTROYED; + } + + if (traceCode == TCL_OK) { + /* Restore result if trace execution was successful */ + Tcl_RestoreResult(interp, &state); + } + + Tcl_DStringFree(&cmd); + } + + /* + * Third, create an interpreter trace, if we need one for + * subsequent internal execution traces. + */ + if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) + && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { + tcmdPtr->startLevel = level; + tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, (ClientData)tcmdPtr, NULL); + } + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC); + } + if (call) { + Tcl_Release((ClientData)tcmdPtr); + } + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * * TraceVarProc -- * * This procedure is called to handle variable accesses that have @@ -3706,6 +4426,16 @@ TraceVarProc(clientData, interp, name1, name2, flags) int code; Tcl_DString cmd; + /* + * We might call Tcl_Eval() below, and that might evaluate + * [trace vdelete] which might try to free tvarPtr. We want + * to use tvarPtr until the end of this function, so we use + * Tcl_Preserve() and Tcl_Release() to be sure it is not + * freed while we still need it. + */ + + Tcl_Preserve((ClientData) tvarPtr); + result = NULL; if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { if (tvarPtr->length != (size_t) 0) { @@ -3778,8 +4508,9 @@ TraceVarProc(clientData, interp, name1, name2, flags) Tcl_DecrRefCount(errMsgObj); result = NULL; } - ckfree((char *) tvarPtr); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); } + Tcl_Release((ClientData) tvarPtr); return result; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6034cf5..83ff215 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -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: tclCompile.c,v 1.36 2002/06/17 00:09:19 msofer Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.37 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -946,6 +946,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { code = (*(cmdPtr->compileProc))(interp, &parse, envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b1893f2..f5949af 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -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: tclExecute.c,v 1.69 2002/06/16 17:59:12 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.70 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -1240,7 +1240,8 @@ TclExecuteByteCode(interp, codePtr) for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextTracePtr) { nextTracePtr = tracePtr->nextPtr; - if (iPtr->numLevels <= tracePtr->level) { + if (tracePtr->level == 0 || + iPtr->numLevels <= tracePtr->level) { /* * Traces will be called: get command string */ @@ -1249,7 +1250,13 @@ TclExecuteByteCode(interp, codePtr) break; } } - } + } else { + Command *cmdPtr; + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (cmdPtr != NULL && cmdPtr->flags & CMD_HAS_EXEC_TRACES) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + } + } /* * A reference to part of the stack vector itself diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 094b9df..973a7bd 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.50 2002/05/29 09:09:57 hobbs Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.51 2002/06/17 22:52:51 hobbs Exp $ library tcl @@ -665,12 +665,20 @@ declare 167 generic { declare 168 generic { Tcl_Obj *TclGetStartupScriptPath(void) } - # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 generic { int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n) } - +declare 170 generic { + int TclCheckInterpTraces (Tcl_Interp *interp, char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) +} +declare 171 generic { + int TclCheckExecutionTraces (Tcl_Interp *interp, char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 920d946..d16d02c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.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: tclInt.h,v 1.94 2002/06/13 09:40:00 vincentdarley Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.95 2002/06/17 22:52:51 hobbs Exp $ */ #ifndef _TCLINT @@ -289,10 +289,18 @@ typedef struct CommandTrace { * a particular command. */ } CommandTrace; +/* + * When a command trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the command's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + typedef struct ActiveCommandTrace { - struct Command *cmdPtr; /* Variable that's being traced. */ + struct Command *cmdPtr; /* Command that's being traced. */ struct ActiveCommandTrace *nextPtr; - /* Next in list of all active variable + /* Next in list of all active command * traces for the interpreter, or NULL * if no more. */ CommandTrace *nextTracePtr; /* Next trace to check after current @@ -656,6 +664,25 @@ typedef struct Trace { } Trace; /* + * When an interpreter trace is active (i.e. its associated procedure + * is executing), one of the following structures is linked into a list + * associated with the interpreter. The information in the structure + * is needed in order for Tcl to behave reasonably if traces are + * deleted while traces are active. + */ + +typedef struct ActiveInterpTrace { + struct ActiveInterpTrace *nextPtr; + /* Next in list of all active command + * traces for the interpreter, or NULL + * if no more. */ + Trace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveInterpTrace; + +/* * The structure below defines an entry in the assocData hash table which * is associated with an interpreter. The entry contains a pointer to a * function to call when the interpreter is deleted, and a pointer to @@ -1080,6 +1107,9 @@ typedef struct Command { * underway for a rename/delete change. * See the two flags below for which is * currently being processed. + * CMD_HAS_EXEC_TRACES - 1 means that this command has at least + * one execution trace (as opposed to simple + * delete/rename traces) in its tracePtr list. * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further @@ -1088,6 +1118,7 @@ typedef struct Command { */ #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 +#define CMD_HAS_EXEC_TRACES 0x4 /* *---------------------------------------------------------------- @@ -1209,7 +1240,7 @@ typedef struct Interp { * unless an "uplevel" command is * executing). NULL means no procedure is * active or "uplevel 0" is executing. */ - ActiveVarTrace *activeTracePtr; + ActiveVarTrace *activeVarTracePtr; /* First in list of active traces for * interp, or NULL if no active traces. */ int returnCode; /* Completion code to return if current @@ -1305,6 +1336,9 @@ typedef struct Interp { ActiveCommandTrace *activeCmdTracePtr; /* First in list of active command traces for * interp, or NULL if no active traces. */ + ActiveInterpTrace *activeInterpTracePtr; + /* First in list of active traces for + * interp, or NULL if no active traces. */ int tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode @@ -1367,6 +1401,9 @@ typedef struct Interp { * interpreter; instead, have Tcl_EvalObj call * Tcl_EvalEx. Used primarily for testing the * new parser. + * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently + * active; so no further trace callbacks should be + * invoked. */ #define DELETED 1 @@ -1378,6 +1415,7 @@ typedef struct Interp { #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 +#define INTERP_TRACE_IN_PROGRESS 0x200 /* *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index db179b9..a03d113 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.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: tclIntDecls.h,v 1.41 2002/05/29 09:09:57 hobbs Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.42 2002/06/17 22:52:51 hobbs Exp $ */ #ifndef _TCLINTDECLS @@ -506,6 +506,18 @@ EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void)); /* 169 */ EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); +/* 170 */ +EXTERN int TclCheckInterpTraces _ANSI_ARGS_(( + Tcl_Interp * interp, char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); +/* 171 */ +EXTERN int TclCheckExecutionTraces _ANSI_ARGS_(( + Tcl_Interp * interp, char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); typedef struct TclIntStubs { int magic; @@ -713,6 +725,8 @@ typedef struct TclIntStubs { void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */ + int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */ + int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ } TclIntStubs; #ifdef __cplusplus @@ -1333,6 +1347,14 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #endif +#ifndef TclCheckInterpTraces +#define TclCheckInterpTraces \ + (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ +#endif +#ifndef TclCheckExecutionTraces +#define TclCheckExecutionTraces \ + (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 90f51ba..ef55072 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.71 2002/05/29 09:09:57 hobbs Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.72 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -249,6 +249,8 @@ TclIntStubs tclIntStubs = { TclSetStartupScriptPath, /* 167 */ TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ + TclCheckInterpTraces, /* 170 */ + TclCheckExecutionTraces, /* 171 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclVar.c b/generic/tclVar.c index 133b387..4a60c5e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,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.52 2002/06/13 19:47:58 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.53 2002/06/17 22:52:51 hobbs Exp $ */ #include "tclInt.h" @@ -40,7 +40,7 @@ static char *isArrayElement = "name refers to an element in an array"; * Forward references to procedures defined later in this file: */ -static int CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, +static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, Var *varPtr, char *part1, CONST char *part2, int flags, int leaveErrMsg)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, @@ -636,7 +636,7 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; @@ -757,7 +757,7 @@ TclGetIndexedScalar(interp, localIndex, flags) */ if (varPtr->tracePtr != NULL) { - if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { return NULL; } @@ -910,7 +910,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } @@ -1249,7 +1249,7 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { return NULL; } @@ -1328,7 +1328,7 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; @@ -1459,7 +1459,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) */ if ((flags & TCL_TRACE_READS) && (varPtr->tracePtr != NULL)) { - if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { return NULL; } @@ -1559,7 +1559,7 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) */ if (varPtr->tracePtr != NULL) { - if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, + if (TCL_ERROR == CallVarTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; } @@ -1760,7 +1760,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } @@ -1831,7 +1831,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, arrayName, elem, TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } @@ -2287,7 +2287,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) * Call trace procedures for the variable being deleted. Then delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: - * 1. We need to increment varPtr's refCount around this: CallTraces + * 1. We need to increment varPtr's refCount around this: CallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. @@ -2297,7 +2297,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; - CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); while (dummyVar.tracePtr != NULL) { @@ -2305,7 +2305,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) dummyVar.tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -2610,10 +2610,10 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) /* * 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. + * processed by CallVarTraces. */ - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; @@ -3120,7 +3120,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (varPtr != NULL && varPtr->tracePtr != NULL && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) { return TCL_ERROR; @@ -3141,7 +3141,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* * We have to wait to get the resultPtr until here because - * CallTraces can affect the result. + * CallVarTraces can affect the result. */ resultPtr = Tcl_GetObjResult(interp); @@ -4407,7 +4407,7 @@ DisposeTraceResult(flags, result) /* *---------------------------------------------------------------------- * - * CallTraces -- + * CallVarTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on @@ -4429,7 +4429,7 @@ DisposeTraceResult(flags, result) */ int -CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) +CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable @@ -4506,8 +4506,8 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) */ result = NULL; - active.nextPtr = iPtr->activeTracePtr; - iPtr->activeTracePtr = &active; + active.nextPtr = iPtr->activeVarTracePtr; + iPtr->activeVarTracePtr = &active; Tcl_Preserve((ClientData) iPtr); if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) { active.varPtr = arrayPtr; @@ -4609,7 +4609,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) } varPtr->flags &= ~VAR_TRACE_ACTIVE; varPtr->refCount--; - iPtr->activeTracePtr = active.nextPtr; + iPtr->activeVarTracePtr = active.nextPtr; Tcl_Release((ClientData) iPtr); return code; } @@ -4909,7 +4909,7 @@ TclDeleteVars(iPtr, tablePtr) * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole - * table is deleted). Note that we give CallTraces the variable's + * table is deleted). Note that we give CallVarTraces the variable's * fully-qualified name so that any called trace procedures can * refer to these variables being deleted. */ @@ -4918,7 +4918,7 @@ TclDeleteVars(iPtr, tablePtr) objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - CallTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), + CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), NULL, flags, /* leaveErrMsg */ 0); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ @@ -4927,7 +4927,7 @@ TclDeleteVars(iPtr, tablePtr) varPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -5044,14 +5044,14 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) */ if (varPtr->tracePtr != NULL) { - CallTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL, + CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL, flags, /* leaveErrMsg */ 0); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -5108,7 +5108,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ - int flags; /* Flags to pass to CallTraces: + int flags; /* Flags to pass to CallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or @@ -5132,7 +5132,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; - CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, + CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, /* leaveErrMsg */ 0); while (elPtr->tracePtr != NULL) { @@ -5140,7 +5140,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) elPtr->tracePtr = tracePtr->nextPtr; Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; @@ -5289,7 +5289,7 @@ TclVarTraceExists(interp, varName) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - CallTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, + CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, TCL_TRACE_READS, /* leaveErrMsg */ 0); } diff --git a/tests/trace.test b/tests/trace.test index bc67464..7f7213b 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.18 2002/06/14 13:17:17 dkf Exp $ +# RCS: @(#) $Id: trace.test,v 1.19 2002/06/17 22:52:51 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -791,9 +791,10 @@ test trace-14.5 {trace command, invalid option} { # 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 { +set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"] +set abbvs [list {a r u w} {d r} {}] +proc x {} {} +foreach type {variable command execution} err $errs abbvlist $abbvs { foreach op {add remove} { test trace-14.6.[incr i] "trace $op $type errors" { list [catch {trace $op $type x {y z w} a} msg] $msg @@ -808,6 +809,7 @@ foreach type {variable command} err $errs abbvlist $abbvs { } [list 1 "bad operation list \"\": must be one or more of $err"] } } +rename x {} test trace-14.7 {trace command, "trace variable" errors} { list [catch {trace variable} msg] $msg @@ -1415,12 +1417,399 @@ catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} -# Delete arrays when done, so they can be re-used as scalars -# elsewhere. +proc foo {a} { + set b $a +} -catch {unset x} -catch {unset y} +proc traceExecute {args} { + global info + lappend info $args +} + +test trace-21.1 {trace execution: enter} { + set info {} + trace add execution foo enter [list traceExecute foo] + foo 1 + trace remove execution foo enter [list traceExecute foo] + set info +} {{foo {foo 1} enter}} + +test trace-21.2 {trace exeuction: leave} { + set info {} + trace add execution foo leave [list traceExecute foo] + foo 2 + trace remove execution foo leave [list traceExecute foo] + set info +} {{foo {foo 2} 0 2 leave}} + +test trace-21.3 {trace exeuction: enter, leave} { + set info {} + trace add execution foo {enter leave} [list traceExecute foo] + foo 3 + trace remove execution foo {enter leave} [list traceExecute foo] + set info +} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}} + +test trace-21.4 {trace execution: enter, leave, enterstep} { + set info {} + trace add execution foo {enter leave enterstep} [list traceExecute foo] + foo 3 + trace remove execution foo {enter leave enterstep} [list traceExecute foo] + set info +} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}} + +test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} { + set info {} + trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo] + foo 3 + trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo] + set info +} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}} + +test trace-21.6 {trace execution: enterstep, leavestep} { + set info {} + trace add execution foo {enterstep leavestep} [list traceExecute foo] + foo 3 + trace remove execution foo {enterstep leavestep} [list traceExecute foo] + set info +} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}} + +test trace-21.7 {trace execution: enterstep} { + set info {} + trace add execution foo {enterstep} [list traceExecute foo] + foo 3 + trace remove execution foo {enterstep} [list traceExecute foo] + set info +} {{foo {set b 3} enterstep}} + +test trace-21.8 {trace execution: leavestep} { + set info {} + trace add execution foo {leavestep} [list traceExecute foo] + foo 3 + trace remove execution foo {leavestep} [list traceExecute foo] + set info +} {{foo {set b 3} 0 3 leavestep}} + +proc factorial {n} { + if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } + return 1 +} + +test trace-22.1 {recursive(1) trace execution: enter} { + set info {} + trace add execution factorial {enter} [list traceExecute factorial] + factorial 1 + trace remove execution factorial {enter} [list traceExecute factorial] + set info +} {{factorial {factorial 1} enter}} + +test trace-22.2 {recursive(2) trace execution: enter} { + set info {} + trace add execution factorial {enter} [list traceExecute factorial] + factorial 2 + trace remove execution factorial {enter} [list traceExecute factorial] + set info +} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}} + +test trace-22.3 {recursive(3) trace execution: enter} { + set info {} + trace add execution factorial {enter} [list traceExecute factorial] + factorial 3 + trace remove execution factorial {enter} [list traceExecute factorial] + set info +} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}} + +test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} { + set info {} + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] + factorial 1 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] + join $info "\n" +} {{factorial 1} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep +{return 1} enterstep +{return 1} 2 1 leavestep +{factorial 1} 0 1 leave} + +test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} { + set info {} + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] + factorial 2 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] + join $info "\n" +} {{factorial 2} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep +{expr {$n -1 }} enterstep +{expr {$n -1 }} 0 1 leavestep +{factorial 1} enterstep +{factorial 1} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep +{return 1} enterstep +{return 1} 2 1 leavestep +{factorial 1} 0 1 leave +{factorial 1} 0 1 leavestep +{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep +{return 2} enterstep +{return 2} 2 2 leavestep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep +{factorial 2} 0 2 leave} + +test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} { + set info {} + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] + factorial 3 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] + join $info "\n" +} {{factorial 3} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep +{expr {$n -1 }} enterstep +{expr {$n -1 }} 0 2 leavestep +{factorial 2} enterstep +{factorial 2} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep +{expr {$n -1 }} enterstep +{expr {$n -1 }} 0 1 leavestep +{factorial 1} enterstep +{factorial 1} enter +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep +{return 1} enterstep +{return 1} 2 1 leavestep +{factorial 1} 0 1 leave +{factorial 1} 0 1 leavestep +{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep +{return 2} enterstep +{return 2} 2 2 leavestep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep +{factorial 2} 0 2 leave +{factorial 2} 0 2 leavestep +{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep +{return 6} enterstep +{return 6} 2 6 leavestep +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep +{factorial 3} 0 6 leave} + +proc traceDelete {cmd args} { + eval trace remove execution $cmd [lindex [trace info execution $cmd] 0] + global info + set info $args +} + +test trace-24.1 {delete trace during enter trace} { + set info {} + trace add execution foo enter [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{foo 1} enter} {}} + +test trace-24.2 {delete trace during leave trace} { + set info {} + trace add execution foo leave [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{foo 1} 0 1 leave} {}} + +test trace-24.3 {delete trace during enter-leave trace} { + set info {} + trace add execution foo {enter leave} [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{foo 1} enter} {}} + +test trace-24.4 {delete trace during all exec traces} { + set info {} + trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{foo 1} enter} {}} + +test trace-24.5 {delete trace during all exec traces except enter} { + set info {} + trace add execution foo {leave enterstep leavestep} [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{set b 1} enterstep} {}} + +proc traceDelete {cmd args} { + rename $cmd {} + global info + set info $args +} + +proc foo {a} { + set b $a +} + +test trace-25.1 {delete command during enter trace} { + set info {} + trace add execution foo enter [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + +proc foo {a} { + set b $a +} + +test trace-25.2 {delete command during leave trace} { + set info {} + trace add execution foo leave [list traceDelete foo] + foo 1 + list $info [trace info execution foo] +} {{{foo 1} 0 1 leave} {unknown command "foo"}} + +proc foo {a} { + set b $a +} + +test trace-25.3 {delete command during enter then leave trace} { + set info {} + trace add execution foo enter [list traceDelete foo] + trace add execution foo leave [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} +proc foo {a} { + set b $a +} +proc traceExecute2 {args} { + global info + lappend info $args +} + +# This shows the peculiar consequences of having two traces +# at the same time: as well as tracing the procedure you want +test trace-25.4 {order dependencies of two enter traces} { + set info {} + trace add execution foo enter [list traceExecute traceExecute] + trace add execution foo enter [list traceExecute2 traceExecute2] + catch {foo 1} err + trace remove execution foo enter [list traceExecute traceExecute] + trace remove execution foo enter [list traceExecute2 traceExecute2] + join [list $err [join $info \n] [trace info execution foo]] "\n" +} {1 +traceExecute2 {foo 1} enter +traceExecute {foo 1} enter +} + +test trace-25.5 {order dependencies of two step traces} { + set info {} + trace add execution foo enterstep [list traceExecute traceExecute] + trace add execution foo enterstep [list traceExecute2 traceExecute2] + catch {foo 1} err + trace remove execution foo enterstep [list traceExecute traceExecute] + trace remove execution foo enterstep [list traceExecute2 traceExecute2] + join [list $err [join $info \n] [trace info execution foo]] "\n" +} {1 +traceExecute2 {set b 1} enterstep +traceExecute {set b 1} enterstep +} + +# We don't want the result string (5th argument), or the results +# will get unmanageable. +proc tracePostExecute {args} { + global info + lappend info [concat [lrange $args 0 2] [lindex $args 4]] +} +proc tracePostExecute2 {args} { + global info + lappend info [concat [lrange $args 0 2] [lindex $args 4]] +} + +test trace-25.6 {order dependencies of two leave traces} { + set info {} + trace add execution foo leave [list tracePostExecute tracePostExecute] + trace add execution foo leave [list tracePostExecute2 tracePostExecute2] + catch {foo 1} err + trace remove execution foo leave [list tracePostExecute tracePostExecute] + trace remove execution foo leave [list tracePostExecute2 tracePostExecute2] + join [list $err [join $info \n] [trace info execution foo]] "\n" +} {1 +tracePostExecute {foo 1} 0 leave +tracePostExecute2 {foo 1} 0 leave +} + +test trace-25.7 {order dependencies of two leavestep traces} { + set info {} + trace add execution foo leavestep [list tracePostExecute tracePostExecute] + trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2] + catch {foo 1} err + trace remove execution foo leavestep [list tracePostExecute tracePostExecute] + trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2] + join [list $err [join $info \n] [trace info execution foo]] "\n" +} {1 +tracePostExecute {set b 1} 0 leavestep +tracePostExecute2 {set b 1} 0 leavestep +} + +proc foo {a} { + set b $a +} + +proc traceDelete {cmd args} { + rename $cmd {} + global info + set info $args +} + +test trace-25.8 {delete command during enter leave and enter/leave-step traces} { + set info {} + trace add execution foo enter [list traceDelete foo] + trace add execution foo leave [list traceDelete foo] + trace add execution foo enterstep [list traceDelete foo] + trace add execution foo leavestep [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + +proc foo {a} { + set b $a +} + +test trace-25.9 {delete command during enter leave and leavestep traces} { + set info {} + trace add execution foo enter [list traceDelete foo] + trace add execution foo leave [list traceDelete foo] + trace add execution foo leavestep [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + +proc foo {a} { + set b $a +} + +test trace-25.10 {delete command during leave and leavestep traces} { + set info {} + trace add execution foo leave [list traceDelete foo] + trace add execution foo leavestep [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {1 {{set b 1} 0 1 leavestep} {unknown command "foo"}} + +proc foo {a} { + set b $a +} + +test trace-25.11 {delete command during enter and enterstep traces} { + set info {} + trace add execution foo enter [list traceDelete foo] + trace add execution foo enterstep [list traceDelete foo] + catch {foo 1} err + list $err $info [trace info execution foo] +} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + +# Delete procedures when done, so we don't clash with other tests +# (e.g. foobar will clash with 'unknown' tests). +catch {rename foobar {}} +catch {rename foo {}} +catch {rename bar {}} # cleanup ::tcltest::cleanupTests diff --git a/unix/mkLinks b/unix/mkLinks index db75bd3..33139b6 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -270,6 +270,8 @@ if test -r CrtObjCmd.3; then rm -f Tcl_SetCommandInfo.3 rm -f Tcl_SetCommandInfoFromToken.3 rm -f Tcl_GetCommandName.3 + rm -f Tcl_GetCommandFullName.3 + rm -f Tcl_GetCommandFromObj.3 ln CrtObjCmd.3 Tcl_CreateObjCommand.3 ln CrtObjCmd.3 Tcl_DeleteCommand.3 ln CrtObjCmd.3 Tcl_DeleteCommandFromToken.3 @@ -278,6 +280,8 @@ if test -r CrtObjCmd.3; then ln CrtObjCmd.3 Tcl_SetCommandInfo.3 ln CrtObjCmd.3 Tcl_SetCommandInfoFromToken.3 ln CrtObjCmd.3 Tcl_GetCommandName.3 + ln CrtObjCmd.3 Tcl_GetCommandFullName.3 + ln CrtObjCmd.3 Tcl_GetCommandFromObj.3 fi if test -r CrtSlave.3; then rm -f Tcl_IsSafe.3 |