diff options
Diffstat (limited to 'generic/tclTrace.c')
| -rw-r--r-- | generic/tclTrace.c | 3222 |
1 files changed, 3222 insertions, 0 deletions
diff --git a/generic/tclTrace.c b/generic/tclTrace.c new file mode 100644 index 0000000..1a6d60d --- /dev/null +++ b/generic/tclTrace.c @@ -0,0 +1,3222 @@ +/* + * tclTrace.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.47.2.3 2010/08/19 10:04:15 dkf Exp $ + */ + +#include "tclInt.h" + +/* + * Structures 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-NUL 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; + +typedef struct { + VarTrace traceInfo; + TraceVarInfo traceCmdInfo; +} CombinedTraceVarInfo; + +/* + * 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-NUL 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 + * TCL_TRACE_ENTER_DURING_EXEC == 4 * TCL_TRACE_ENTER_EXEC and that + * TCL_TRACE_LEAVE_DURING_EXEC == 4 * TCL_TRACE_LEAVE_EXEC. + * + * 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 function 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 functions defined in this file: + */ + +typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, + int objc, Tcl_Obj *const objv[]); + +static Tcl_TraceTypeObjCmd TraceVariableObjCmd; +static Tcl_TraceTypeObjCmd TraceCommandObjCmd; +static Tcl_TraceTypeObjCmd TraceExecutionObjCmd; + +/* + * 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", NULL +}; +static Tcl_TraceTypeObjCmd *traceSubCmds[] = { + TraceExecutionObjCmd, + TraceCommandObjCmd, + TraceVariableObjCmd, +}; + +/* + * Declarations for local functions to this file: + */ + +static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, + Command *cmdPtr, const char *command, int numChars, + int objc, Tcl_Obj *const objv[]); +static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, + const char *name1, const char *name2, int flags); +static void TraceCommandProc(ClientData clientData, + Tcl_Interp *interp, const char *oldName, + const char *newName, int flags); +static Tcl_CmdObjTraceProc TraceExecutionProc; +static int StringTraceProc(ClientData clientData, + Tcl_Interp *interp, int level, + const char *command, Tcl_Command commandInfo, + int objc, Tcl_Obj *const objv[]); +static void StringTraceDeleteProc(ClientData clientData); +static void DisposeTraceResult(int flags, char *result); +static int TraceVarEx(Tcl_Interp *interp, const char *part1, + const char *part2, register VarTrace *tracePtr); + +/* + * 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 function from Tcl_CreateTrace */ +} StringTraceData; + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceObjCmd -- + * + * This function 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( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int optionIndex; + char *name, *flagOps, *p; + /* Main sub commands to 'trace' */ + static const char *traceOptions[] = { + "add", "info", "remove", +#ifndef TCL_REMOVE_OBSOLETE_TRACES + "variable", "vdelete", "vinfo", +#endif + 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); + } + 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: + case TRACE_OLD_VDELETE: { + Tcl_Obj *copyObjv[6]; + Tcl_Obj *opsList; + int code, numFlags; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + opsList = Tcl_NewObj(); + Tcl_IncrRefCount(opsList); + flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + if (numFlags == 0) { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + for (p = flagOps; *p != 0; p++) { + Tcl_Obj *opObj; + + if (*p == 'r') { + TclNewLiteralStringObj(opObj, "read"); + } else if (*p == 'w') { + TclNewLiteralStringObj(opObj, "write"); + } else if (*p == 'u') { + TclNewLiteralStringObj(opObj, "unset"); + } else if (*p == 'a') { + TclNewLiteralStringObj(opObj, "array"); + } else { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + Tcl_ListObjAppendElement(NULL, opsList, opObj); + } + copyObjv[0] = NULL; + memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); + copyObjv[4] = opsList; + if (optionIndex == TRACE_OLD_VARIABLE) { + code = (traceSubCmds[2])(interp, TRACE_ADD, objc+1, copyObjv); + } else { + code = (traceSubCmds[2])(interp, TRACE_REMOVE, objc+1, copyObjv); + } + Tcl_DecrRefCount(opsList); + return code; + } + 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_NewObj(); + 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, 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", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraceExecutionObjCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +TraceExecutionObjCmd( + 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", 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 & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + memcpy(tcmdPtr->command, command, length+1); + 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 & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC)) { + 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, NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + int numOps = 0; + Tcl_Obj *opObj; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + /* + * 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, NULL); + Tcl_IncrRefCount(elemObjPtr); + if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { + TclNewLiteralStringObj(opObj, "enter"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { + TclNewLiteralStringObj(opObj, "leave"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { + TclNewLiteralStringObj(opObj, "enterstep"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { + TclNewLiteralStringObj(opObj, "leavestep"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + if (0 == numOps) { + Tcl_DecrRefCount(elemObjPtr); + continue; + } + eachTraceObjPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_DecrRefCount(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; +} + +/* + *---------------------------------------------------------------------- + * + * TraceCommandObjCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +TraceCommandObjCmd( + 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", 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; + memcpy(tcmdPtr->command, command, length+1); + 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, NULL); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != NULL) { + int numOps = 0; + Tcl_Obj *opObj; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + /* + * 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, NULL); + Tcl_IncrRefCount(elemObjPtr); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + TclNewLiteralStringObj(opObj, "rename"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + TclNewLiteralStringObj(opObj, "delete"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + Tcl_ListObjLength(NULL, elemObjPtr, &numOps); + if (0 == numOps) { + Tcl_DecrRefCount(elemObjPtr); + continue; + } + eachTraceObjPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_DecrRefCount(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; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVariableObjCmd -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +TraceVariableObjCmd( + 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", 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) { + CombinedTraceVarInfo *ctvarPtr; + + ctvarPtr = (CombinedTraceVarInfo *) ckalloc((unsigned) + (sizeof(CombinedTraceVarInfo) + length + 1 + - sizeof(ctvarPtr->traceCmdInfo.command))); + ctvarPtr->traceCmdInfo.flags = flags; + if (objv[0] == NULL) { + ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; + } + ctvarPtr->traceCmdInfo.length = length; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; + memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); + ctvarPtr->traceInfo.traceProc = TraceVarProc; + ctvarPtr->traceInfo.clientData = (ClientData) + &ctvarPtr->traceCmdInfo; + ctvarPtr->traceInfo.flags = flags; + name = Tcl_GetString(objv[3]); + if (TraceVarEx(interp,name,NULL,(VarTrace*)ctvarPtr) != TCL_OK) { + ckfree((char *) ctvarPtr); + 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 & ~TCL_TRACE_OLD_STYLE)==flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + TraceVarProc, clientData); + 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_NewObj(); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, + clientData)) != 0) { + Tcl_Obj *opObj; + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + /* + * 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, NULL); + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + TclNewLiteralStringObj(opObj, "array"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tvarPtr->flags & TCL_TRACE_READS) { + TclNewLiteralStringObj(opObj, "read"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + TclNewLiteralStringObj(opObj, "write"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + TclNewLiteralStringObj(opObj, "unset"); + Tcl_ListObjAppendElement(NULL, elemObjPtr, opObj); + } + eachTraceObjPtr = Tcl_NewListObj(0, NULL); + 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 function can also be used to step through all of the traces on a + * particular command that have the same trace function. + * + * 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 function. 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( + 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, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by + * this function, 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 function to be + * invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command to cause a + * function 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( + 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, /* Function 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( + 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, /* Function 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) { + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + 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 function 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 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. */ +{ + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + tcmdPtr->refCount++; + + if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp) + && !Tcl_LimitExceeded(interp)) { + /* + * 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. 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. + */ + + 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 */ + /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ + } + 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)) { + int untraceFlags = tcmdPtr->flags; + Tcl_InterpState state; + + 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; + } + + /* + * We need to construct the same flags for Tcl_UntraceCommand as were + * passed to Tcl_TraceCommand. Reproduce the processing of [trace add + * execution/command]. Be careful to keep this code in sync with that. + */ + + if (untraceFlags & TCL_TRACE_ANY_EXEC) { + untraceFlags |= TCL_TRACE_DELETE; + if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC + | TCL_TRACE_LEAVE_DURING_EXEC)) { + untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + } else if (untraceFlags & TCL_TRACE_RENAME) { + untraceFlags |= TCL_TRACE_DELETE; + } + + /* + * Remove the trace since TCL_TRACE_DESTROYED tells us to, or the + * command we're tracing has just gone away. Then decrement the + * clientData refCount that was set up by trace creation. + * + * Note that we save the (return) state of the interpreter to prevent + * bizarre error messages. + */ + + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_UntraceCommand(interp, oldName, untraceFlags, + TraceCommandProc, clientData); + (void) Tcl_RestoreInterpState(interp, state); + tcmdPtr->refCount--; + } + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckExecutionTraces -- + * + * Checks on all current command execution traces, and invokes functions + * which have been registered. This function 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 function 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 functions called. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckExecutionTraces( + 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; + Tcl_InterpState state = NULL; + + if (cmdPtr->tracePtr == NULL) { + return traceCode; + } + + curLevel = 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.reverseScan = 1; + active.nextTracePtr = NULL; + tracePtr = cmdPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.reverseScan = 0; + active.nextTracePtr = tracePtr->nextPtr; + } + if (tracePtr->traceProc == TraceCommandProc) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) + tracePtr->clientData; + + if (tcmdPtr->flags != 0) { + tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; + tcmdPtr->curCode = code; + tcmdPtr->refCount++; + if (state == NULL) { + state = Tcl_SaveInterpState(interp, code); + } + traceCode = TraceExecutionProc((ClientData) tcmdPtr, interp, + curLevel, command, (Tcl_Command) cmdPtr, objc, objv); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } + } + } + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } + } + iPtr->activeCmdTracePtr = active.nextPtr; + if (state) { + (void) Tcl_RestoreInterpState(interp, state); + } + + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckInterpTraces -- + * + * Checks on all current traces, and invokes functions which have been + * registered. This function 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 function 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 functions called. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckInterpTraces( + 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; + Tcl_InterpState state = NULL; + + if ((iPtr->tracePtr == NULL) + || (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + return(traceCode); + } + + curLevel = iPtr->numLevels; + + 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.reverseScan = 1; + active.nextTracePtr = NULL; + tracePtr = iPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } + } else { + active.reverseScan = 0; + 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 (state == NULL) { + state = Tcl_SaveInterpState(interp, code); + } + + if (tracePtr->flags & + (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { + /* + * New style trace. + */ + + if (tracePtr->flags & traceFlags) { + if (tracePtr->proc == TraceExecutionProc) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) + tracePtr->clientData; + + tcmdPtr->curFlags = traceFlags; + tcmdPtr->curCode = code; + } + traceCode = (tracePtr->proc)(tracePtr->clientData, + 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 = CallTraceFunction(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); + } + } + tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + Tcl_Release((ClientData) tracePtr); + } + } + iPtr->activeInterpTracePtr = active.nextPtr; + if (state) { + if (traceCode == TCL_OK) { + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); + } + } + + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * CallTraceFunction -- + * + * Invokes a trace function registered with an interpreter. These + * functions trace command execution. Currently this trace function 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 function. + * + *---------------------------------------------------------------------- + */ + +static int +CallTraceFunction( + Tcl_Interp *interp, /* The current interpreter. */ + register Trace *tracePtr, /* Describes the trace function 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 = TclStackAlloc(interp, (unsigned) (numChars + 1)); + memcpy(commandCopy, command, (size_t) numChars); + commandCopy[numChars] = '\0'; + + /* + * Call the trace function then free allocated storage. + */ + + traceCode = (tracePtr->proc)(tracePtr->clientData, (Tcl_Interp *) iPtr, + iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv); + + TclStackFree(interp, 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 function 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 function 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 (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { + /* + * 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) && (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_DString cmd; + Tcl_DString sub; + int i, saveInterpFlags; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + + /* + * Append command with arguments. + */ + + Tcl_DStringInit(&sub); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i])); + } + 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 { + Tcl_Panic("TraceExecutionProc: bad flag combination"); + } + + /* + * Execute the command. We discard any object result the command + * returns. + */ + + saveInterpFlags = iPtr->flags; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + tcmdPtr->flags |= TCL_TRACE_EXEC_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; + + /* + * Restore the interp tracing flag to prevent cmd traces from + * affecting interp traces. + */ + + iPtr->flags = saveInterpFlags; + if (tcmdPtr->flags == 0) { + flags |= TCL_TRACE_DESTROYED; + } + 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))) { + register unsigned len = strlen(command) + 1; + + tcmdPtr->startLevel = level; + tcmdPtr->startCmd = ckalloc(len); + memcpy(tcmdPtr->startCmd, command, len); + 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(tcmdPtr->startCmd); + } + } + } + if (call) { + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } + } + return traceCode; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarProc -- + * + * This function 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 function returns an error string. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +TraceVarProc( + 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. */ +{ + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + char *result; + int code, destroy = 0; + 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. + */ + + result = NULL; + if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) + && !Tcl_LimitExceeded(interp)) { + 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. 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. + */ + + if ((flags & TCL_TRACE_DESTROYED) + && !(tvarPtr->flags & TCL_TRACE_DESTROYED)) { + destroy = 1; + 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 */ + Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); + result = (char *) errMsgObj; + } + Tcl_DStringFree(&cmd); + } + } + if (destroy && result != NULL) { + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + + Tcl_DecrRefCount(errMsgObj); + result = NULL; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateObjTrace -- + * + * Arrange for a function 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 function 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' function will be invoked, + * passing it the original client data. + * + *---------------------------------------------------------------------- + */ + +Tcl_Trace +Tcl_CreateObjTrace( + 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) + /* Function 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 function 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 function. 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 function 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( + 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, /* Function to call before executing each + * command. */ + ClientData clientData) /* Arbitrary value word to pass to proc. */ +{ + StringTraceData *data = (StringTraceData *) + ckalloc(sizeof(StringTraceData)); + + data->clientData = clientData; + data->proc = proc; + return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc); +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceProc -- + * + * Invoke a string-based trace function from an object-based callback. + * + * Results: + * None. + * + * Side effects: + * Whatever the string-based trace function does. + * + *---------------------------------------------------------------------- + */ + +static int +StringTraceProc( + 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 **) TclStackAlloc(interp, + (unsigned) ((objc + 1) * sizeof(const char *))); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; + + /* + * Invoke the command function. 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); + TclStackFree(interp, (void *) 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) +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteTrace -- + * + * Remove a trace. + * + * Results: + * None. + * + * Side effects: + * From now on there will be no more calls to the function given in + * trace. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteTrace( + Tcl_Interp *interp, /* Interpreter that contains trace. */ + Tcl_Trace trace) /* Token for trace (returned previously by + * Tcl_CreateTrace). */ +{ + Interp *iPtr = (Interp *) interp; + Trace *prevPtr, *tracePtr = (Trace *) trace; + register Trace **tracePtr2 = &(iPtr->tracePtr); + ActiveInterpTrace *activePtr; + + /* + * Locate the trace entry in the interpreter's trace list, and remove it + * from the list. + */ + + prevPtr = NULL; + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + prevPtr = *tracePtr2; + tracePtr2 = &((*tracePtr2)->nextPtr); + } + if (*tracePtr2 == NULL) { + return; + } + (*tracePtr2) = (*tracePtr2)->nextPtr; + + /* + * 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 + * TclCheckInterpTraces. + */ + + for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->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); +} + +/* + *---------------------------------------------------------------------- + * + * TclTraceVarExists -- + * + * This is called from info exists. We need to trigger read and/or array + * traces because they may end up creating a variable that doesn't + * currently exist. + * + * Results: + * A pointer to the Var structure, or NULL. + * + * Side effects: + * May fill in error messages in the interp. + * + *---------------------------------------------------------------------- + */ + +Var * +TclVarTraceExists( + Tcl_Interp *interp, /* The interpreter */ + const char *varName) /* The variable name */ +{ + Var *varPtr; + Var *arrayPtr; + + /* + * The choice of "create" flag values is delicate here, and matches the + * semantics of GetVar. Things are still not perfect, however, because if + * you do "info exists x" you get a varPtr and therefore trigger traces. + * However, if you do "info exists x(i)", then you only get a varPtr if x + * is already known to be an array. Otherwise you get NULL, and no trace + * is triggered. This matches Tcl 7.6 semantics. + */ + + varPtr = TclLookupVar(interp, varName, NULL, 0, "access", + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + + if (varPtr == NULL) { + return NULL; + } + + if ((varPtr->flags & VAR_TRACED_READ) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) { + TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, + TCL_TRACE_READS, /* leaveErrMsg */ 0); + } + + /* + * If the variable doesn't exist anymore and no-one's using it, then free + * up the relevant structures and hash table entries. + */ + + if (TclIsVarUndefined(varPtr)) { + TclCleanupVar(varPtr, arrayPtr); + return NULL; + } + + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclCallVarTraces -- + * + * This function is invoked to find and invoke relevant trace functions + * associated with a particular operation on a variable. This function + * invokes traces both on the variable and on its containing array (where + * relevant). + * + * Results: + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned and leaveErrMsg is true, then the errorInfo field of iPtr has + * information about the error placed in it. + * + * Side effects: + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +int +TclObjCallVarTraces( + Interp *iPtr, /* Interpreter containing variable. */ + register Var *arrayPtr, /* Pointer to array variable that contains the + * variable, or NULL if the variable isn't an + * element of an array. */ + Var *varPtr, /* Variable whose traces are to be invoked. */ + Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, /* Variable's two-part name. */ + int flags, /* Flags passed to trace functions: indicates + * what's happening to variable, plus maybe + * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ + int leaveErrMsg, /* If true, and one of the traces indicates an + * error, then leave an error message and + * stack trace information in *iPTr. */ + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ +{ + char *part1, *part2; + + if (!part1Ptr) { + part1Ptr = localName(iPtr->varFramePtr, index); + } + part1 = TclGetString(part1Ptr); + part2 = part2Ptr? TclGetString(part2Ptr) : NULL; + + return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, + leaveErrMsg); +} + +int +TclCallVarTraces( + Interp *iPtr, /* Interpreter containing variable. */ + register Var *arrayPtr, /* Pointer to array variable that contains the + * variable, or NULL if the variable isn't an + * element of an array. */ + Var *varPtr, /* Variable whose traces are to be invoked. */ + const char *part1, + const char *part2, /* Variable's two-part name. */ + int flags, /* Flags passed to trace functions: indicates + * what's happening to variable, plus maybe + * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ + int leaveErrMsg) /* If true, and one of the traces indicates an + * error, then leave an error message and + * stack trace information in *iPTr. */ +{ + register VarTrace *tracePtr; + ActiveVarTrace active; + char *result; + const char *openParen, *p; + Tcl_DString nameCopy; + int copiedName; + int code = TCL_OK; + int disposeFlags = 0; + Tcl_InterpState state = NULL; + Tcl_HashEntry *hPtr; + int traceflags = flags & VAR_ALL_TRACES; + + /* + * If there are already similar trace functions active for the variable, + * don't call them again. + */ + + if (TclIsVarTraceActive(varPtr)) { + return code; + } + TclSetVarTraceActive(varPtr); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; + } + + /* + * If the variable name hasn't been parsed into array name and element, do + * it here. If there really is an array element, make a copy of the + * original name so that NULLs can be inserted into it to separate the + * names (can't modify the name string in place, because the string might + * get used by the callbacks we invoke). + */ + + copiedName = 0; + if (part2 == NULL) { + for (p = part1; *p ; p++) { + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + int offset = (openParen - part1); + char *newPart1; + + Tcl_DStringInit(&nameCopy); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + newPart1 = Tcl_DStringValue(&nameCopy); + newPart1[offset] = 0; + part1 = newPart1; + part2 = newPart1 + offset + 1; + copiedName = 1; + } + break; + } + } + } + + /* + * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can + * set it correctly. + */ + + flags &= ~TCL_INTERP_DESTROYED; + + /* + * Invoke traces on the array containing the variable, if relevant. + */ + + result = NULL; + active.nextPtr = iPtr->activeVarTracePtr; + iPtr->activeVarTracePtr = &active; + Tcl_Preserve((ClientData) iPtr); + if (arrayPtr && !TclIsVarTraceActive(arrayPtr) + && (arrayPtr->flags & traceflags)) { + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr); + active.varPtr = arrayPtr; + for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + Tcl_Preserve((ClientData) tracePtr); + if (state == NULL) { + state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); + } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + /* + * Ignore errors in unset traces. + */ + + DisposeTraceResult(tracePtr->flags, result); + } else { + disposeFlags = tracePtr->flags; + code = TCL_ERROR; + } + } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } + } + } + + /* + * Invoke traces on the variable itself. + */ + + if (flags & TCL_TRACE_UNSETS) { + flags |= TCL_TRACE_DESTROYED; + } + active.varPtr = varPtr; + if (varPtr->flags & traceflags) { + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr); + tracePtr != NULL; tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + Tcl_Preserve((ClientData) tracePtr); + if (state == NULL) { + state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); + } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + /* + * Ignore errors in unset traces. + */ + + DisposeTraceResult(tracePtr->flags, result); + } else { + disposeFlags = tracePtr->flags; + code = TCL_ERROR; + } + } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } + } + } + + /* + * Restore the variable's flags, remove the record of our active traces, + * and then return. + */ + + done: + if (code == TCL_ERROR) { + if (leaveErrMsg) { + const char *verb = ""; + const char *type = ""; + + switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { + case TCL_TRACE_READS: + verb = "read"; + type = verb; + break; + case TCL_TRACE_WRITES: + verb = "set"; + type = "write"; + break; + case TCL_TRACE_ARRAY: + verb = "trace array"; + type = "array"; + break; + } + + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { + Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result); + } else { + Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC); + } + Tcl_AddErrorInfo((Tcl_Interp *)iPtr, ""); + + Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( + "\n (%s trace on \"%s%s%s%s\")", type, part1, + (part2 ? "(" : ""), (part2 ? part2 : ""), + (part2 ? ")" : "") )); + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, + Tcl_GetString((Tcl_Obj *) result)); + } else { + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); + } + iPtr->flags &= ~(ERR_ALREADY_LOGGED); + Tcl_DiscardInterpState(state); + } else { + (void) Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); + } + DisposeTraceResult(disposeFlags,result); + } else if (state) { + if (code == TCL_OK) { + code = Tcl_RestoreInterpState((Tcl_Interp *)iPtr, state); + } else { + Tcl_DiscardInterpState(state); + } + } + + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; + } + if (copiedName) { + Tcl_DStringFree(&nameCopy); + } + TclClearVarTraceActive(varPtr); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + iPtr->activeVarTracePtr = active.nextPtr; + Tcl_Release((ClientData) iPtr); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * DisposeTraceResult-- + * + * This function is called to dispose of the result returned from a trace + * function. The disposal method appropriate to the type of result is + * determined by flags. + * + * Results: + * None. + * + * Side effects: + * The memory allocated for the trace result may be freed. + * + *---------------------------------------------------------------------- + */ + +static void +DisposeTraceResult( + int flags, /* Indicates type of result to determine + * proper disposal method. */ + char *result) /* The result returned from a trace function + * to be disposed. */ +{ + if (flags & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(result); + } else if (flags & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) result); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName with the + * given flags, proc, and clientData, then that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar2 -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by part1 and part2 with + * the given flags, proc, and clientData, then that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar2( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags, /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + VarTrace *prevPtr, *nextPtr; + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + ActiveVarTrace *activePtr; + int flagMask, allFlags = 0; + Tcl_HashEntry *hPtr; + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ NULL, + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL || !(varPtr->flags & VAR_ALL_TRACES & flags)) { + return; + } + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + flags &= flagMask; + + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); + for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + goto updateFlags; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + break; + } + allFlags |= tracePtr->flags; + } + + /* + * 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 + * TclCallVarTraces. + */ + + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + nextPtr = tracePtr->nextPtr; + if (prevPtr == NULL) { + if (nextPtr) { + Tcl_SetHashValue(hPtr, nextPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } + } else { + prevPtr->nextPtr = nextPtr; + } + tracePtr->nextPtr = NULL; + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + + for (tracePtr = nextPtr; tracePtr != NULL; + tracePtr = tracePtr->nextPtr) { + allFlags |= tracePtr->flags; + } + + updateFlags: + varPtr->flags &= ~VAR_ALL_TRACES; + if (allFlags & VAR_ALL_TRACES) { + varPtr->flags |= (allFlags & VAR_ALL_TRACES); + } else if (TclIsVarUndefined(varPtr)) { + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + TclCleanupVar(varPtr, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a variable. + * This function can also be used to step through all of the traces on a + * particular variable that have the same trace function. + * + * Results: + * The return value is the clientData value associated with a trace on + * the given variable. Information will only be returned for a trace with + * proc as trace function. 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 variable doesn't + * exist, or if there are no (more) traces for it, then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ +{ + return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, + prevClientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo2 -- + * + * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of + * one. + * + * Results: + * Same as Tcl_VarTraceInfo. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo2( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *part1, /* Name of variable or array. */ + const char *part2, /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ +{ + Interp *iPtr = (Interp *) interp; + register VarTrace *tracePtr; + Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; + + varPtr = TclLookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL, + /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); + + if (hPtr) { + tracePtr = Tcl_GetHashValue(hPtr); + + 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_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that future + * references to the variable will be intermediated by proc. See the + * manual entry for complete details on the calling sequence for proc. + * The variable's flags are updated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function to call when specified ops are + * invoked upon varName. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar2 -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such that + * future references to the variable will be intermediated by proc. See + * the manual entry for complete details on the calling sequence for + * proc. The variable's flags are updated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar2( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags, /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function to call when specified ops are + * invoked upon varName. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + int result; + + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags; + + result = TraceVarEx(interp, part1, part2, tracePtr); + + if (result != TCL_OK) { + ckfree((char *) tracePtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraceVarEx -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such that + * future references to the variable will be intermediated by the + * traceProc listed in tracePtr. See the manual entry for complete + * details on the calling sequence for proc. + * + *---------------------------------------------------------------------- + */ + +static int +TraceVarEx( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *part1, /* Name of scalar variable or array. */ + const char *part2, /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + register VarTrace *tracePtr)/* Structure containing flags, traceProc and + * clientData fields. Others should be left + * blank. Will be ckfree()d (eventually) if + * this function returns TCL_OK, and up to + * caller to free if this function returns + * TCL_ERROR. */ +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; + int flagMask, isNew; + Tcl_HashEntry *hPtr; + + /* + * We strip 'flags' down to just the parts which are relevant to + * TclLookupVar, to avoid conflicts between trace flags and internal + * namespace flags such as 'TCL_FIND_ONLY_NS'. This can now occur since we + * have trace flags with values 0x1000 and higher. + */ + + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, + (tracePtr->flags & flagMask) | TCL_LEAVE_ERR_MSG, + "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Check for a nonsense flag combination. Note that this is a Tcl_Panic() + * because there should be no code path that ever sets both flags. + */ + + if ((tracePtr->flags&TCL_TRACE_RESULT_DYNAMIC) + && (tracePtr->flags&TCL_TRACE_RESULT_OBJECT)) { + Tcl_Panic("bad result flag combination"); + } + + /* + * Set up trace information. + */ + + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + tracePtr->flags = tracePtr->flags & flagMask; + + hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) varPtr, &isNew); + if (isNew) { + tracePtr->nextPtr = NULL; + } else { + tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr); + } + Tcl_SetHashValue(hPtr, (char *) tracePtr); + + /* + * Mark the variable as traced so we know to call them. + */ + + varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES); + + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |