Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.186
diff -u -r1.186 tclVar.c
--- generic/tclVar.c	31 Jan 2010 22:33:06 -0000	1.186
+++ generic/tclVar.c	1 Feb 2010 23:50:02 -0000
@@ -3211,11 +3211,7 @@
 	    return TCL_ERROR;
 	}
 	return TclArraySet(interp, objv[2], objv[3]);
-    case ARRAY_UNSET: {
-	Tcl_HashSearch search;
-	Var *varPtr2;
-	const char *pattern = NULL;
-
+    case ARRAY_UNSET:
 	if ((objc != 3) && (objc != 4)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
 	    return TCL_ERROR;
@@ -3228,11 +3224,16 @@
 	     * 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)) {
@@ -3240,23 +3241,61 @@
 		}
 		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;
Index: tests/var.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/var.test,v
retrieving revision 1.34
diff -u -r1.34 var.test
--- tests/var.test	25 Sep 2008 19:51:29 -0000	1.34
+++ tests/var.test	1 Feb 2010 23:50:03 -0000
@@ -34,7 +34,7 @@
 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 
@@ -725,9 +725,9 @@
 
 
 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
 
@@ -736,13 +736,33 @@
 } -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}
@@ -761,3 +781,7 @@
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
