summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog4
-rw-r--r--generic/tclTrace.c17
-rw-r--r--tests/unsupported.test27
3 files changed, 45 insertions, 3 deletions
diff --git a/ChangeLog b/ChangeLog
index 6360fb4..6e7a9d8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
2008-09-04 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclTrace.test (TraceVarProc):
+ * generic/unsupported.test: insure that unset traces are run even
+ when the coroutine is unwinding [Bug 2093947]
+
* generic/tclExecute.c (CACHE_STACK_INFO):
* tests/unsupported.test: restore the execEnv's bottomPtr, fix
for [Bug 2093188].
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index bb4dbfa..8f095b5 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.50 2008/08/07 22:29:09 nijtmans Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.51 2008/09/05 01:20:00 msofer Exp $
*/
#include "tclInt.h"
@@ -1947,7 +1947,8 @@ TraceVarProc(
char *result;
int code, destroy = 0;
Tcl_DString cmd;
-
+ int rewind = ((Interp *)interp)->execEnvPtr->rewind;
+
/*
* We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
@@ -2008,8 +2009,20 @@ TraceVarProc(
destroy = 1;
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
+
+ /*
+ * Make sure that unset traces are rune even if the execEnv is
+ * rewinding (coroutine deletion, [Bug 2093947]
+ */
+
+ if (rewind && (flags & TCL_TRACE_UNSETS)) {
+ ((Interp *)interp)->execEnvPtr->rewind = 0;
+ }
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
+ if (rewind) {
+ ((Interp *)interp)->execEnvPtr->rewind = rewind;
+ }
if (code != TCL_OK) { /* copy error msg to result */
Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errMsgObj);
diff --git a/tests/unsupported.test b/tests/unsupported.test
index 2c1a281..74f91aa 100644
--- a/tests/unsupported.test
+++ b/tests/unsupported.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unsupported.test,v 1.9 2008/09/04 16:34:55 msofer Exp $
+# RCS: @(#) $Id: unsupported.test,v 1.10 2008/09/05 01:20:01 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -810,6 +810,31 @@ test unsupported-C.4.2 {bug #2093188} -constraints {coroutine} \
unset ::res
} -result {{} 3 {{v {} read} {v {} unset}}}
+test unsupported-C.4.2 {bug #2093947} -constraints {coroutine} \
+-setup {
+ proc foo {} {
+ set v 1
+ trace add variable v {write unset} bar
+ yield
+ set v 2
+ yield
+ set v 3
+ }
+ proc bar args {lappend ::res $args}
+} -body {
+ coroutine a foo
+ a
+ a
+ coroutine a foo
+ a
+ rename a {}
+ set ::res
+} -cleanup {
+ rename foo {}
+ rename bar {}
+ unset ::res
+} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
+
# cleanup
::tcltest::cleanupTests