tclTrace.c Go to the documentation of this file. /* * 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 2007/12/13 15:23:20 dgp 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); } strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to see if * there's one with the given command. If so, then delete the * first one that matches. */ TraceCommandInfo *tcmdPtr; ClientData clientData = NULL; name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; /* * In checking the 'flags' field we must remove any extraneous * flags which may have been temporarily added by various * pieces of the trace mechanism. */ if ((tcmdPtr->length == length) && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (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; strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, (ClientData) tcmdPtr) != TCL_OK) { ckfree((char *) tcmdPtr); return TCL_ERROR; } } else { /* * Search through all of our traces on this command to see if * there's one with the given command. If so, then delete the * first one that matches. */ TraceCommandInfo *tcmdPtr; ClientData clientData = NULL; name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if ((--tcmdPtr->refCount) <= 0) { ckfree((char *) tcmdPtr); } break; } } } break; } case TRACE_INFO: { ClientData clientData; Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; if (objc != 4) { Tcl_WrongNumArgs(interp, 3, objv, "name"); return TCL_ERROR; } clientData = NULL; name = Tcl_GetString(objv[3]); /* * First ensure the name given is valid. */ if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } resultListPtr = Tcl_NewListObj(0, 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; strcpy(ctvarPtr->traceCmdInfo.command, command); 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 *type = ""; Tcl_Obj *options = Tcl_GetReturnOptions((Tcl_Interp *)iPtr, code); Tcl_Obj *errorInfoKey, *errorInfo; TclNewLiteralStringObj(errorInfoKey, "-errorinfo"); Tcl_IncrRefCount(errorInfoKey); Tcl_DictObjGet(NULL, options, errorInfoKey, &errorInfo); Tcl_IncrRefCount(errorInfo); Tcl_DictObjRemove(NULL, options, errorInfoKey); if (Tcl_IsShared(errorInfo)) { Tcl_DecrRefCount(errorInfo); errorInfo = Tcl_DuplicateObj(errorInfo); Tcl_IncrRefCount(errorInfo); } Tcl_AppendToObj(errorInfo, "\n (", -1); switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { case TCL_TRACE_READS: type = "read"; Tcl_AppendToObj(errorInfo, type, -1); break; case TCL_TRACE_WRITES: type = "set"; Tcl_AppendToObj(errorInfo, "write", -1); break; case TCL_TRACE_ARRAY: type = "trace array"; Tcl_AppendToObj(errorInfo, "array", -1); break; } if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, Tcl_GetString((Tcl_Obj *) result)); } else { TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); } Tcl_AppendToObj(errorInfo, " trace on \"", -1); Tcl_AppendToObj(errorInfo, part1, -1); if (part2 != NULL) { Tcl_AppendToObj(errorInfo, "(", -1); Tcl_AppendToObj(errorInfo, part1, -1); Tcl_AppendToObj(errorInfo, ")", -1); } Tcl_AppendToObj(errorInfo, "\")", -1); Tcl_DictObjPut(NULL, options, errorInfoKey, errorInfo); Tcl_DecrRefCount(errorInfoKey); Tcl_DecrRefCount(errorInfo); code = Tcl_SetReturnOptions((Tcl_Interp *)iPtr, options); 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; } 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: */

• ソフトウェア開発
• ホームページ制作
• Doxygen版
• STLport版