summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls14
-rw-r--r--generic/tcl.h15
-rw-r--r--generic/tclBasic.c126
-rw-r--r--generic/tclCmdMZ.c1019
-rw-r--r--generic/tclDecls.h32
-rw-r--r--generic/tclInt.h62
-rw-r--r--generic/tclStubInit.c5
-rw-r--r--generic/tclVar.c56
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) {