Attachment "arrayunset.patch" to
ticket [2939073fff]
added by
dkf
2010-02-02 07:09:38.
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:
