From d74ef041362e5b4eeea97da995d6829f2a88b479 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 19 Nov 2001 14:35:54 +0000
Subject: Changes due to TIP#68; memory handling in variable traces is now
correct!
---
ChangeLog | 36 ++++++++
doc/TraceVar.3 | 48 ++++++++--
generic/tcl.h | 5 +-
generic/tclCmdMZ.c | 55 ++++--------
generic/tclVar.c | 253 ++++++++++++++++++++++++++++++++++++++++++++++-------
tests/trace.test | 23 ++++-
6 files changed, 337 insertions(+), 83 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index dea5080..17ba358 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
--
cgit v0.12