diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 339 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 1948 | ||||
| -rw-r--r-- | generic/tclTrace.c | 2299 |
3 files changed, 2301 insertions, 2285 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cb7bb9e..cf8a758 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.84 2003/06/10 19:46:42 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.85 2003/06/25 23:02:11 dkf Exp $ */ #include "tclInt.h" @@ -32,14 +32,6 @@ static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ProcessUnexpectedResult _ANSI_ARGS_(( Tcl_Interp *interp, int returnCode)); -static int StringTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, - int level, - CONST char* command, - Tcl_Command commandInfo, - int objc, - Tcl_Obj *CONST objv[])); -static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); extern TclStubs tclStubs; @@ -251,16 +243,6 @@ static CmdInfo builtInCmds[] = { {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; - -/* - * The following structure holds the client data for string-based - * trace procs - */ - -typedef struct StringTraceData { - ClientData clientData; /* Client data from Tcl_CreateTrace */ - Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ -} StringTraceData; /* *---------------------------------------------------------------------- @@ -4555,325 +4537,6 @@ Tcl_ExprString(interp, string) /* *---------------------------------------------------------------------- * - * Tcl_CreateObjTrace -- - * - * Arrange for a procedure to be called to trace command execution. - * - * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. - * - * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void proc( ClientData clientData, - * Tcl_Interp* interp, - * int level, - * CONST char* command, - * Tcl_Command commandInfo, - * int objc, - * Tcl_Obj *CONST objv[] ); - * - * The 'clientData' and 'interp' arguments to 'proc' will be the - * same as the arguments to Tcl_CreateObjTrace. The 'level' - * argument gives the nesting depth of command interpretation within - * the interpreter. The 'command' argument is the ASCII text of - * the command being evaluated -- before any substitutions are - * performed. The 'commandInfo' argument gives a handle to the - * command procedure that will be evaluated. The 'objc' and 'objv' - * parameters give the parameter vector that will be passed to the - * command procedure. proc does not return a value. - * - * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo - * to change the command procedure or client data for the command - * being evaluated, and these changes will take effect with the - * current evaluation. - * - * The 'level' argument specifies the maximum nesting level of calls - * to be traced. If the execution depth of the interpreter exceeds - * 'level', the trace callback is not executed. - * - * The 'flags' argument is either zero or the value, - * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION - * flag is not present, the bytecode compiler will not generate inline - * code for Tcl's built-in commands. This behavior will have a significant - * impact on performance, but will ensure that all command evaluations are - * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the - * bytecode compiler will have its normal behavior of compiling in-line - * code for some of Tcl's built-in commands. In this case, the tracing - * will be imprecise -- in-line code will not be traced -- but run-time - * performance will be improved. The latter behavior is desired for - * many applications such as profiling of run time. - * - * When the trace is deleted, the 'delProc' procedure will be invoked, - * passing it the original client data. - * - *---------------------------------------------------------------------- - */ - -Tcl_Trace -Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) - Tcl_Interp* interp; /* Tcl interpreter */ - int level; /* Maximum nesting level */ - int flags; /* Flags, see above */ - Tcl_CmdObjTraceProc* proc; /* Trace callback */ - ClientData clientData; /* Client data for the callback */ - Tcl_CmdObjTraceDeleteProc* delProc; - /* Procedure to call when trace is deleted */ -{ - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; - - /* Test if this trace allows inline compilation of commands */ - - if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { - if (iPtr->tracesForbiddingInline == 0) { - - /* - * When the first trace forbidding inline compilation is - * created, invalidate existing compiled code for this - * interpreter and arrange (by setting the - * DONT_COMPILE_CMDS_INLINE flag) that when compiling new - * code, no commands will be compiled inline (i.e., into - * an inline sequence of instructions). We do this because - * commands that were compiled inline will never result in - * a command trace being called. - */ - - iPtr->compileEpoch++; - iPtr->flags |= DONT_COMPILE_CMDS_INLINE; - } - iPtr->tracesForbiddingInline++; - } - - tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->delProc = delProc; - tracePtr->nextPtr = iPtr->tracePtr; - tracePtr->flags = flags; - iPtr->tracePtr = tracePtr; - - return (Tcl_Trace) tracePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateTrace -- - * - * Arrange for a procedure to be called to trace command execution. - * - * Results: - * The return value is a token for the trace, which may be passed - * to Tcl_DeleteTrace to eliminate the trace. - * - * Side effects: - * From now on, proc will be called just before a command procedure - * is called to execute a Tcl command. Calls to proc will have the - * following form: - * - * void - * proc(clientData, interp, level, command, cmdProc, cmdClientData, - * argc, argv) - * ClientData clientData; - * Tcl_Interp *interp; - * int level; - * char *command; - * int (*cmdProc)(); - * ClientData cmdClientData; - * int argc; - * char **argv; - * { - * } - * - * The clientData and interp arguments to proc will be the same - * as the corresponding arguments to this procedure. Level gives - * the nesting level of command interpretation for this interpreter - * (0 corresponds to top level). Command gives the ASCII text of - * the raw command, cmdProc and cmdClientData give the procedure that - * will be called to process the command and the ClientData value it - * will receive, and argc and argv give the arguments to the - * command, after any argument parsing and substitution. Proc - * does not return a value. - * - *---------------------------------------------------------------------- - */ - -Tcl_Trace -Tcl_CreateTrace(interp, level, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which to create trace. */ - int level; /* Only call proc for commands at nesting - * level<=argument level (1=>top level). */ - Tcl_CmdTraceProc *proc; /* Procedure to call before executing each - * command. */ - ClientData clientData; /* Arbitrary value word to pass to proc. */ -{ - StringTraceData* data; - data = (StringTraceData*) ckalloc( sizeof( *data )); - data->clientData = clientData; - data->proc = proc; - return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, - (ClientData) data, StringTraceDeleteProc ); -} - -/* - *---------------------------------------------------------------------- - * - * StringTraceProc -- - * - * Invoke a string-based trace procedure from an object-based - * callback. - * - * Results: - * None. - * - * Side effects: - * Whatever the string-based trace procedure does. - * - *---------------------------------------------------------------------- - */ - -static int -StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) - ClientData clientData; - Tcl_Interp* interp; - int level; - CONST char* command; - Tcl_Command commandInfo; - int objc; - Tcl_Obj *CONST *objv; -{ - StringTraceData* data = (StringTraceData*) clientData; - Command* cmdPtr = (Command*) commandInfo; - - CONST char** argv; /* Args to pass to string trace proc */ - - int i; - - /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. - */ - - argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) - * sizeof(CONST char *) )); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[objc] = 0; - - /* - * Invoke the command procedure. Note that we cast away const-ness - * 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, argv ); - ckfree( (char*) argv ); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringTraceDeleteProc -- - * - * Clean up memory when a string-based trace is deleted. - * - * Results: - * None. - * - * Side effects: - * Allocated memory is returned to the system. - * - *---------------------------------------------------------------------- - */ - -static void -StringTraceDeleteProc( clientData ) - ClientData clientData; -{ - ckfree( (char*) clientData ); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteTrace -- - * - * Remove a trace. - * - * Results: - * None. - * - * Side effects: - * From now on there will be no more calls to the procedure given - * in trace. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteTrace(interp, trace) - Tcl_Interp *interp; /* Interpreter that contains trace. */ - Tcl_Trace trace; /* Token for trace (returned previously by - * Tcl_CreateTrace). */ -{ - Interp *iPtr = (Interp *) interp; - Trace *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &(iPtr->tracePtr); - - /* - * Locate the trace entry in the interpreter's trace list, - * and remove it from the list. - */ - - while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { - tracePtr2 = &((*tracePtr2)->nextPtr); - } - if (*tracePtr2 == NULL) { - 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 - * advance the compilation epoch so that procs will be recompiled to - * take advantage of it. - */ - - if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { - iPtr->tracesForbiddingInline--; - if (iPtr->tracesForbiddingInline == 0) { - iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; - iPtr->compileEpoch++; - } - } - - /* - * Execute any delete callback. - */ - - if (tracePtr->delProc != NULL) { - (tracePtr->delProc)(tracePtr->clientData); - } - - /* Delete the trace object */ - - Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_AddErrorInfo -- * * Add information to the "errorInfo" variable that describes the diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 48d8e75..9c212ab 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.91 2003/06/17 20:36:20 vincentdarley Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.92 2003/06/25 23:02:11 dkf Exp $ */ #include "tclInt.h" @@ -22,117 +22,6 @@ #include "tclRegexp.h" /* - * Structure used to hold information about variable traces: - */ - -typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ - size_t length; /* Number of non-NULL chars. in command. */ - char command[4]; /* Space for Tcl command to invoke. Actual - * size will be as large as necessary to - * hold command. This field must be the - * last in the structure, so that it can - * be larger than 4 bytes. */ -} TraceVarInfo; - -/* - * Structure used to hold information about command traces: - */ - -typedef struct { - int flags; /* Operations for which Tcl command is - * to be invoked. */ - size_t length; /* Number of non-NULL chars. in command. */ - Tcl_Trace stepTrace; /* Used for execution traces, when tracing - * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution - * traces, store the level at which the step - * trace was invoked */ - char *startCmd; /* Used for bookkeeping with step execution - * traces, store the command name which invoked - * step trace */ - int curFlags; /* Trace flags for the current command */ - int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is - * not deleted too early. Keeps track - * of how many pieces of code have - * a pointer to this structure. */ - 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: - */ - -typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, - int optionIndex, int objc, Tcl_Obj *CONST objv[])); - -Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; -Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; -Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; - -/* - * Each subcommand has a number of 'types' to which it can apply. - * 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[] = { - "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, - CONST char *command, int numChars, - int objc, Tcl_Obj *CONST objv[])); -static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, CONST 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; - -/* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- @@ -2845,1840 +2734,6 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_TraceObjCmd -- - * - * 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|info|remove} {command|variable} name ops cmd - * - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_TraceObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int optionIndex, commandLength; - char *name, *flagOps, *command, *p; - size_t length; - /* Main sub commands to 'trace' */ - static CONST char *traceOptions[] = { - "add", "info", "remove", -#ifndef TCL_REMOVE_OBSOLETE_TRACES - "variable", "vdelete", "vinfo", -#endif - (char *) NULL - }; - /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptions { - TRACE_ADD, TRACE_INFO, 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 ...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, - "option", 0, &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum traceOptions) optionIndex) { - case TRACE_ADD: - case TRACE_REMOVE: { - /* - * 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; - } - case TRACE_INFO: { - /* - * All sub commands of trace info must take exactly two - * more arguments which name the type of thing being - * traced and the name of the thing being traced. - */ - int typeIndex; - if (objc < 3) { - /* - * Delegate other complaints to the type-specific code - * which can give a better error message. - */ - Tcl_WrongNumArgs(interp, 2, objv, "type name"); - 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->length = length; - flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; - strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[2]); - if (Tcl_TraceVar(interp, name, flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - break; - } - case TRACE_OLD_VDELETE: { - int flags; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - flags = 0; - flagOps = Tcl_GetString(objv[3]); - for (p = flagOps; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else 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_UntraceVar2(interp, name, NULL, - flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, - TraceVarProc, clientData); - Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); - 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; -} - - -/* - *---------------------------------------------------------------------- - * - * 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 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 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->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - 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 = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - 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; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion */ - tcmdPtr->flags = 0; - } - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); - } - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - - 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",5)); - } - 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",9)); - } - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - elemObjPtr = NULL; - - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, - Tcl_NewStringObj(tcmdPtr->command, -1)); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } - } - return TCL_OK; -} - - -/* - *---------------------------------------------------------------------- - * - * TclTraceCommandObjCmd -- - * - * Helper function for Tcl_TraceObjCmd; implements the - * [trace {add|info|remove} 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 info) 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, 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[] = { "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->stepTrace = NULL; - tcmdPtr->startLevel = 0; - tcmdPtr->startCmd = NULL; - tcmdPtr->length = length; - tcmdPtr->refCount = 1; - 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 = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - 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); - tcmdPtr->flags |= TCL_TRACE_DESTROYED; - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char *) tcmdPtr); - } - break; - } - } - } - break; - } - case TRACE_INFO: { - ClientData clientData; - Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "name"); - return TCL_ERROR; - } - - clientData = NULL; - name = Tcl_GetString(objv[3]); - - /* First ensure the name given is valid */ - if (Tcl_FindCommand(interp, name, NULL, - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - - resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != NULL) { - - 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); - - 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|info|remove} 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 info) 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, 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[] = { "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)); - tvarPtr->flags = flags; - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; - strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[3]); - if (Tcl_TraceVar(interp, name, flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - } else { - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ - - TraceVarInfo *tvarPtr; - ClientData clientData = 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) - && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar2(interp, name, NULL, - flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, - TraceVarProc, clientData); - Tcl_EventuallyFree((ClientData) tvarPtr, 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_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)); - } - 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); - - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, - eachTraceObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); - break; - } - } - return TCL_OK; -} - - -/* - *---------------------------------------------------------------------- - * - * 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 then an error message is left in the interpreter - * and NULL is returned. Also, if there are no (more) traces for - * the given command, NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) - Tcl_Interp *interp; /* Interpreter containing command. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ - ClientData prevClientData; /* If non-NULL, gives last value returned - * by this procedure, so this call will - * return the next trace after that one. - * If NULL, this call will return the - * first trace. */ -{ - Command *cmdPtr; - register CommandTrace *tracePtr; - - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); - if (cmdPtr == NULL) { - return NULL; - } - - /* - * Find the relevant trace, if any, and return its clientData. - */ - - tracePtr = cmdPtr->tracePtr; - if (prevClientData != NULL) { - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { - if ((tracePtr->clientData == prevClientData) - && (tracePtr->traceProc == proc)) { - tracePtr = tracePtr->nextPtr; - break; - } - } - } - for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { - if (tracePtr->traceProc == proc) { - return tracePtr->clientData; - } - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TraceCommand -- - * - * Arrange for rename/deletes to a command to cause a - * procedure to be invoked, which can monitor the operations. - * - * Also optionally arrange for execution of that command - * to cause a procedure to be invoked. - * - * 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. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, - * and any of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are - * invoked upon cmdName. */ - 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 - | TCL_TRACE_ANY_EXEC); - tracePtr->nextPtr = cmdPtr->tracePtr; - tracePtr->refCount = 1; - cmdPtr->tracePtr = tracePtr; - if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - cmdPtr->flags |= CMD_HAS_EXEC_TRACES; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UntraceCommand -- - * - * Remove a previously-created trace for a command. - * - * Results: - * None. - * - * Side effects: - * If there exists a trace for the command given by cmdName - * with the given flags, proc, and clientData, then that trace - * is removed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) - Tcl_Interp *interp; /* Interpreter containing command. */ - CONST char *cmdName; /* Name of command. */ - int flags; /* OR-ed collection of bits, including any - * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, - * and any of the TRACE_*_EXEC flags */ - Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ - ClientData clientData; /* Arbitrary argument to pass to proc. */ -{ - register CommandTrace *tracePtr; - CommandTrace *prevPtr; - Command *cmdPtr; - Interp *iPtr = (Interp *) interp; - ActiveCommandTrace *activePtr; - int hasExecTraces = 0; - - cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, - NULL, TCL_LEAVE_ERR_MSG); - if (cmdPtr == NULL) { - return; - } - - flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); - - for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { - if (tracePtr == NULL) { - return; - } - if ((tracePtr->traceProc == proc) - && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | - TCL_TRACE_ANY_EXEC)) == flags) - && (tracePtr->clientData == clientData)) { - if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { - hasExecTraces = 1; - } - break; - } - } - - /* - * The code below makes it possible to delete traces while traces - * are active: it makes sure that the deleted trace won't be - * processed by CallCommandTraces. - */ - - for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->nextTracePtr == tracePtr) { - activePtr->nextTracePtr = tracePtr->nextPtr; - } - } - if (prevPtr == NULL) { - cmdPtr->tracePtr = tracePtr->nextPtr; - } else { - prevPtr->nextPtr = tracePtr->nextPtr; - } - tracePtr->flags = 0; - - if ((--tracePtr->refCount) <= 0) { - ckfree((char*)tracePtr); - } - - 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; - } -} - -/* - *---------------------------------------------------------------------- - * - * TraceCommandProc -- - * - * This procedure is called to handle command changes that have - * been traced using the "trace" command, when using the - * 'rename' or 'delete' options. - * - * Results: - * None. - * - * 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. */ - CONST char *oldName; /* Name of command being changed. */ - CONST 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. */ -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *stateReturnOpts; - Tcl_SavedResult state; - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; - int code; - Tcl_DString cmd; - - tcmdPtr->refCount++; - - 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. - */ - - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); - Tcl_DStringAppendElement(&cmd, oldName); - Tcl_DStringAppendElement(&cmd, (newName ? 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, including the value of iPtr->returnOpts which may be - * modified when Tcl_Eval is invoked. We discard any object - * result the command returns. - * - * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to - * other areas that this will be destroyed by us, otherwise a - * double-free might occur depending on what the eval does. - */ - - Tcl_SaveResult(interp, &state); - stateReturnOpts = iPtr->returnOpts; - Tcl_IncrRefCount(stateReturnOpts); - if (flags & TCL_TRACE_DESTROYED) { - tcmdPtr->flags |= TCL_TRACE_DESTROYED; - } - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), - Tcl_DStringLength(&cmd), 0); - if (code != TCL_OK) { - /* We ignore errors in these traced commands */ - } - - Tcl_RestoreResult(interp, &state); - if (iPtr->returnOpts != stateReturnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = stateReturnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - Tcl_DecrRefCount(stateReturnOpts); - - Tcl_DStringFree(&cmd); - } - /* - * We delete when the trace was destroyed or if this is a delete trace, - * because command deletes are unconditional, so the trace must go away. - */ - if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { - if (tcmdPtr->stepTrace != NULL) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { - /* Postpone deletion, until exec trace returns */ - tcmdPtr->flags = 0; - } - /* - * Decrement the refCount since the command which held our - * reference (ever since we were created) has just gone away - */ - tcmdPtr->refCount--; - } - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)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. */ - CONST 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; - tcmdPtr->refCount++; - traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, - curLevel, command, (Tcl_Command)cmdPtr, objc, objv); - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); - } - } - 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. */ - CONST 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)) { - /* - * The proc invoked might delete the traced command which - * which might try to free tracePtr. We want to use tracePtr - * until the end of this if section, so we use - * Tcl_Preserve() and Tcl_Release() to be sure it is not - * freed while we still need it. - */ - Tcl_Preserve((ClientData) tracePtr); - tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; - - if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { - /* New style trace */ - 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 { - /* Old-style trace */ - - 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; - Tcl_Release((ClientData) tracePtr); - } - 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. */ - CONST 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); -} - -/* - *---------------------------------------------------------------------- - * - * CommandObjTraceDeleted -- - * - * Ensure the trace is correctly deleted by decrementing its - * refCount and only deleting if no other references exist. - * - * Results: - * None. - * - * Side effects: - * May release memory. - * - *---------------------------------------------------------------------- - */ -static void -CommandObjTraceDeleted(ClientData clientData) { - TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ -static 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 for enterstep and/or leavestep - * execution traces, we remove it here. - */ - if (flags & TCL_TRACE_LEAVE_EXEC) { - if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) - && (strcmp(command, tcmdPtr->startCmd) == 0)) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - } - - /* - * Second, create the tcl callback, if required. - */ - if (call) { - Tcl_SavedResult state; - Tcl_Obj *stateReturnOpts; - 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, including the value of iPtr->returnOpts which - * may be modified when Tcl_Eval is invoked. We discard any - * object result the command returns. - */ - - Tcl_SaveResult(interp, &state); - stateReturnOpts = iPtr->returnOpts; - Tcl_IncrRefCount(stateReturnOpts); - - tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; - iPtr->flags |= INTERP_TRACE_IN_PROGRESS; - tcmdPtr->refCount++; - /* - * 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); - if (iPtr->returnOpts != stateReturnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = stateReturnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - } else { - Tcl_DiscardResult(&state); - } - Tcl_DecrRefCount(stateReturnOpts); - - Tcl_DStringFree(&cmd); - } - - /* - * Third, if there are any step execution traces for this proc, - * we register an interpreter trace to invoke enterstep and/or - * leavestep traces. - * We also need to save the current stack level and the proc - * string in startLevel and startCmd so that we can delete this - * interpreter trace when it reaches the end of this proc. - */ - 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->startCmd = - (char *) ckalloc((unsigned) (strlen(command) + 1)); - strcpy(tcmdPtr->startCmd, command); - tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, - (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, (ClientData)tcmdPtr, - CommandObjTraceDeleted); - } - } - if (flags & TCL_TRACE_DESTROYED) { - if (tcmdPtr->stepTrace != NULL) { - Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); - tcmdPtr->stepTrace = NULL; - if (tcmdPtr->startCmd != NULL) { - ckfree((char *)tcmdPtr->startCmd); - } - } - } - if (call) { - if ((--tcmdPtr->refCount) <= 0) { - ckfree((char*)tcmdPtr); - } - } - return traceCode; -} - -/* - *---------------------------------------------------------------------- - * - * TraceVarProc -- - * - * This procedure is called to handle variable accesses that have - * been traced using the "trace" command. - * - * Results: - * Normally returns NULL. If the trace command returns an error, - * then this procedure returns an error string. - * - * Side effects: - * Depends on the command associated with the trace. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static char * -TraceVarProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Information about the variable trace. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - CONST char *name1; /* Name of variable or array. */ - CONST char *name2; /* Name of element within array; NULL means - * scalar variable is being referenced. */ - int flags; /* OR-ed bits giving operation and other - * information. */ -{ - Tcl_SavedResult state; - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - char *result; - 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) { - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. - */ - - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); - Tcl_DStringAppendElement(&cmd, name1); - Tcl_DStringAppendElement(&cmd, (name2 ? 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. - * - * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to - * other areas that this will be destroyed by us, otherwise a - * double-free might occur depending on what the eval does. - */ - - Tcl_SaveResult(interp, &state); - if (flags & TCL_TRACE_DESTROYED) { - tvarPtr->flags |= TCL_TRACE_DESTROYED; - } - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), - Tcl_DStringLength(&cmd), 0); - if (code != TCL_OK) { /* copy error msg to result */ - register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(errMsgObj); - result = (char *) errMsgObj; - } - - Tcl_RestoreResult(interp, &state); - - Tcl_DStringFree(&cmd); - } - } - if (flags & TCL_TRACE_DESTROYED) { - if (result != NULL) { - register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; - - Tcl_DecrRefCount(errMsgObj); - result = NULL; - } - Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); - } - Tcl_Release((ClientData) tvarPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. @@ -4740,4 +2795,3 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) } return result; } - diff --git a/generic/tclTrace.c b/generic/tclTrace.c new file mode 100644 index 0000000..1725a7d --- /dev/null +++ b/generic/tclTrace.c @@ -0,0 +1,2299 @@ +/* + * tclCmdAH.c -- + * + * This file contains code to handle most trace management. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Scriptics Corporation. + * Copyright (c) 2002 ActiveState Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclTrace.c,v 1.1 2003/06/25 23:02:11 dkf Exp $ + */ + +#include "tclInt.h" + +/* + * Structure used to hold information about variable traces: + */ + +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + size_t length; /* Number of non-NULL chars. in command. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to + * hold command. This field must be the + * last in the structure, so that it can + * be larger than 4 bytes. */ +} TraceVarInfo; + +/* + * Structure used to hold information about command traces: + */ + +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + size_t length; /* Number of non-NULL chars. in command. */ + Tcl_Trace stepTrace; /* Used for execution traces, when tracing + * inside the given command */ + int startLevel; /* Used for bookkeeping with step execution + * traces, store the level at which the step + * trace was invoked */ + char *startCmd; /* Used for bookkeeping with step execution + * traces, store the command name which invoked + * step trace */ + int curFlags; /* Trace flags for the current command */ + int curCode; /* Return code for the current command */ + int refCount; /* Used to ensure this structure is + * not deleted too early. Keeps track + * of how many pieces of code have + * a pointer to this structure. */ + 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: + */ + +typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, + int optionIndex, int objc, Tcl_Obj *CONST objv[])); + +Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; +Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; +Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; + +/* + * Each subcommand has a number of 'types' to which it can apply. + * 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[] = { + "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, + CONST char *command, int numChars, + int objc, Tcl_Obj *CONST objv[])); +static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST 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; +static int StringTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); +static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); + +/* + * The following structure holds the client data for string-based + * trace procs + */ + +typedef struct StringTraceData { + ClientData clientData; /* Client data from Tcl_CreateTrace */ + Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ +} StringTraceData; + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceObjCmd -- + * + * 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|info|remove} {command|variable} name ops cmd + * + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TraceObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int optionIndex, commandLength; + char *name, *flagOps, *command, *p; + size_t length; + /* Main sub commands to 'trace' */ + static CONST char *traceOptions[] = { + "add", "info", "remove", +#ifndef TCL_REMOVE_OBSOLETE_TRACES + "variable", "vdelete", "vinfo", +#endif + (char *) NULL + }; + /* 'OLD' options are pre-Tcl-8.4 style */ + enum traceOptions { + TRACE_ADD, TRACE_INFO, 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 ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + /* + * 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; + } + case TRACE_INFO: { + /* + * All sub commands of trace info must take exactly two + * more arguments which name the type of thing being + * traced and the name of the thing being traced. + */ + int typeIndex; + if (objc < 3) { + /* + * Delegate other complaints to the type-specific code + * which can give a better error message. + */ + Tcl_WrongNumArgs(interp, 2, objv, "type name"); + 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->length = length; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; + } + case TRACE_OLD_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else 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_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + TraceVarProc, clientData); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); + 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; +} + + +/* + *---------------------------------------------------------------------- + * + * 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 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 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->startCmd = NULL; + tcmdPtr->length = length; + tcmdPtr->refCount = 1; + 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 = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + 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; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } + } + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* Postpone deletion */ + tcmdPtr->flags = 0; + } + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + + 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",5)); + } + 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",9)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + elemObjPtr = NULL; + + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, + Tcl_NewStringObj(tcmdPtr->command, -1)); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceCommandObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|info|remove} 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 info) 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, 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[] = { "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->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->startCmd = NULL; + tcmdPtr->length = length; + tcmdPtr->refCount = 1; + 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 = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + 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); + tcmdPtr->flags |= TCL_TRACE_DESTROYED; + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + clientData = NULL; + name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + + 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); + + 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|info|remove} 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 info) 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, 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[] = { "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)); + tvarPtr->flags = flags; + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + TraceVarInfo *tvarPtr; + ClientData clientData = 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) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + TraceVarProc, clientData); + Tcl_EventuallyFree((ClientData) tvarPtr, 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_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)); + } + 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); + + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * 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 then an error message is left in the interpreter + * and NULL is returned. Also, if there are no (more) traces for + * the given command, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + CONST char *cmdName; /* Name of command. */ + int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + Command *cmdPtr; + register CommandTrace *tracePtr; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = cmdPtr->tracePtr; + if (prevClientData != NULL) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; + break; + } + } + } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCommand -- + * + * Arrange for rename/deletes to a command to cause a + * procedure to be invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command + * to cause a procedure to be invoked. + * + * 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. */ + CONST char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon cmdName. */ + 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 + | TCL_TRACE_ANY_EXEC); + tracePtr->nextPtr = cmdPtr->tracePtr; + tracePtr->refCount = 1; + cmdPtr->tracePtr = tracePtr; + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + cmdPtr->flags |= CMD_HAS_EXEC_TRACES; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceCommand -- + * + * Remove a previously-created trace for a command. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the command given by cmdName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + CONST char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register CommandTrace *tracePtr; + CommandTrace *prevPtr; + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + ActiveCommandTrace *activePtr; + int hasExecTraces = 0; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); + + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) + && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | + TCL_TRACE_ANY_EXEC)) == flags) + && (tracePtr->clientData == clientData)) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + hasExecTraces = 1; + } + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallCommandTraces. + */ + + for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + cmdPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + tracePtr->flags = 0; + + if ((--tracePtr->refCount) <= 0) { + ckfree((char*)tracePtr); + } + + 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; + } +} + +/* + *---------------------------------------------------------------------- + * + * TraceCommandProc -- + * + * This procedure is called to handle command changes that have + * been traced using the "trace" command, when using the + * 'rename' or 'delete' options. + * + * Results: + * None. + * + * 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. */ + CONST char *oldName; /* Name of command being changed. */ + CONST 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. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *stateReturnOpts; + Tcl_SavedResult state; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + tcmdPtr->refCount++; + + 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. + */ + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, (newName ? 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, including the value of iPtr->returnOpts which may be + * modified when Tcl_Eval is invoked. We discard any object + * result the command returns. + * + * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to + * other areas that this will be destroyed by us, otherwise a + * double-free might occur depending on what the eval does. + */ + + Tcl_SaveResult(interp, &state); + stateReturnOpts = iPtr->returnOpts; + Tcl_IncrRefCount(stateReturnOpts); + if (flags & TCL_TRACE_DESTROYED) { + tcmdPtr->flags |= TCL_TRACE_DESTROYED; + } + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + if (iPtr->returnOpts != stateReturnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + iPtr->returnOpts = stateReturnOpts; + Tcl_IncrRefCount(iPtr->returnOpts); + } + Tcl_DecrRefCount(stateReturnOpts); + + Tcl_DStringFree(&cmd); + } + /* + * We delete when the trace was destroyed or if this is a delete trace, + * because command deletes are unconditional, so the trace must go away. + */ + if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } + } + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* Postpone deletion, until exec trace returns */ + tcmdPtr->flags = 0; + } + /* + * Decrement the refCount since the command which held our + * reference (ever since we were created) has just gone away + */ + tcmdPtr->refCount--; + } + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)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. */ + CONST 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; + tcmdPtr->refCount++; + traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, + curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } + } + 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. */ + CONST 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)) { + /* + * The proc invoked might delete the traced command which + * which might try to free tracePtr. We want to use tracePtr + * until the end of this if section, so we use + * Tcl_Preserve() and Tcl_Release() to be sure it is not + * freed while we still need it. + */ + Tcl_Preserve((ClientData) tracePtr); + tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + + if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { + /* New style trace */ + 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 { + /* Old-style trace */ + + 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; + Tcl_Release((ClientData) tracePtr); + } + 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. */ + CONST 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); +} + +/* + *---------------------------------------------------------------------- + * + * CommandObjTraceDeleted -- + * + * Ensure the trace is correctly deleted by decrementing its + * refCount and only deleting if no other references exist. + * + * Results: + * None. + * + * Side effects: + * May release memory. + * + *---------------------------------------------------------------------- + */ +static void +CommandObjTraceDeleted(ClientData clientData) { + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ +static 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 for enterstep and/or leavestep + * execution traces, we remove it here. + */ + if (flags & TCL_TRACE_LEAVE_EXEC) { + if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) + && (strcmp(command, tcmdPtr->startCmd) == 0)) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } + } + } + + /* + * Second, create the tcl callback, if required. + */ + if (call) { + Tcl_SavedResult state; + Tcl_Obj *stateReturnOpts; + 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, including the value of iPtr->returnOpts which + * may be modified when Tcl_Eval is invoked. We discard any + * object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + stateReturnOpts = iPtr->returnOpts; + Tcl_IncrRefCount(stateReturnOpts); + + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + tcmdPtr->refCount++; + /* + * 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); + if (iPtr->returnOpts != stateReturnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + iPtr->returnOpts = stateReturnOpts; + Tcl_IncrRefCount(iPtr->returnOpts); + } + } else { + Tcl_DiscardResult(&state); + } + Tcl_DecrRefCount(stateReturnOpts); + + Tcl_DStringFree(&cmd); + } + + /* + * Third, if there are any step execution traces for this proc, + * we register an interpreter trace to invoke enterstep and/or + * leavestep traces. + * We also need to save the current stack level and the proc + * string in startLevel and startCmd so that we can delete this + * interpreter trace when it reaches the end of this proc. + */ + 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->startCmd = + (char *) ckalloc((unsigned) (strlen(command) + 1)); + strcpy(tcmdPtr->startCmd, command); + tcmdPtr->refCount++; + tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, (ClientData)tcmdPtr, + CommandObjTraceDeleted); + } + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } + } + } + if (call) { + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } + } + return traceCode; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarProc -- + * + * This procedure is called to handle variable accesses that have + * been traced using the "trace" command. + * + * Results: + * Normally returns NULL. If the trace command returns an error, + * then this procedure returns an error string. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +TraceVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about the variable trace. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + CONST char *name1; /* Name of variable or array. */ + CONST char *name2; /* Name of element within array; NULL means + * scalar variable is being referenced. */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + Tcl_SavedResult state; + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + char *result; + 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) { + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. + */ + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, (name2 ? 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. + * + * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to + * other areas that this will be destroyed by us, otherwise a + * double-free might occur depending on what the eval does. + */ + + Tcl_SaveResult(interp, &state); + if (flags & TCL_TRACE_DESTROYED) { + tvarPtr->flags |= TCL_TRACE_DESTROYED; + } + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); + if (code != TCL_OK) { /* copy error msg to result */ + register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); + result = (char *) errMsgObj; + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + } + if (flags & TCL_TRACE_DESTROYED) { + if (result != NULL) { + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + + Tcl_DecrRefCount(errMsgObj); + result = NULL; + } + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); + } + Tcl_Release((ClientData) tvarPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateObjTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void proc( ClientData clientData, + * Tcl_Interp* interp, + * int level, + * CONST char* command, + * Tcl_Command commandInfo, + * int objc, + * Tcl_Obj *CONST objv[] ); + * + * The 'clientData' and 'interp' arguments to 'proc' will be the + * same as the arguments to Tcl_CreateObjTrace. The 'level' + * argument gives the nesting depth of command interpretation within + * the interpreter. The 'command' argument is the ASCII text of + * the command being evaluated -- before any substitutions are + * performed. The 'commandInfo' argument gives a handle to the + * command procedure that will be evaluated. The 'objc' and 'objv' + * parameters give the parameter vector that will be passed to the + * command procedure. proc does not return a value. + * + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo + * to change the command procedure or client data for the command + * being evaluated, and these changes will take effect with the + * current evaluation. + * + * The 'level' argument specifies the maximum nesting level of calls + * to be traced. If the execution depth of the interpreter exceeds + * 'level', the trace callback is not executed. + * + * The 'flags' argument is either zero or the value, + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION + * flag is not present, the bytecode compiler will not generate inline + * code for Tcl's built-in commands. This behavior will have a significant + * impact on performance, but will ensure that all command evaluations are + * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the + * bytecode compiler will have its normal behavior of compiling in-line + * code for some of Tcl's built-in commands. In this case, the tracing + * will be imprecise -- in-line code will not be traced -- but run-time + * performance will be improved. The latter behavior is desired for + * many applications such as profiling of run time. + * + * When the trace is deleted, the 'delProc' procedure will be invoked, + * passing it the original client data. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) + Tcl_Interp* interp; /* Tcl interpreter */ + int level; /* Maximum nesting level */ + int flags; /* Flags, see above */ + Tcl_CmdObjTraceProc* proc; /* Trace callback */ + ClientData clientData; /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc* delProc; + /* Procedure to call when trace is deleted */ +{ + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; + + /* Test if this trace allows inline compilation of commands */ + + if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { + if (iPtr->tracesForbiddingInline == 0) { + + /* + * When the first trace forbidding inline compilation is + * created, invalidate existing compiled code for this + * interpreter and arrange (by setting the + * DONT_COMPILE_CMDS_INLINE flag) that when compiling new + * code, no commands will be compiled inline (i.e., into + * an inline sequence of instructions). We do this because + * commands that were compiled inline will never result in + * a command trace being called. + */ + + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + } + iPtr->tracesForbiddingInline++; + } + + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->delProc = delProc; + tracePtr->nextPtr = iPtr->tracePtr; + tracePtr->flags = flags; + iPtr->tracePtr = tracePtr; + + return (Tcl_Trace) tracePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateTrace -- + * + * Arrange for a procedure to be called to trace command execution. + * + * Results: + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. + * + * Side effects: + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: + * + * void + * proc(clientData, interp, level, command, cmdProc, cmdClientData, + * argc, argv) + * ClientData clientData; + * Tcl_Interp *interp; + * int level; + * char *command; + * int (*cmdProc)(); + * ClientData cmdClientData; + * int argc; + * char **argv; + * { + * } + * + * The clientData and interp arguments to proc will be the same + * as the corresponding arguments to this procedure. Level gives + * the nesting level of command interpretation for this interpreter + * (0 corresponds to top level). Command gives the ASCII text of + * the raw command, cmdProc and cmdClientData give the procedure that + * will be called to process the command and the ClientData value it + * will receive, and argc and argv give the arguments to the + * command, after any argument parsing and substitution. Proc + * does not return a value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateTrace(interp, level, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which to create trace. */ + int level; /* Only call proc for commands at nesting + * level<=argument level (1=>top level). */ + Tcl_CmdTraceProc *proc; /* Procedure to call before executing each + * command. */ + ClientData clientData; /* Arbitrary value word to pass to proc. */ +{ + StringTraceData* data; + data = (StringTraceData*) ckalloc( sizeof( *data )); + data->clientData = clientData; + data->proc = proc; + return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc ); +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceProc -- + * + * Invoke a string-based trace procedure from an object-based + * callback. + * + * Results: + * None. + * + * Side effects: + * Whatever the string-based trace procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) + ClientData clientData; + Tcl_Interp* interp; + int level; + CONST char* command; + Tcl_Command commandInfo; + int objc; + Tcl_Obj *CONST *objv; +{ + StringTraceData* data = (StringTraceData*) clientData; + Command* cmdPtr = (Command*) commandInfo; + + CONST char** argv; /* Args to pass to string trace proc */ + + int i; + + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. + */ + + argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) + * sizeof(CONST char *) )); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; + + /* + * Invoke the command procedure. Note that we cast away const-ness + * 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, argv ); + ckfree( (char*) argv ); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceDeleteProc -- + * + * Clean up memory when a string-based trace is deleted. + * + * Results: + * None. + * + * Side effects: + * Allocated memory is returned to the system. + * + *---------------------------------------------------------------------- + */ + +static void +StringTraceDeleteProc( clientData ) + ClientData clientData; +{ + ckfree( (char*) clientData ); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the procedure given + * in trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace(interp, trace) + Tcl_Interp *interp; /* Interpreter that contains trace. */ + Tcl_Trace trace; /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + Interp *iPtr = (Interp *) interp; + Trace *tracePtr = (Trace *) trace; + register Trace **tracePtr2 = &(iPtr->tracePtr); + + /* + * Locate the trace entry in the interpreter's trace list, + * and remove it from the list. + */ + + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + tracePtr2 = &((*tracePtr2)->nextPtr); + } + if (*tracePtr2 == NULL) { + 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 + * advance the compilation epoch so that procs will be recompiled to + * take advantage of it. + */ + + if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { + iPtr->tracesForbiddingInline--; + if (iPtr->tracesForbiddingInline == 0) { + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + iPtr->compileEpoch++; + } + } + + /* + * Execute any delete callback. + */ + + if (tracePtr->delProc != NULL) { + (tracePtr->delProc)(tracePtr->clientData); + } + + /* Delete the trace object */ + + Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); +} |