diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclBasic.c | 20 | ||||
| -rw-r--r-- | tests/trace.test | 12 |
3 files changed, 29 insertions, 9 deletions
@@ -1,3 +1,9 @@ +2002-07-17 Miguel Sofer <msofer@users.sourceforge.net> + + * generic/tclBasic.c (CallCommandTraces): delete traces now + receive the FQ old name of the command. + [Bug 582532] (Don Porter) + 2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net> * tests/ioUtil.test: added constraints to 1.4,2.4 so they diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b60a6c3..86730ab 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.63 2002/07/16 01:12:50 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.64 2002/07/18 13:37:45 msofer Exp $ */ #include "tclInt.h" @@ -2518,6 +2518,8 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) register CommandTrace *tracePtr; ActiveCommandTrace active; char *result; + Tcl_Obj *oldNamePtr = NULL; + if (cmdPtr->flags & CMD_TRACE_ACTIVE) { /* * While a rename trace is active, we will not process any more @@ -2554,8 +2556,11 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) } cmdPtr->flags |= tracePtr->flags; if (oldName == NULL) { - oldName = Tcl_GetCommandName((Tcl_Interp *) iPtr, - (Tcl_Command) cmdPtr); + TclNewObj(oldNamePtr); + Tcl_IncrRefCount(oldNamePtr); + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr, oldNamePtr); + oldName = TclGetString(oldNamePtr); } Tcl_Preserve((ClientData) tracePtr); (*tracePtr->traceProc)(tracePtr->clientData, @@ -2565,6 +2570,15 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) } /* + * If a new object was created to hold the full oldName, + * free it now. + */ + + if (oldNamePtr != NULL) { + TclDecrRefCount(oldNamePtr); + } + + /* * Restore the variable's flags, remove the record of our active * traces, and then return. */ diff --git a/tests/trace.test b/tests/trace.test index 7f7213b..2229b69 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.19 2002/06/17 22:52:51 hobbs Exp $ +# RCS: @(#) $Id: trace.test,v 1.20 2002/07/18 13:37:46 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1254,7 +1254,7 @@ test trace-20.1 {trace add command (delete option)} { trace add command foo delete traceCommand rename foo "" set info -} {foo {} delete} +} {::foo {} delete} test trace-20.2 {trace add command delete doesn't trace recreated commands} { set info {} proc foo {} {} @@ -1271,7 +1271,7 @@ test trace-20.3 {trace add command implicit delete} { trace add command foo delete traceCommand proc foo {} {} set info -} {foo {} delete} +} {::foo {} delete} test trace-20.3.1 {trace add command delete trace info} { proc foo {} {} trace info command foo @@ -1287,7 +1287,7 @@ test trace-20.4 {trace add command rename followed by delete} { set info $infotemp unset infotemp set info -} {{foo bar rename} {bar {} delete}} +} {{foo bar rename} {::bar {} delete}} catch {rename foo {}} catch {rename bar {}} @@ -1303,7 +1303,7 @@ test trace-20.5 {trace add command rename and delete} { set info $infotemp unset infotemp set info -} {{foo bar rename} {bar {} delete}} +} {{foo bar rename} {::bar {} delete}} test trace-20.6 {trace add command rename and delete in subinterp} { set tc [interp create] @@ -1323,7 +1323,7 @@ test trace-20.6 {trace add command rename and delete in subinterp} { set info [$tc eval [list set info]] interp delete $tc set info -} {{foo bar rename} {bar {} delete}} +} {{foo bar rename} {::bar {} delete}} # I'd like it if this test could give 'foo {} d' as a result, # but interp deletion means there is no interp to evaluate |