From 2137f75a0e2bd2dba76b4b82a50d26eea8b2b1d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Nov 2004 21:14:28 +0000 Subject: * 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 | 7 +++ generic/tclCmdMZ.c | 123 ++++++++++++++++------------------------------------- tests/trace.test | 9 +++- 3 files changed, 51 insertions(+), 88 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2903d8e..b4e173c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2004-11-15 Don Porter + + * 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-12 Don Porter * library/init.tcl: Made [unknown] robust in the case that diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1bf2183..b4313cb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.82.2.12 2004/08/30 18:15:24 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.13 2004/11/15 21:14:32 dgp Exp $ */ #include "tclInt.h" @@ -2976,9 +2976,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", @@ -3025,105 +3024,52 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) return (traceSubCmds[typeIndex])(interp, optionIndex, 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; @@ -3721,6 +3667,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); @@ -3744,7 +3693,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 6475aed..322f761 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.26.2.3 2003/09/29 22:03:44 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.26.2.4 2004/11/15 21:14:34 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2132,6 +2132,13 @@ test trace-32.1 { set result } [list [list delete foo]] +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 + # 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