summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclVar.c79
-rw-r--r--tests/var.test34
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: