diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclVar.c | 79 | ||||
| -rw-r--r-- | tests/var.test | 34 |
3 files changed, 95 insertions, 25 deletions
@@ -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: |