diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 14 | ||||
| -rw-r--r-- | generic/tcl.h | 15 | ||||
| -rw-r--r-- | generic/tclBasic.c | 126 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 1019 | ||||
| -rw-r--r-- | generic/tclDecls.h | 32 | ||||
| -rw-r--r-- | generic/tclInt.h | 62 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 5 | ||||
| -rw-r--r-- | generic/tclVar.c | 56 |
8 files changed, 1145 insertions, 184 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index ea5b6d2..e71c6ee 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.38 2000/07/22 01:53:23 ericm Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.39 2000/08/25 02:04:27 ericm Exp $ library tcl @@ -1406,6 +1406,18 @@ declare 405 generic { declare 406 generic { void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) } +declare 407 generic { + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, char *varName, \ + int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData) +} +declare 408 generic { + int Tcl_TraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) +} +declare 409 generic { + void Tcl_UntraceCommand(Tcl_Interp *interp, char *varName, int flags, \ + Tcl_CommandTraceProc *proc, ClientData clientData) +} ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index eb8329a..b0b74a4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.76 2000/08/15 00:08:36 ericm Exp $ + * RCS: @(#) $Id: tcl.h,v 1.77 2000/08/25 02:04:27 ericm Exp $ */ #ifndef _TCL @@ -603,6 +603,8 @@ typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags)); +typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *oldName, char *newName, int flags)); typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd)); @@ -926,6 +928,17 @@ typedef struct Tcl_DString { #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 +#ifndef TCL_REMOVE_OBSOLETE_TRACES +/* Required to support old variable/vdelete/vinfo traces */ +#define TCL_TRACE_OLD_STYLE 0x1000 +#endif + +/* + * Flag values passed to command-related procedures. + */ + +#define TCL_TRACE_RENAME 0x2000 +#define TCL_TRACE_DELETE 0x4000 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e9a52e6..47862de 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.28 2000/05/23 22:10:49 ericm Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.29 2000/08/25 02:04:28 ericm Exp $ */ #include "tclInt.h" @@ -25,6 +25,9 @@ * Static procedures in this file: */ +static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, + Command *cmdPtr, char *oldName, + char* newName, int flags)); static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ProcessUnexpectedResult _ANSI_ARGS_(( Tcl_Interp *interp, int returnCode)); @@ -335,6 +338,7 @@ Tcl_CreateInterp() iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; + iPtr->activeCmdTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ @@ -447,8 +451,9 @@ Tcl_CreateInterp() } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } @@ -1498,8 +1503,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1659,8 +1665,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1975,6 +1982,8 @@ TclRenameCommand(interp, oldName, newName) return result; } + CallCommandTraces(iPtr,cmdPtr,oldName,newName,TCL_TRACE_RENAME); + /* * The new command name is okay, so remove the command from its * current namespace. This is like deleting the command, so bump @@ -2281,7 +2290,7 @@ Tcl_DeleteCommandFromToken(interp, cmd) * flag allows us to detect these cases and skip nested deletes. */ - if (cmdPtr->deleted) { + if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the @@ -2293,6 +2302,33 @@ Tcl_DeleteCommandFromToken(interp, cmd) return 0; } + /* + * We must delete this command, even though both traces and + * delete procs may try to avoid this (renaming the command etc). + * Also traces and delete procs may try to delete the command + * themsevles. This flag declares that a delete is in progress + * and that recursive deletes should be ignored. + */ + cmdPtr->flags |= CMD_IS_DELETED; + + /* + * Call trace procedures for the command being deleted. Then delete + * its traces. + */ + + if (cmdPtr->tracePtr != NULL) { + CommandTrace *tracePtr; + CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); + /* Now delete these traces */ + tracePtr = cmdPtr->tracePtr; + while (tracePtr != NULL) { + CommandTrace *nextPtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + tracePtr = nextPtr; + } + cmdPtr->tracePtr = NULL; + } + /* * If the command being deleted has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This @@ -2306,7 +2342,6 @@ Tcl_DeleteCommandFromToken(interp, cmd) iPtr->compileEpoch++; } - cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command @@ -2381,6 +2416,75 @@ Tcl_DeleteCommandFromToken(interp, cmd) TclCleanupCommand(cmdPtr); return 0; } +static char * +CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) + Interp *iPtr; /* Interpreter containing variable. */ + Command *cmdPtr; /* Variable whose traces are to be + * invoked. */ + char *oldName; /* Command's old name, or NULL if we + * must get the name from cmdPtr */ + char *newName; /* Command's new name, or NULL if + * the command is not being renamed */ + int flags; /* Flags passed to trace procedures: + * indicates what's happening to variable, + * plus other stuff like TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and + * TCL_INTERP_DESTROYED. */ +{ + register CommandTrace *tracePtr; + ActiveCommandTrace active; + char *result; + if (cmdPtr->flags & CMD_TRACE_ACTIVE) { + /* + * While a rename trace is active, we will not process any more + * rename traces; while a delete trace is active we will not + * process any more delete traces + */ + if (cmdPtr->flags & TCL_TRACE_RENAME) { + flags &= ~TCL_TRACE_RENAME; + } + if (cmdPtr->flags & TCL_TRACE_DELETE) { + flags &= ~TCL_TRACE_DELETE; + } + if (flags == 0) { + return NULL; + } + } + cmdPtr->flags |= CMD_TRACE_ACTIVE; + cmdPtr->refCount++; + + result = NULL; + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + active.cmdPtr = cmdPtr; + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + cmdPtr->flags |= tracePtr->flags; + if (oldName == NULL) { + oldName = Tcl_GetCommandName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr); + } + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); + cmdPtr->flags &= ~tracePtr->flags; + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + cmdPtr->flags &= ~CMD_TRACE_ACTIVE; + cmdPtr->refCount--; + iPtr->activeCmdTracePtr = active.nextPtr; + return result; +} + /* *---------------------------------------------------------------------- @@ -3870,11 +3974,11 @@ Tcl_CreateTrace(interp, level, proc, clientData) iPtr->flags |= DONT_COMPILE_CMDS_INLINE; tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->nextPtr = iPtr->tracePtr; - iPtr->tracePtr = tracePtr; + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->nextPtr = iPtr->tracePtr; + iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cc17067..2421158 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.27 2000/05/26 08:51:11 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.28 2000/08/25 02:04:28 ericm Exp $ */ #include "tclInt.h" @@ -55,12 +55,43 @@ typedef struct { } TraceVarInfo; /* + * The same structure is used for command traces at present + */ + +typedef TraceVarInfo TraceCommandInfo; + +/* * Forward declarations for procedures defined in this file: */ +typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, + int optionIndex, int objc, Tcl_Obj *CONST objv[])); + +Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; +Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; + +/* + * Each subcommand has a number of 'types' to which it can apply. + * Currently 'command' and 'variable' are the only + * types supported. These two arrays MUST be kept in sync! + * In the future we may provide an API to add to the list of + * supported trace types. + */ +static char *traceTypeOptions[] = { + "command", "variable", (char*) NULL +}; +static Tcl_TraceTypeObjCmd* traceSubCmds[] = { + TclTraceCommandObjCmd, + TclTraceVariableObjCmd, +}; + static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); +static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *oldName, char *newName, + int flags)); + /* *---------------------------------------------------------------------- @@ -2469,13 +2500,17 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. + * + * Standard syntax as of Tcl 8.4 is + * + * trace {add|remove|list} {command|variable} name ops cmd + * * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. - * *---------------------------------------------------------------------- */ @@ -2488,17 +2523,26 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex, commandLength; - char *name, *rwuOps, *command, *p; + char *name, *flagOps, *command, *p; size_t length; + /* Main sub commands to 'trace' */ static char *traceOptions[] = { - "variable", "vdelete", "vinfo", (char *) NULL + "add", "list", "remove", +#ifndef TCL_REMOVE_OBSOLETE_TRACES + "variable", "vdelete", "vinfo", +#endif + (char *) NULL }; + /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { - TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO + TRACE_ADD, TRACE_LIST, 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 ...]"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -2507,33 +2551,449 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { - case TRACE_VARIABLE: { - int flags; - TraceVarInfo *tvarPtr; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; + case TRACE_ADD: + case TRACE_REMOVE: + case TRACE_LIST: { + /* + * All sub commands of trace add/remove must take at least + * one more argument. Beyond that we let the subcommand itself + * control the argument structure. + */ + int typeIndex; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, + "option", 0, &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + break; + } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + case TRACE_OLD_VARIABLE: { + int flags; + TraceVarInfo *tvarPtr; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; + } + case TRACE_OLD_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; - flags = 0; - rwuOps = Tcl_GetString(objv[3]); - for (p = rwuOps; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; + } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } + } + break; + } + case TRACE_OLD_VINFO: { + ClientData clientData; + char ops[5]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + *p = 'a'; + p++; + } + *p = '\0'; + + /* + * Build a pair (2-item list) with the ops string as + * the first obj element and the tvarPtr->command string + * as the second obj element. Append the pair (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewStringObj(ops, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } +#endif /* TCL_REMOVE_OBSOLETE_TRACES */ + } + return TCL_OK; + + badVarOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be one or more of rwua", (char *) NULL); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceCommandObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|list} 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 list) being performed; + * may add or remove command traces on a command. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceCommandObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, list 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_LIST, TRACE_REMOVE }; + static char *opStrings[] = { "delete", "rename", (char *) NULL }; + enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of delete or rename", TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_CMD_RENAME: + flags |= TCL_TRACE_RENAME; + break; + case TRACE_CMD_DELETE: + flags |= TCL_TRACE_DELETE; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->errMsg = NULL; + tcmdPtr->length = length; + 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; + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + 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); + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + } + ckfree((char *) tcmdPtr); + break; } } - if (flags == 0) { - goto badOps; + } + break; + } + case TRACE_LIST: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("rename",6)); } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("delete",6)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceVariableObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|list} 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 list) being performed; + * may add or remove variable traces on a variable. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceVariableObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, list 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_LIST, TRACE_REMOVE }; + static char *opStrings[] = { "array", "read", "unset", "write", + (char *) NULL }; + enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, + TRACE_VAR_WRITE }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of array, read, unset, or write", + TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen ; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_VAR_ARRAY: + flags |= TCL_TRACE_ARRAY; + break; + case TRACE_VAR_READ: + flags |= TCL_TRACE_READS; + break; + case TRACE_VAR_UNSET: + flags |= TCL_TRACE_UNSETS; + break; + case TRACE_VAR_WRITE: + flags |= TCL_TRACE_WRITES; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); @@ -2542,55 +3002,27 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[2]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } - break; - } - case TRACE_VDELETE: { - int flags; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - flags = 0; - rwuOps = Tcl_GetString(objv[3]); - for (p = rwuOps; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } - + } 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. */ - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; - clientData = 0; - name = Tcl_GetString(objv[2]); + TraceVarInfo *tvarPtr; + ClientData clientData = 0; + name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + if ((tvarPtr->length == length) + && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, @@ -2602,67 +3034,339 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) break; } } - break; } - case TRACE_VINFO: { - ClientData clientData; - char ops[4]; - Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + break; + } + case TRACE_LIST: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("array", 5)); } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; - name = Tcl_GetString(objv[2]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { + if (tvarPtr->flags & TCL_TRACE_READS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("read", 4)); + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("write", 5)); + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("unset", 5)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} - pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; - } - *p = '\0'; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandTraceInfo -- + * + * Return the clientData value associated with a trace on a + * command. This procedure can also be used to step through + * all of the traces on a particular command that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given command. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the command + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * 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. - */ +ClientData +Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + char *cmdName; /* Name of command. */ + int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + Command *cmdPtr; + register CommandTrace *tracePtr; - 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); + 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; } - default: { - panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); - } + } } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCommand -- + * + * Arrange for rename/deletes to a command to cause a + * procedure to be invoked, which can monitor the operations. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the command given by cmdName, such that + * future changes to the command will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which command is + * to be traced. */ + char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + 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); + tracePtr->nextPtr = cmdPtr->tracePtr; + cmdPtr->tracePtr = tracePtr; 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. + * + *---------------------------------------------------------------------- + */ - badOps: - Tcl_AppendResult(interp, "bad operations \"", rwuOps, - "\": should be one or more of rwu", (char *) NULL); - return TCL_ERROR; +void +Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register CommandTrace *tracePtr; + CommandTrace *prevPtr; + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + ActiveCommandTrace *activePtr; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE); + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallTraces. + */ + + for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + cmdPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TraceCommandProc -- + * + * This procedure is called to handle command changes that have + * been traced using the "trace" command. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TraceCommandProc(clientData, interp, oldName, newName, flags) + ClientData clientData; /* Information about the command trace. */ + Tcl_Interp *interp; /* Interpreter containing command. */ + char *oldName; /* Name of command being changed. */ + 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. */ +{ + Tcl_SavedResult state; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + tcmdPtr->errMsg = NULL; + } + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + /* + * Generate a command to execute by appending list elements + * for the old and new command name and the operation. + */ + + if (newName == NULL) { + newName = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, newName); + if (flags & TCL_TRACE_RENAME) { + Tcl_DStringAppend(&cmd, " rename", 7); + } else if (flags & TCL_TRACE_DELETE) { + Tcl_DStringAppend(&cmd, " delete", 7); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->errMsg != NULL) { + ckfree(tcmdPtr->errMsg); + } + ckfree((char *) tcmdPtr); + } + return; } /* @@ -2706,50 +3410,67 @@ TraceVarProc(clientData, interp, name1, name2, flags) tvarPtr->errMsg = NULL; } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if (tvarPtr->length != (size_t) 0) { + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. + */ - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. The five - * extra characters are for three space, the opcode character, - * and the terminating null. - */ + if (name2 == NULL) { + name2 = ""; + } + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, name2); +#ifndef TCL_REMOVE_OBSOLETE_TRACES + if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " a", 2); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " w", 2); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " u", 2); + } + } else { +#endif + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " array", 6); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " read", 5); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " write", 6); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " unset", 6); + } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + } +#endif + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ - if (name2 == NULL) { - name2 = ""; - } - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); - Tcl_DStringAppendElement(&cmd, name1); - Tcl_DStringAppendElement(&cmd, name2); - 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); - } + Tcl_SaveResult(interp, &state); - /* - * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. - */ + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { /* copy error msg to result */ + char *string; + int length; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); + result = tvarPtr->errMsg; + } - Tcl_SaveResult(interp, &state); + Tcl_RestoreResult(interp, &state); - code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); - if (code != TCL_OK) { /* copy error msg to result */ - char *string; - int length; - - string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); - tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); - memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); - result = tvarPtr->errMsg; + Tcl_DStringFree(&cmd); } - - Tcl_RestoreResult(interp, &state); - - Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { result = NULL; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8b041c7..fd355df 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.39 2000/07/22 01:53:24 ericm Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.40 2000/08/25 02:04:28 ericm Exp $ */ #ifndef _TCLDECLS @@ -1268,6 +1268,21 @@ EXTERN void Tcl_InitHashTableEx _ANSI_ARGS_(( /* 406 */ EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); +/* 407 */ +EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_(( + Tcl_Interp * interp, char * varName, + int flags, Tcl_CommandTraceProc * procPtr, + ClientData prevClientData)); +/* 408 */ +EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); +/* 409 */ +EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1742,6 +1757,9 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 404 */ void (*tcl_InitHashTableEx) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 405 */ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 406 */ + ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 407 */ + int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 408 */ + void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 409 */ } TclStubs; #ifdef __cplusplus @@ -3415,6 +3433,18 @@ extern TclStubs *tclStubsPtr; #define Tcl_InitObjHashTable \ (tclStubsPtr->tcl_InitObjHashTable) /* 406 */ #endif +#ifndef Tcl_CommandTraceInfo +#define Tcl_CommandTraceInfo \ + (tclStubsPtr->tcl_CommandTraceInfo) /* 407 */ +#endif +#ifndef Tcl_TraceCommand +#define Tcl_TraceCommand \ + (tclStubsPtr->tcl_TraceCommand) /* 408 */ +#endif +#ifndef Tcl_UntraceCommand +#define Tcl_UntraceCommand \ + (tclStubsPtr->tcl_UntraceCommand) /* 409 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index bb3e32d..c4858d4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.49 2000/08/10 18:25:15 davidg Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.50 2000/08/25 02:04:29 ericm Exp $ */ #ifndef _TCLINT @@ -270,6 +270,35 @@ typedef struct VarTrace { } VarTrace; /* + * The following structure defines a command trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a command. + */ + +typedef struct CommandTrace { + Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on command. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ + struct CommandTrace *nextPtr; /* Next in list of traces associated with + * a particular command. */ +} CommandTrace; + +typedef struct ActiveCommandTrace { + struct Command *cmdPtr; /* Variable that's being traced. */ + struct ActiveCommandTrace *nextPtr; + /* Next in list of all active variable + * traces for the interpreter, or NULL + * if no more. */ + CommandTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveCommandTrace; + +/* * When a variable trace is active (i.e. its associated procedure is * executing), one of the following structures is linked into a list * associated with the variable's interpreter. The information in @@ -1020,10 +1049,8 @@ typedef struct Command { /* Procedure invoked when deleting command * to, e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ - int deleted; /* Means that the command is in the process - * of being deleted (its deleteProc is - * currently executing). Other attempts to - * delete the command should be ignored. */ + int flags; /* Miscellaneous bits of information about + * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands @@ -1031,9 +1058,31 @@ typedef struct Command { * command. The list is used to remove all * those imported commands when deleting * this "real" command. */ + CommandTrace *tracePtr; /* First in list of all traces set for this + * command. */ } Command; /* + * Flag bits for commands. + * + * CMD_IS_DELETED - Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Other attempts to + * delete the command should be ignored. + * CMD_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a rename/delete change. + * See the two flags below for which is + * currently being processed. + * TCL_TRACE_RENAME - A rename trace is in progress. Further + * recursive renames will not be traced. + * TCL_TRACE_DELETE - A delete trace is in progress. Further + * recursive deletes will not be traced. + * (these last two flags are defined in tcl.h) + */ +#define CMD_IS_DELETED 0x1 +#define CMD_TRACE_ACTIVE 0x2 + +/* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- @@ -1248,6 +1297,9 @@ typedef struct Interp { * accessed directly; see comment above. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + ActiveCommandTrace *activeCmdTracePtr; + /* First in list of active command traces for + * interp, or NULL if no active traces. */ /* * Statistical information about the bytecode compiler and interpreter's * operation. diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7a76c9b..c927969 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.42 2000/07/26 01:30:59 davidg Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.43 2000/08/25 02:04:29 ericm Exp $ */ #include "tclInt.h" @@ -809,6 +809,9 @@ TclStubs tclStubs = { Tcl_CreateHashEntry, /* 404 */ Tcl_InitHashTableEx, /* 405 */ Tcl_InitObjHashTable, /* 406 */ + Tcl_CommandTraceInfo, /* 407 */ + Tcl_TraceCommand, /* 408 */ + Tcl_UntraceCommand, /* 409 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index 8e431c7..48fd89a 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.21 2000/08/21 01:37:51 ericm Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.22 2000/08/25 02:04:29 ericm Exp $ */ #include "tclInt.h" @@ -2309,8 +2309,17 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; - - varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + int flagMask; + + /* + * 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 '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, + (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -2320,14 +2329,17 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) * Set up trace information. */ - tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + flagMask = (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY); - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & flagMask; + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; return TCL_OK; } @@ -2403,17 +2415,31 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - - varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), + int flagMask; + + /* + * 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*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + + /* + * 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; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + flags &= flagMask; for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { |