summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-04-11 14:37:02 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-04-11 14:37:02 (GMT)
commit4178b8327b6e6dbb1d85866a25606c3417ba68f4 (patch)
tree4741306107e77f7b8f74fe1dc24b9e8ae7648c69
parente5d972dc85e7f1928c032bf9322877cf169bc941 (diff)
downloadtcl-4178b8327b6e6dbb1d85866a25606c3417ba68f4.zip
tcl-4178b8327b6e6dbb1d85866a25606c3417ba68f4.tar.gz
tcl-4178b8327b6e6dbb1d85866a25606c3417ba68f4.tar.bz2
* generic/tclCmdMZ.c: Stop some interference between enter traces
* tests/trace.test: and enterstep traces. [Bug 1458266]
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclCmdMZ.c15
-rw-r--r--tests/trace.test39
3 files changed, 53 insertions, 6 deletions
diff --git a/ChangeLog b/ChangeLog
index 4a6d969..72ee577 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2006-04-11 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCmdMZ.c: Stop some interference between enter traces
+ * tests/trace.test: and enterstep traces. [Bug 1458266]
+
2006-04-10 Don Porter <dgp@users.sourceforge.net>
*** 8.4.13 TAGGED FOR RELEASE ***
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9aaa6cb..1613799 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.25 2005/11/18 23:07:27 msofer Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.26 2006/04/11 14:37:04 dgp Exp $
*/
#include "tclInt.h"
@@ -4579,10 +4579,9 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
*/
if (call) {
Tcl_SavedResult state;
- int stateCode;
+ int stateCode, i, saveInterpFlags;
Tcl_DString cmd;
Tcl_DString sub;
- int i;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
@@ -4636,8 +4635,9 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
- 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++;
/*
* This line can have quite arbitrary side-effects,
@@ -4646,7 +4646,12 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
*/
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 21536ad..a85bda2 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.15 2006/02/28 15:44:36 dgp Exp $
+# RCS: @(#) $Id: trace.test,v 1.26.2.16 2006/04/11 14:37:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2325,6 +2325,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
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}