diff options
| -rw-r--r-- | generic/tclVar.c | 20 | ||||
| -rw-r--r-- | tests/var.test | 31 |
2 files changed, 48 insertions, 3 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index bdc64b7..e95307e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4498,11 +4498,14 @@ TclDeleteNamespaceVars( Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags); - Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ /* - * 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)) { @@ -4527,6 +4530,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); + } + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } diff --git a/tests/var.test b/tests/var.test index c852ca9..30e340e 100644 --- a/tests/var.test +++ b/tests/var.test @@ -22,6 +22,21 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} catch {rename p ""} catch {namespace delete test_ns_var} @@ -540,6 +555,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit list [namespace delete test_ns_var] $::info } {{} {::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} testsetnoerr { catch {unset u}; catch {unset v} list \ |