summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-11-15 21:47:21 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-11-15 21:47:21 (GMT)
commita7b6d284d9a81d17771007a9b3158d7a3ee2abdf (patch)
tree9717c0374c2caf6f45e09dcb36894b7895ccd57c
parentcd2e2d4f0350a8752c58aab0c644f415e8b770a3 (diff)
downloadtcl-a7b6d284d9a81d17771007a9b3158d7a3ee2abdf.zip
tcl-a7b6d284d9a81d17771007a9b3158d7a3ee2abdf.tar.gz
tcl-a7b6d284d9a81d17771007a9b3158d7a3ee2abdf.tar.bz2
* generic/tclInt.h: Added comment warning that the old
ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used for the sake of those extensions that have accessed them. * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed * tests/trace.test (trace-33.1): to permit a variable trace created with [trace variable] to be destroyed with [trace remove]. Thanks to Keith Vetter for the report.
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclTrace.c123
-rw-r--r--tests/trace.test12
4 files changed, 62 insertions, 90 deletions
diff --git a/ChangeLog b/ChangeLog
index 900ce9c..196be4f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2004-11-15 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclInt.h: Added comment warning that the old
+ ERR_IN_PROGRESS and ERROR_CODE_SET flag values should not be re-used
+ for the sake of those extensions that have accessed them.
+
+ * generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed
+ * tests/trace.test (trace-33.1): to permit a variable trace
+ created with [trace variable] to be destroyed with [trace remove].
+ Thanks to Keith Vetter for the report.
+
2004-11-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/tclvars.n: Added section to documentation on global
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 28284b2..04254d9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.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: tclInt.h,v 1.198 2004/11/13 00:19:09 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.199 2004/11/15 21:47:22 dgp Exp $
*/
#ifndef _TCLINT
@@ -1471,6 +1471,10 @@ typedef struct Interp {
* INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
* active; so no further trace callbacks should be
* invoked.
+ *
+ * WARNING: For the sake of some extensions that have made use of former
+ * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
+ * or 8 (formerly ERROR_CODE_SET).
*/
#define DELETED 1
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 893f38e..5059a60 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -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: tclTrace.c,v 1.20 2004/11/13 00:19:10 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.21 2004/11/15 21:47:23 dgp Exp $
*/
#include "tclInt.h"
@@ -176,9 +176,8 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int optionIndex, commandLength;
- char *name, *flagOps, *command, *p;
- size_t length;
+ int optionIndex;
+ char *name, *flagOps, *p;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
"add", "info", "remove",
@@ -247,105 +246,52 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv)
}
#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->length = length;
- flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
- 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_VARIABLE:
case TRACE_OLD_VDELETE: {
- int flags;
- TraceVarInfo *tvarPtr;
- ClientData clientData;
+ Tcl_Obj *copyObjv[6];
+ Tcl_Obj *opsList;
+ int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
- flags = 0;
- flagOps = Tcl_GetString(objv[3]);
+ opsList = Tcl_NewObj();
+ Tcl_IncrRefCount(opsList);
+ flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
+ if (numFlags == 0) {
+ Tcl_DecrRefCount(opsList);
+ goto badVarOps;
+ }
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
- flags |= TCL_TRACE_READS;
+ Tcl_ListObjAppendElement(NULL, opsList,
+ Tcl_NewStringObj("read", -1));
} else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
+ Tcl_ListObjAppendElement(NULL, opsList,
+ Tcl_NewStringObj("write", -1));
} else if (*p == 'u') {
- flags |= TCL_TRACE_UNSETS;
+ Tcl_ListObjAppendElement(NULL, opsList,
+ Tcl_NewStringObj("unset", -1));
} else if (*p == 'a') {
- flags |= TCL_TRACE_ARRAY;
+ Tcl_ListObjAppendElement(NULL, opsList,
+ Tcl_NewStringObj("array", -1));
} else {
+ Tcl_DecrRefCount(opsList);
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_UntraceVar2(interp, name, NULL,
- flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
- TraceVarProc, clientData);
- Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
- break;
- }
+ copyObjv[0] = NULL;
+ memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
+ copyObjv[4] = opsList;
+ if (optionIndex == TRACE_OLD_VARIABLE) {
+ code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
+ } else {
+ code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
}
- break;
+ Tcl_DecrRefCount(opsList);
+ return code;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
@@ -934,6 +880,9 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
(sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ length + 1));
tvarPtr->flags = flags;
+ if (objv[0] == NULL) {
+ tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
+ }
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
strcpy(tvarPtr->command, command);
@@ -957,7 +906,7 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length)
- && (tvarPtr->flags == flags)
+ && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
diff --git a/tests/trace.test b/tests/trace.test
index 145d171..e8b2ae7 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.36 2004/11/03 21:49:14 dgp Exp $
+# RCS: @(#) $Id: trace.test,v 1.37 2004/11/15 21:47:23 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2197,7 +2197,14 @@ test trace-32.1 {
set result
} [list [list delete foo]]
-test trace-33.1 {527164: Keep -errorinfo of traces} -setup {
+test trace-33.1 {variable match with remove variable} {
+ unset -nocomplain x
+ trace variable x w foo
+ trace remove variable x write foo
+ llength [trace info variable x]
+} 0
+
+test trace-34.1 {527164: Keep -errorinfo of traces} -setup {
unset -nocomplain x y
} -body {
trace add variable x write {error foo;#}
@@ -2215,6 +2222,7 @@ test trace-33.1 {527164: Keep -errorinfo of traces} -setup {
invoked from within
"set y 1"}}
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}