From 20f90f51f25cf3474e10150eebc6f1e23f68a0db Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Thu, 18 Jul 2002 13:37:43 +0000
Subject: * generic/tclBasic.c (CallCommandTraces): delete traces now receive  
 the FQ old name of the command. [Bug 582532] (Don Porter)

---
 ChangeLog          |  6 ++++++
 generic/tclBasic.c | 20 +++++++++++++++++---
 tests/trace.test   | 12 ++++++------
 3 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ede14f2..d6a70bd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
-- 
cgit v0.12