From 2e99120257a8ebe71af4bcfeab8cc1d031a4bd24 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 21 Jun 2005 17:19:36 +0000 Subject: * generic/tclBasic.c: Made the walk of the active trace list aware * generic/tclCmdMZ.c: of the direction of trace scanning, so the * generic/tclInt.h: proper correction can be made. [Bug 1224585] * tests/trace.test (trace-34.2,3): --- ChangeLog | 5 +++++ changes | 4 +++- generic/tclBasic.c | 13 ++++++++++--- generic/tclCmdMZ.c | 20 ++++++++++++++++---- generic/tclInt.h | 6 +++++- tests/trace.test | 18 +++++++++++++++++- 6 files changed, 56 insertions(+), 10 deletions(-) diff --git a/ChangeLog b/ChangeLog index f31078e..f4e887b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,11 @@ *** 8.4.11 TAGGED FOR RELEASE *** + * generic/tclBasic.c: Made the walk of the active trace list aware + * generic/tclCmdMZ.c: of the direction of trace scanning, so the + * generic/tclInt.h: proper correction can be made. [Bug 1224585] + * tests/trace.test (trace-34.2,3): + * generic/tclBasic.c (Tcl_DeleteTrace): Added missing walk of the * tests/trace.test (trace-34.1): list of active traces to cleanup references to traces being deleted. [Bug 1201035] diff --git a/changes b/changes index 1e6bf4d..cf603c4 100644 --- a/changes +++ b/changes @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.79.2.19 2005/06/18 19:52:36 dgp Exp $ +RCS: @(#) $Id: changes,v 1.79.2.20 2005/06/21 17:19:40 dgp Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -6213,4 +6213,6 @@ Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.] 2005-06-18 (bug fix)[1154163] [format %h] on 64-bit OS's (kraft,fellows) +2005-06-21 (bug fix)[1201035,1224585] execution trace crashes (porter) + --- Released 8.4.11, June 24, 2005 --- See ChangeLog for details --- diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ccb6de9..f1423cf 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.15 2005/06/21 14:44:58 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.16 2005/06/21 17:19:40 dgp Exp $ */ #include "tclInt.h" @@ -2585,6 +2585,7 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) result = NULL; active.nextPtr = iPtr->activeCmdTracePtr; + active.reverseScan = 0; iPtr->activeCmdTracePtr = &active; if (flags & TCL_TRACE_DELETE) { @@ -5158,7 +5159,7 @@ Tcl_DeleteTrace(interp, trace) * Tcl_CreateTrace). */ { Interp *iPtr = (Interp *) interp; - Trace *tracePtr = (Trace *) trace; + Trace *prevPtr, *tracePtr = (Trace *) trace; register Trace **tracePtr2 = &(iPtr->tracePtr); ActiveInterpTrace *activePtr; @@ -5167,7 +5168,9 @@ Tcl_DeleteTrace(interp, trace) * and remove it from the list. */ + prevPtr = NULL; while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { + prevPtr = *tracePtr2; tracePtr2 = &((*tracePtr2)->nextPtr); } if (*tracePtr2 == NULL) { @@ -5184,7 +5187,11 @@ Tcl_DeleteTrace(interp, trace) for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { - activePtr->nextTracePtr = tracePtr->nextPtr; + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->nextPtr; + } } } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0c9ff94..1ab108f 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.19 2005/05/25 19:25:57 hobbs Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.20 2005/06/21 17:19:42 dgp Exp $ */ #include "tclInt.h" @@ -3972,7 +3972,11 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { - activePtr->nextTracePtr = tracePtr->nextPtr; + if (activePtr->reverseScan) { + activePtr->nextTracePtr = prevPtr; + } else { + activePtr->nextTracePtr = tracePtr->nextPtr; + } } } if (prevPtr == NULL) { @@ -4201,6 +4205,7 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_LEAVE_EXEC) { /* execute the trace command in order of creation for "leave" */ + active.reverseScan = 1; active.nextTracePtr = NULL; tracePtr = cmdPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { @@ -4208,6 +4213,7 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, tracePtr = tracePtr->nextPtr; } } else { + active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; @@ -4225,7 +4231,9 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, ckfree((char*)tcmdPtr); } } - lastTracePtr = tracePtr; + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } } iPtr->activeCmdTracePtr = active.nextPtr; return(traceCode); @@ -4296,6 +4304,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, * Tcl_CreateObjTrace creates one more linked list of traces * which results in one more reversal of trace invocation. */ + active.reverseScan = 1; active.nextTracePtr = NULL; tracePtr = iPtr->tracePtr; while (tracePtr->nextPtr != lastTracePtr) { @@ -4303,6 +4312,7 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, tracePtr = tracePtr->nextPtr; } } else { + active.reverseScan = 0; active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->level > 0 && curLevel > tracePtr->level) { @@ -4347,7 +4357,9 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; Tcl_Release((ClientData) tracePtr); } - lastTracePtr = tracePtr; + if (active.nextTracePtr) { + lastTracePtr = active.nextTracePtr->nextPtr; + } } iPtr->activeInterpTracePtr = active.nextPtr; return(traceCode); diff --git a/generic/tclInt.h b/generic/tclInt.h index 2716467..45eb8ff 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.118.2.11 2005/06/18 21:46:42 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.12 2005/06/21 17:19:43 dgp Exp $ */ #ifndef _TCLINT @@ -336,6 +336,8 @@ typedef struct ActiveCommandTrace { * trace procedure returns; if this * trace gets deleted, must update pointer * to avoid using free'd memory. */ + int reverseScan; /* Boolean set true when the traces + * are scanning in reverse order. */ } ActiveCommandTrace; /* @@ -709,6 +711,8 @@ typedef struct ActiveInterpTrace { * trace procedure returns; if this * trace gets deleted, must update pointer * to avoid using free'd memory. */ + int reverseScan; /* Boolean set true when the traces + * are scanning in reverse order. */ } ActiveInterpTrace; /* diff --git a/tests/trace.test b/tests/trace.test index 4456afa..e0c6648 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.5 2005/06/21 14:44:59 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.26.2.6 2005/06/21 17:19:43 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2156,6 +2156,22 @@ test trace-34.1 {Bug 1201035} { set ::x } {{{lappend ::x foo} enterstep} done foo} +test trace-34.2 {Bug 1224585} { + proc foo {} {} + proc bar args {trace remove execution foo leave soom} + trace add execution foo leave bar + trace add execution foo leave soom + foo +} {} + +test trace-34.3 {Bug 1224585} { + proc foo {} {set x {}} + proc bar args {trace remove execution foo enterstep soom} + trace add execution foo enterstep soom + trace add execution foo enterstep bar + foo +} {} + # 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