diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclTrace.c | 14 | ||||
| -rw-r--r-- | tests/trace.test | 39 |
3 files changed, 53 insertions, 5 deletions
@@ -1,3 +1,8 @@ +2006-04-11 Don Porter <dgp@users.sourceforge.net> + + * generic/tclTrace.c: Stop some interference between enter traces + * tests/trace.test: and enterstep traces. [Bug 1458266] + 2006-04-07 Don Porter <dgp@users.sourceforge.net> *** 8.5a4 TAGGED FOR RELEASE *** diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 48cd1db..65c53f8 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -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: tclTrace.c,v 1.32 2006/01/09 09:31:58 dkf Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.33 2006/04/11 14:37:54 dgp Exp $ */ #include "tclInt.h" @@ -1789,7 +1789,7 @@ TraceExecutionProc( if (call) { Tcl_DString cmd; Tcl_DString sub; - int i; + int i, saveInterpFlags; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); @@ -1852,8 +1852,9 @@ TraceExecutionProc( * returns. */ - tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + saveInterpFlags = iPtr->flags; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; tcmdPtr->refCount++; /* @@ -1864,7 +1865,12 @@ TraceExecutionProc( traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; - iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + + /* + * Restore the interp tracing flag to prevent cmd traces + * from affecting interp traces. + */ + iPtr->flags = saveInterpFlags; if (tcmdPtr->flags == 0) { flags |= TCL_TRACE_DESTROYED; } diff --git a/tests/trace.test b/tests/trace.test index 657c86a..a6afc4e 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.48 2006/02/28 15:47:10 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.49 2006/04/11 14:37:54 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2391,6 +2391,43 @@ test trace-34.5 {Bug 1047286} { set x } {::foo::bar exists: } +test trace-34.6 {Bug 1458266} -setup { + proc dummy {} {} + proc stepTraceHandler {cmdString args} { + variable log + append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n" + dummy + isTracedInside_2 + } + proc cmdTraceHandler {cmdString args} { + # silent + } + proc isTracedInside_1 {} { + isTracedInside_2 + } + proc isTracedInside_2 {} { + set x 2 + } +} -body { + variable log {} + trace add execution isTracedInside_1 enterstep stepTraceHandler + trace add execution isTracedInside_2 enterstep stepTraceHandler + isTracedInside_1 + variable first $log + set log {} + trace add execution dummy enter cmdTraceHandler + isTracedInside_1 + variable second $log + expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"} +} -cleanup { + unset -nocomplain log first second + rename dummy {} + rename stepTraceHandler {} + rename cmdTraceHandler {} + rename isTracedInside_1 {} + rename isTracedInside_2 {} +} -result ok + test trace-35.1 {527164: Keep -errorinfo of traces} -setup { unset -nocomplain x y } -body { |