From 727cc7ed58601550160c4b3dbc91bec67fec705f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Sep 2003 22:03:43 +0000 Subject: * 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. --- ChangeLog | 11 ++++++++++- generic/tclBasic.c | 13 +++++++++---- tests/trace.test | 29 ++++++++++++++++------------- 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 + + * 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 * library/http/http.tcl (geturl): Correctly check the type of @@ -20,7 +29,7 @@ 2003-09-23 Don Porter - * 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 -- cgit v0.12