diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | generic/tclTrace.c | 17 | ||||
| -rw-r--r-- | tests/unsupported.test | 27 |
3 files changed, 45 insertions, 3 deletions
@@ -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 |