diff options
| -rw-r--r-- | generic/tclNamesp.c | 20 | ||||
| -rw-r--r-- | generic/tclVar.c | 73 | ||||
| -rw-r--r-- | tests/trace.test | 23 | ||||
| -rw-r--r-- | tests/var.test | 16 |
4 files changed, 97 insertions, 35 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 369a098..fa2a10f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -382,19 +382,6 @@ Tcl_PopCallFrame( register CallFrame *framePtr = iPtr->framePtr; Namespace *nsPtr; - /* - * It's important to remove the call frame from the interpreter's stack of - * call frames before deleting local variables, so that traces invoked by - * the variable deletion don't see the partially-deleted frame. - */ - - if (framePtr->callerPtr) { - iPtr->framePtr = framePtr->callerPtr; - iPtr->varFramePtr = framePtr->callerVarPtr; - } else { - /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ - } - if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree(framePtr->varTablePtr); @@ -422,6 +409,13 @@ Tcl_PopCallFrame( } framePtr->nsPtr = NULL; + if (framePtr->callerPtr) { + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + } else { + /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ + } + if (framePtr->tailcallPtr) { TclSetTailcall(interp, framePtr->tailcallPtr); } diff --git a/generic/tclVar.c b/generic/tclVar.c index a212c16..44325f8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4953,13 +4953,16 @@ TclDeleteNamespaceVars( VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags, - -1); - Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */ + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); /* - * Remove the variable from the table and force it undefined in case - * an unset trace brought it back from the dead. + * We just unset the variable. However, an unset trace might + * have re-set it, or might have re-established traces on it. + * This namespace and its vartable are going away unconditionally, + * so we cannot let such things linger. That would be a leak. + * + * First we destroy all traces. ... */ if (TclIsVarTraced(varPtr)) { @@ -4983,6 +4986,17 @@ TclDeleteNamespaceVars( } } } + + /* + * ...and then, if the variable still holds a value, we unset it + * again. This time with no traces left, we're sure it goes away. + */ + + if (!TclIsVarUndefined(varPtr)) { + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); + } + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } @@ -5015,27 +5029,44 @@ TclDeleteVars( TclVarHashTable *tablePtr) /* Hash table containing variables to * delete. */ { - Tcl_Interp *interp = (Tcl_Interp *) iPtr; Tcl_HashSearch search; register Var *varPtr; - int flags; - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - /* - * Determine what flags to pass to the trace callback functions. - */ - - flags = TCL_TRACE_UNSETS; - if (tablePtr == &iPtr->globalNsPtr->varTable) { - flags |= TCL_GLOBAL_ONLY; - } else if (tablePtr == &currNsPtr->varTable) { - flags |= TCL_NAMESPACE_ONLY; - } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { - UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags, - -1); + VarHashRefCount(varPtr)++; + + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), + NULL, TCL_TRACE_UNSETS, -1); + + if (TclIsVarTraced(varPtr)) { + Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); + VarTrace *tracePtr = Tcl_GetHashValue(tPtr); + ActiveVarTrace *activePtr; + + while (tracePtr) { + VarTrace *prevPtr = tracePtr; + + tracePtr = tracePtr->nextPtr; + prevPtr->nextPtr = NULL; + Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC); + } + Tcl_DeleteHashEntry(tPtr); + varPtr->flags &= ~VAR_ALL_TRACES; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + + if (!TclIsVarUndefined(varPtr)) { + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), + NULL, TCL_TRACE_UNSETS, -1); + } + + VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } VarHashDeleteTable(tablePtr); diff --git a/tests/trace.test b/tests/trace.test index 1099f48..3b69d38 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -1227,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} { test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 2 {info vars}]}}} set info {} p1 foo bar set info @@ -1263,6 +1263,27 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { rename doTrace {} set info } 1110 +test trace-18.5 {Bug 7f02ff1efa} -setup { + proc constant {name value} { + upvar 1 $name c + set c $value + trace variable c wu [list reset $value] + } + proc reset {v a i o} { + uplevel 1 [list constant $a $v] + } + proc demo {} { + constant pi 3.14 + } +} -body { + unset -nocomplain pi + demo + info exists pi +} -cleanup { + rename demo {} + rename reset {} + rename constant {} +} -result 0 # Delete arrays when done, so they can be re-used as scalars # elsewhere. diff --git a/tests/var.test b/tests/var.test index 44e671a..9816d98 100644 --- a/tests/var.test +++ b/tests/var.test @@ -594,6 +594,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit list [namespace delete test_ns_var] $::info } -result {{} {::test_ns_var::v {} u}} +test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { + proc ::t {a i o} { + set $a 321 + } +} -body { + leaktest { + namespace eval n { + variable v 123 + trace variable v u ::t + } + namespace delete n + } +} -cleanup { + rename ::t {} +} -result 0 + test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { catch {unset u} catch {unset v} |