From a7b6d284d9a81d17771007a9b3158d7a3ee2abdf Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Nov 2004 21:47:21 +0000 Subject: * 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. --- ChangeLog | 11 +++++ generic/tclInt.h | 6 ++- generic/tclTrace.c | 123 ++++++++++++++++------------------------------------- tests/trace.test | 12 +++++- 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 + + * 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 * 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 {}} -- cgit v0.12