Fix [Bug 2939073]: dangling ref when an unset trace triggered by [array unset]

hits the next element to be deleted.

1 files changed, 29 insertions, 5 deletions

diff --git a/tests/var.test b/tests/var.test
index bf48224..c5c304e 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -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: var.test,v 1.31 2008/03/11 17:23:56 msofer Exp $
+# RCS: @(#) $Id: var.test,v 1.31.2.1 2010/02/02 00:42:41 dkf Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -34,7 +34,7 @@ catch {unset y}
 catch {unset i}
 catch {unset a}
 catch {unset arr}
-
+
 test var-1.1 {TclLookupVar, Array handling} {
     catch {unset a}
     set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd 
@@ -716,9 +716,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} {
 
 
 test var-16.1 {CallVarTraces: save/restore interp error state} {
-    trace add variable ::errorCode write { ;#}
+    trace add variable ::errorCode write " ;#"
     catch {error foo bar baz}
-    trace remove variable ::errorCode write { ;#}
+    trace remove variable ::errorCode write " ;#"
     set ::errorInfo
 } bar
 
@@ -727,13 +727,33 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup {
 } -body {
     namespace eval :: {
 	set elements {1 2 3 4}
-	trace add variable a write {string length $elements ;#}
+	trace add variable a write "string length \$elements ;#"
 	array set a $elements
     }
 } -cleanup {
     unset -nocomplain ::a ::elements
 } -result {}
 
+test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
+    set already 0
+    unset x
+} -body {
+    array set x {e 1 i 1}
+    trace add variable x unset {apply {args {
+	global already x
+	if {!$already} {
+	    set already 1
+	    unset x(i)
+	}
+    }}}
+    # The next command would crash reliably with memory debugging prior to the
+    # bug fix.
+    array unset x *
+    array size x
+} -cleanup {
+    unset x already
+} -result 0
+
 catch {namespace delete ns}
 catch {unset arr}
 catch {unset v}
@@ -752,3 +772,7 @@ catch {unset aaaaa}
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End: