diff options
| -rw-r--r-- | ChangeLog | 36 | ||||
| -rw-r--r-- | doc/TraceVar.3 | 48 | ||||
| -rw-r--r-- | generic/tcl.h | 5 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 55 | ||||
| -rw-r--r-- | generic/tclVar.c | 253 | ||||
| -rw-r--r-- | tests/trace.test | 23 |
6 files changed, 337 insertions, 83 deletions
@@ -1,3 +1,39 @@ +2001-11-19 Donal K. Fellows <fellowsd@cs.man.ac.uk> + + * tests/trace.test (trace-8.8): Added adapted version of Bug + #219393 as new test; the test won't reliably show up the old + problem unless it is being run under something like Purify, but + something is better than nothing... + + * generic/tclVar.c (Tcl_TraceVar2, Tcl_UntraceVar2): Added missing + mask bits for trace result type and a check for a nonsense flag + combination. + * generic/tclCmdMZ.c (TraceVarProc): Added missing test for NULL + when deleting a trace that doesn't cause an error. + + * doc/TraceVar.3: Added documentation for change due to TIP#68. + + * generic/tclCmdMZ.c (TraceVarInfo): Removed problematic errMsg + field from structure. + (TraceVarProc): Removed references to errMsg field and changed + handling of errors so that they returned a Tcl_Obj* containing the + error string. This minimizes the number of calls to the memory + management subsystem. + (TclTraceCommandObjCmd, TraceCommandProc): Removed references to + errMsg field which was never used in command traces in any case. + (Tcl_TraceObjCmd, TclTraceVariableObjCmd): Removed references to + errMsg field and made variable traces register with + TCL_TRACE_RESULT_OBJECT bit set. + + * generic/tcl.h (TCL_TRACE_RESULT_DYNAMIC,TCL_TRACE_RESULT_OBJECT): + New constants to define how to handle the strings returned from + trace callbacks [TIP#68] + * generic/tclVar.c (CallTraces, Tcl_GetVar2Ex, TclGetIndexedScalar, + TclGetElementOfIndexedArray, Tcl_SetVar2Ex, TclSetIndexedScalar, + TclSetElementOfIndexedArray, Tcl_UnsetVar2, Tcl_ArrayObjCmd, + TclDeleteVars, TclDeleteCompiledLocalVars, DeleteArray, + TclVarTraceExists): Support for those new trace flags. + 2001-11-16 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCompCmds.c: patch for [Bug 483309] (petasis). diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 226a460..b8c5efb 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: TraceVar.3,v 1.4 2000/04/14 23:01:54 hobbs Exp $ +'\" RCS: @(#) $Id: TraceVar.3,v 1.5 2001/11/19 14:35:54 dkf Exp $ '\" .so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" @@ -43,8 +43,9 @@ If the name references an element of an array, then it must be in writable memory: Tcl will make temporary modifications to it while looking up the name. .AP int flags in -OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and -TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, and TCL_GLOBAL_ONLY. +OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, +TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, +TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in @@ -84,6 +85,11 @@ Normally, the variable will be looked up at the current level of procedure call; if this bit is set then the variable will be looked up at global level, ignoring any active procedures. .TP +\fBTCL_NAMESPACE_ONLY\fR +Normally, the variable will be looked up at the current level of +procedure call; if this bit is set then the variable will be looked +up in the current namespace, ignoring any active procedures. +.TP \fBTCL_TRACE_READS\fR Invoke \fIproc\fR whenever an attempt is made to read the variable. .TP @@ -102,6 +108,21 @@ Invoke \fIproc\fR whenever the array command is invoked. This gives the trace procedure a chance to update the array before array names or array get is called. Note that this is called before an array set, but that will trigger write traces. +.VS 8.4 +.TP +\fBTCL_TRACE_RESULT_DYNAMIC\fR +The result of invoking the \fIproc\fR is a dynamically allocated +string that will be released by the Tcl library via a call to +\fBckfree\fR. Must not be specified at the same time as +TCL_TRACE_RESULT_OBJECT. +.TP +\fBTCL_TRACE_RESULT_OBJECT\fR +The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*) +with a reference count of at least one. The ownership of that +reference will be transferred to the Tcl core for release (when the +core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must +not be specified at the same time as TCL_TRACE_RESULT_DYNAMIC. +.VE 8.4 .PP Whenever one of the specified operations occurs on the variable, \fIproc\fR will be invoked. @@ -135,6 +156,11 @@ accessed is a global one not accessible from the current level of procedure call: the trace procedure will need to pass this flag back to variable-related procedures like \fBTcl_GetVar\fR if it attempts to access the variable. +The bit TCL_NAMESPACE_ONLY will be set whenever the variable being +accessed is a namespace one not accessible from the current level of +procedure call: the trace procedure will need to pass this flag +back to variable-related procedures like \fBTcl_GetVar\fR if it +attempts to access the variable. The bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see @@ -159,9 +185,10 @@ traces set on a given variable. The return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR associated with a particular trace. The trace must be on the variable specified by the \fIinterp\fR, -\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY -bit from \fIflags\fR is used; other bits are ignored) and its trace procedure -must the same as the \fIproc\fR argument. +\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY and +TCL_NAMESPACE_ONLY bits from \fIflags\fR is used; other bits are +ignored) and its trace procedure must the same as the \fIproc\fR +argument. If the \fIprevClientData\fR argument is NULL then the return value corresponds to the first (most recently created) matching trace, or NULL if there are no matching traces. @@ -297,7 +324,14 @@ successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string -containing an error message. +containing an error message, +.VS 8.4 +unless (\fIexactly\fR one of) the TCL_TRACE_RESULT_DYNAMIC and +TCL_TRACE_RESULT_OBJECT flags is set, which specify that the result is +either a dynamic string (to be released with \fBckfree\fR) or a +Tcl_Obj* (cast to char* and to be released with +\fBTcl_DecrRefCount\fR) containing the error message. +.VE 8.4 If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. diff --git a/generic/tcl.h b/generic/tcl.h index cb5c9d5..f960f51 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.104 2001/10/15 17:34:35 hobbs Exp $ + * RCS: @(#) $Id: tcl.h,v 1.105 2001/11/19 14:35:54 dkf Exp $ */ #ifndef _TCL @@ -942,6 +942,9 @@ typedef struct Tcl_DString { /* Required to support old variable/vdelete/vinfo traces */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif +/* Indicate the semantics of the result of a trace */ +#define TCL_TRACE_RESULT_DYNAMIC 0x8000 +#define TCL_TRACE_RESULT_OBJECT 0x10000 /* * Flag values passed to command-related procedures. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7ac9677..836c080 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.48 2001/10/16 05:31:17 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.49 2001/11/19 14:35:54 dkf Exp $ */ #include "tclInt.h" @@ -27,8 +27,6 @@ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ - char *errMsg; /* Error message returned from Tcl command, - * or NULL. Malloc'ed. */ size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to @@ -2806,9 +2804,8 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[2]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, @@ -2864,11 +2861,9 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) if ((tvarPtr->length == length) && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { - Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + Tcl_UntraceVar(interp, name, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - } ckfree((char *) tvarPtr); break; } @@ -3019,7 +3014,6 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + length + 1)); tcmdPtr->flags = flags; - tcmdPtr->errMsg = NULL; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); @@ -3050,9 +3044,6 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); - if (tcmdPtr->errMsg != NULL) { - ckfree(tcmdPtr->errMsg); - } ckfree((char *) tcmdPtr); break; } @@ -3198,9 +3189,8 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, @@ -3225,11 +3215,9 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { - Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + Tcl_UntraceVar(interp, name, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - } ckfree((char *) tvarPtr); break; } @@ -3521,10 +3509,6 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) 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 @@ -3561,9 +3545,6 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { - if (tcmdPtr->errMsg != NULL) { - ckfree(tcmdPtr->errMsg); - } ckfree((char *) tcmdPtr); } return; @@ -3605,10 +3586,6 @@ TraceVarProc(clientData, interp, name1, name2, flags) Tcl_DString cmd; result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - tvarPtr->errMsg = NULL; - } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { if (tvarPtr->length != (size_t) 0) { /* @@ -3658,13 +3635,9 @@ TraceVarProc(clientData, interp, name1, name2, flags) 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; + register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); + result = (char *) errMsgObj; } Tcl_RestoreResult(interp, &state); @@ -3673,9 +3646,11 @@ TraceVarProc(clientData, interp, name1, name2, flags) } } if (flags & TCL_TRACE_DESTROYED) { - result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); + if (result != NULL) { + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + + Tcl_DecrRefCount(errMsgObj); + result = NULL; } ckfree((char *) tvarPtr); } diff --git a/generic/tclVar.c b/generic/tclVar.c index 530b3d8..31437e7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,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.40 2001/11/14 23:17:04 hobbs Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.41 2001/11/19 14:35:54 dkf Exp $ */ #include "tclInt.h" @@ -42,7 +42,7 @@ static char *isArrayElement = "name refers to an element in an array"; static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, Var *varPtr, char *part1, char *part2, - int flags)); + int flags, int *resultTypePtr)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); @@ -634,11 +634,23 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + int resultType; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS, + &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "read", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, part1, part2, "read", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, part1, part2, "read", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); } goto errorReturn; } @@ -758,11 +770,23 @@ TclGetIndexedScalar(interp, localIndex, flags) */ if (varPtr->tracePtr != NULL) { + int resultType; + msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); + TCL_TRACE_READS, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, varName, NULL, "read", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, varName, NULL, "read", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, varName, NULL, "read", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); } return NULL; } @@ -915,11 +939,23 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + int resultType; + msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS); + TCL_TRACE_READS, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "read", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, arrayName, elem, "read", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, arrayName, elem, "read", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *)msg); } goto errorReturn; } @@ -1331,11 +1367,24 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + int resultType; + char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES, + &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, part1, part2, "set", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, part1, part2, "set", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *)msg); } goto cleanup; } @@ -1466,11 +1515,23 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) if ((flags & TCL_APPEND_VALUE) && (flags & TCL_LIST_ELEMENT) && (varPtr->tracePtr != NULL)) { + int resultType; + char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); + TCL_TRACE_READS, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, varName, NULL, "read", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, varName, NULL, "read", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, varName, NULL, "read", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *)msg); } return NULL; } @@ -1570,11 +1631,23 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, flags) */ if (varPtr->tracePtr != NULL) { + int resultType; + char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, - varName, (char *) NULL, TCL_TRACE_WRITES); + varName, (char *) NULL, TCL_TRACE_WRITES, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, varName, NULL, "set", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, varName, NULL, "set", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, varName, NULL, "set", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *)msg); } goto cleanup; } @@ -1776,11 +1849,23 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) if ((flags & TCL_APPEND_VALUE) && (flags & TCL_LIST_ELEMENT) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + int resultType; + char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS); + TCL_TRACE_READS, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "read", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, arrayName, elem, "read", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, arrayName, elem, "read", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); } goto errorReturn; } @@ -1851,11 +1936,23 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + int resultType; + char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_WRITES); + TCL_TRACE_WRITES, &resultType); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, arrayName, elem, "set", msg); + if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, arrayName, elem, "set", + Tcl_GetString((Tcl_Obj *) msg)); + } else { + VarErrMsg(interp, arrayName, elem, "set", msg); + } + } + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); } goto errorReturn; } @@ -2259,10 +2356,21 @@ Tcl_UnsetVar2(interp, part1, part2, flags) if ((dummyVar.tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + int resultType; + varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + msg = CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, + &resultType); + if (msg != NULL) { + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); + } + } while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; @@ -2436,11 +2544,20 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) } /* + * Check for a nonsense flag combination. Note that this is a + * panic() because there should be no code path that ever sets + * both flags. + */ + if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { + panic("bad result flag combination"); + } + + /* * Set up trace information. */ - flagMask = (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif @@ -2545,7 +2662,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) * interested in now. */ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY; + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; #ifndef TCL_REMOVE_OBSOLETE_TRACES flagMask |= TCL_TRACE_OLD_STYLE; #endif @@ -3074,11 +3191,22 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (varPtr != NULL && varPtr->tracePtr != NULL && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + int resultType; + msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY)); + TCL_TRACE_ARRAY), &resultType); if (msg != NULL) { - VarErrMsg(interp, varName, NULL, "trace array", msg); + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + VarErrMsg(interp, varName, NULL, "trace array", msg); + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg(interp, varName, NULL, "trace array", + Tcl_GetString((Tcl_Obj *) msg)); + Tcl_DecrRefCount((Tcl_Obj *)msg); + } else { + VarErrMsg(interp, varName, NULL, "trace array", msg); + } return TCL_ERROR; } } @@ -4295,7 +4423,7 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) */ static char * -CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) +CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, resultTypePtr) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable @@ -4308,6 +4436,8 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ + int *resultTypePtr; /* Report what kind of result was generated + * from the trace to this location. */ { register VarTrace *tracePtr; ActiveVarTrace active; @@ -4377,7 +4507,14 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { + *resultTypePtr = tracePtr->flags & + (TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT); if (flags & TCL_TRACE_UNSETS) { + if (tracePtr->flags & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(result); + } else if (tracePtr->flags & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) result); + } result = NULL; } else { goto done; @@ -4403,7 +4540,14 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { + *resultTypePtr = tracePtr->flags & + (TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT); if (flags & TCL_TRACE_UNSETS) { + if (tracePtr->flags & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(result); + } else if (tracePtr->flags & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) result); + } result = NULL; } else { goto done; @@ -4730,11 +4874,21 @@ TclDeleteVars(iPtr, tablePtr) */ if (varPtr->tracePtr != NULL) { + char *msg; + int resultType; + objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetString(objPtr), (char *) NULL, flags); + msg = CallTraces(iPtr, (Var *) NULL, varPtr, + Tcl_GetString(objPtr), (char *) NULL, flags, &resultType); + if (msg != NULL) { + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); + } + } Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { @@ -4859,8 +5013,18 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) */ if (varPtr->tracePtr != NULL) { - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - varPtr->name, (char *) NULL, flags); + char *msg; + int resultType; + + msg = CallTraces(iPtr, (Var *) NULL, varPtr, + varPtr->name, (char *) NULL, flags, &resultType); + if (msg != NULL) { + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); + } + } while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; @@ -4946,9 +5110,20 @@ DeleteArray(iPtr, arrayName, varPtr, flags) } elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { + char *msg; + int resultType; + elPtr->flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + msg = CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, + &resultType); + if (msg != NULL) { + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); + } + } while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; elPtr->tracePtr = tracePtr->nextPtr; @@ -5102,8 +5277,18 @@ TclVarTraceExists(interp, varName) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - CallTraces((Interp *)interp, arrayPtr, varPtr, varName, - (char *) NULL, TCL_TRACE_READS); + char *msg; + int resultType; + + msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName, + (char *) NULL, TCL_TRACE_READS, &resultType); + if (msg != NULL) { + if (resultType & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(msg); + } else if (resultType & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) msg); + } + } } /* diff --git a/tests/trace.test b/tests/trace.test index b6d75c2..f28b50e 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -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: trace.test,v 1.11 2001/08/13 12:40:15 msofer Exp $ +# RCS: @(#) $Id: trace.test,v 1.12 2001/11/19 14:35:55 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -477,6 +477,27 @@ test trace-8.7 {error returns from traces} { catch {set x} trace remove variable x read traceError } {} +test trace-8.8 {error returns from traces} { + # Yet more elaborate memory corruption testing that checks nothing + # bad happens when the trace deletes itself and installs something + # new. Alas, there is no neat way to guarantee that this test will + # fail if there is a problem, but that's life and with the new code + # it should *never* fail. + # + # Adapted from Bug #219393 reported by Don Porter. + catch {rename ::foo {}} + proc foo {old args} { + trace remove variable ::x write [list foo $old] + trace add variable ::x write [list foo $::x] + error "foo" + } + catch {unset ::x ::y} + set x junk + trace add variable ::x write [list junk $x] + for {set y 0} {$y<100} {incr y} { + catch {set x junk} + } +} {} # Check to see that variables are expunged before trace # procedures are invoked, so trace procedure can even manipulate |