* generic/tclBasic.c (CallCommandTraces): Added safety bit

        * tests/trace.test:     masking to prevent any of the bit values
        TCL_TRACE_*_EXEC from leaking into the flags field of any
        Command struct.  This does not fix [Bug 811483] but helps to
        contain some of its worst symptoms.  Also backported the corrections
        to test trace-28.4 from Vince Darley.

3 files changed, 35 insertions, 18 deletions

diff --git a/ChangeLog b/ChangeLog
index c7bfd12..281d24f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2003-09-29  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c (CallCommandTraces):	Added safety bit
+	* tests/trace.test:	masking to prevent any of the bit values
+	TCL_TRACE_*_EXEC from leaking into the flags field of any
+	Command struct.  This does not fix [Bug 811483] but helps to
+	contain some of its worst symptoms.  Also backported the corrections
+	to test trace-28.4 from Vince Darley.
+
 2003-09-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
 
 	* library/http/http.tcl (geturl): Correctly check the type of
@@ -20,7 +29,7 @@
 
 2003-09-23  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCmdMZ.c ():		Fixed [Bug 807243] where
+	* generic/tclCmdMZ.c:			Fixed [Bug 807243] where
 	* tests/trace.test (trace-31,32.*):	the introspection results
 	of both [trace info command] and [trace info execution] were getting
 	co-mingled.  Thanks to Mark Saye for the report.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 629293f..50f80d4 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.75.2.5 2003/07/18 23:35:38 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.6 2003/09/29 22:03:44 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2560,6 +2560,9 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
     ActiveCommandTrace active;
     char *result;
     Tcl_Obj *oldNamePtr = NULL;
+    int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME);	/* Safety */
+
+    flags &= mask;
 
     if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
 	/* 
@@ -2595,11 +2598,13 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
     
     for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
 	 tracePtr = active.nextTracePtr) {
+	int traceFlags = (tracePtr->flags & mask);
+
 	active.nextTracePtr = tracePtr->nextPtr;
-	if (!(tracePtr->flags & flags)) {
+	if (!(traceFlags & flags)) {
 	    continue;
 	}
-	cmdPtr->flags |= tracePtr->flags;
+	cmdPtr->flags |= traceFlags;
 	if (oldName == NULL) {
 	    TclNewObj(oldNamePtr);
 	    Tcl_IncrRefCount(oldNamePtr);
@@ -2610,7 +2615,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
 	tracePtr->refCount++;
 	(*tracePtr->traceProc)(tracePtr->clientData,
 		(Tcl_Interp *) iPtr, oldName, newName, flags);
-	cmdPtr->flags &= ~tracePtr->flags;
+	cmdPtr->flags &= ~traceFlags;
 	if ((--tracePtr->refCount) <= 0) {
 	    ckfree((char*)tracePtr);
 	}
diff --git a/tests/trace.test b/tests/trace.test
index 4e010e9..6475aed 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.2 2003/09/24 02:17:10 dgp Exp $
+# RCS: @(#) $Id: trace.test,v 1.26.2.3 2003/09/29 22:03:44 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -1980,9 +1980,10 @@ foo {if {[catch {bar}]} {
 	}} 2 error leavestep
 foo foo 0 error leave}}
 
-test trace-28.4 {exec traces in slave with 'return -code error'} {knownBug} {
+test trace-28.4 {exec traces in slave with 'return -code error'} {
     interp create slave
     interp alias slave traceExecute {} traceExecute
+    set info {}
     set res [interp eval slave {
 	set info {}
 	set res {}
@@ -2009,16 +2010,16 @@ test trace-28.4 {exec traces in slave with 'return -code error'} {knownBug} {
 	trace remove execution foo {enter enterstep leave leavestep} \
 	  [list traceExecute foo]
 	
-	list $res [join $info \n]
+	list $res
     }]
     interp delete slave
-    set res
+    lappend res [join $info \n]
 } {{error error} {foo foo enter
 foo {if {[catch {bar}]} {
-	    return "error"
-	} else {
-	    return "ok"
-	}} enterstep
+		return "error"
+	    } else {
+		return "ok"
+	    }} enterstep
 foo {catch bar} enterstep
 foo bar enterstep
 foo {return -code error msg} enterstep
@@ -2028,10 +2029,10 @@ foo {catch bar} 0 1 leavestep
 foo {return error} enterstep
 foo {return error} 2 error leavestep
 foo {if {[catch {bar}]} {
-	    return "error"
-	} else {
-	    return "ok"
-	}} 2 error leavestep
+		return "error"
+	    } else {
+		return "ok"
+	    }} 2 error leavestep
 foo foo 0 error leave}}
 
 test trace-28.5 {exec traces} {
@@ -2119,7 +2120,9 @@ test trace-31.2 {command and execution traces shared struct} {
     set result
 } [list [list enter foo]]
 
-test trace-32.1 {mystery memory corruption} knownBug {
+test trace-32.1 {
+    TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference
+} {
     # Tcl Bug 811483
     proc foo {} {}
     trace add command foo delete foo