From a2138bd6664eaf8ec5a4dcf1b66a78ee9c9fa8f3 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 2 Feb 2010 00:11:30 +0000 Subject: Fix [Bug 2939073]: dangling ref when an unset trace triggered by [array unset] hits the next element to be deleted. --- ChangeLog | 5 ++++ generic/tclVar.c | 79 ++++++++++++++++++++++++++++++++++++++++++-------------- tests/var.test | 34 ++++++++++++++++++++---- 3 files changed, 93 insertions(+), 25 deletions(-) diff --git a/ChangeLog b/ChangeLog index 527339e..eea0ae9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,10 @@ 2010-02-01 Donal K. Fellows + * 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. + * generic/regexec.c (ccondissect, crevdissect): [Bug 2942697]: Rework these functions so that certain pathological patterns are matched much more rapidly. Many thanks to Tom Lane for dianosing this issue and diff --git a/generic/tclVar.c b/generic/tclVar.c index dccbfbb..5e7ec1e 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.186 2010/01/31 22:33:06 dkf Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.187 2010/02/02 00:11:31 dkf Exp $ */ #include "tclInt.h" @@ -3211,11 +3211,7 @@ Tcl_ArrayObjCmd( 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 @@ 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)) { @@ -3240,23 +3241,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 698cd20..59b71be 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.34 2008/09/25 19:51:29 dgp Exp $ +# RCS: @(#) $Id: var.test,v 1.35 2010/02/02 00:11:31 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 @@ -725,9 +725,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 @@ -736,13 +736,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} @@ -761,3 +781,7 @@ catch {unset aaaaa} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12