summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c339
-rw-r--r--generic/tclCmdMZ.c1948
-rw-r--r--generic/tclTrace.c2299
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);
+}