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

hits the next element to be deleted.

3 files changed, 95 insertions, 25 deletions

diff --git a/ChangeLog b/ChangeLog
index a476c12..7c87350 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2010-02-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclVar.c (Tcl_ArrayObjCmd): [Bug 2939073]: Stop the [array
+	unset] command from having dangling pointer problems when an unset
+	trace deletes the element that is going to be processed next. Many
+	thanks to Alexandre Ferrieux for the bulk of this fix.
+
 2010-02-01  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/regexec.c (ccondissect, crevdissect): [Bug 2942697]: Rework
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 969cc17..775c864 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.160.2.6 2009/10/17 22:35:58 dkf Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.160.2.7 2010/02/02 00:42:41 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -3170,11 +3170,7 @@ Tcl_ArrayObjCmd(
 	    return TCL_ERROR;
 	}
 	return TclArraySet(interp, objv[2], objv[3]);
-    case ARRAY_UNSET: {
-	Tcl_HashSearch search;
-	Var *varPtr2;
-	char *pattern = NULL;
-
+    case ARRAY_UNSET:
 	if ((objc != 3) && (objc != 4)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
 	    return TCL_ERROR;
@@ -3187,11 +3183,16 @@ Tcl_ArrayObjCmd(
 	     * When no pattern is given, just unset the whole array.
 	     */
 
-	    if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) != TCL_OK) {
-		return TCL_ERROR;
-	    }
+	    return TclObjUnsetVar2(interp, varNamePtr, NULL, 0);
 	} else {
-	    pattern = TclGetString(objv[3]);
+	    Tcl_HashSearch search;
+	    Var *varPtr2, *protectedVarPtr;
+	    const char *pattern = TclGetString(objv[3]);
+
+	    /*
+	     * With a trivial pattern, we can just unset.
+	     */
+
 	    if (TclMatchIsTrivial(pattern)) {
 		varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]);
 		if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) {
@@ -3199,23 +3200,61 @@ Tcl_ArrayObjCmd(
 		}
 		return TCL_OK;
 	    }
+
+	    /*
+	     * Non-trivial case (well, deeply tricky really). We peek inside
+	     * the hash iterator in order to allow us to guarantee that the
+	     * following element in the array will not be scrubbed until we
+	     * have dealt with it. This stops the overall iterator from ending
+	     * up pointing into deallocated memory. [Bug 2939073]
+	     */
+
+	    protectedVarPtr = NULL;
 	    for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search);
 		    varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) {
-		Tcl_Obj *namePtr;
+		/*
+		 * Drop the extra ref immediately. We don't need to free it at
+		 * this point though; we'll be unsetting it if necessary soon.
+		 */
 
-		if (TclIsVarUndefined(varPtr2)) {
-		    continue;
+		if (varPtr2 == protectedVarPtr) {
+		    VarHashRefCount(varPtr2)--;
+		}
+
+		/*
+		 * Guard the next item in the search chain by incrementing its
+		 * refcount. This guarantees that the hash table iterator
+		 * won't be dangling on the next time through the loop.
+		 */
+
+		if (search.nextEntryPtr != NULL) {
+		    protectedVarPtr = VarHashGetValue(search.nextEntryPtr);
+		    VarHashRefCount(protectedVarPtr)++;
+		} else {
+		    protectedVarPtr = NULL;
 		}
-		namePtr = VarHashGetKey(varPtr2);
-		if (Tcl_StringMatch(TclGetString(namePtr), pattern) &&
-			TclObjUnsetVar2(interp, varNamePtr, namePtr,
-				0) != TCL_OK) {
-		    return TCL_ERROR;
+
+		if (!TclIsVarUndefined(varPtr2)) {
+		    Tcl_Obj *namePtr = VarHashGetKey(varPtr2);
+
+		    if (Tcl_StringMatch(TclGetString(namePtr), pattern)
+			    && TclObjUnsetVar2(interp, varNamePtr, namePtr,
+				    0) != TCL_OK) {
+			/*
+			 * If we incremented a refcount, we must decrement it
+			 * here as we will not be coming back properly due to
+			 * the error.
+			 */
+
+			if (protectedVarPtr) {
+			    VarHashRefCount(protectedVarPtr)--;
+			}
+			return TCL_ERROR;
+		    }
 		}
 	    }
+	    break;
 	}
-	break;
-    }
 
     case ARRAY_SIZE: {
 	Tcl_HashSearch search;
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: