diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclVar.c | 75 | ||||
| -rw-r--r-- | tests/trace.test | 30 |
3 files changed, 102 insertions, 9 deletions
@@ -1,3 +1,9 @@ +2001-12-05 Miguel Sofer <msofer@users.sourceforge.net> + + * generic/tclVar.c: + * tests/trace.test: new algorithm for [array get], safe when there + are traces that modify the array [Bug #449893]. + 2001-12-04 Donal K. Fellows <fellowsd@cs.man.ac.uk> * tests/compExpr-old.test, tests/compExpr.test, tests/compile.test: diff --git a/generic/tclVar.c b/generic/tclVar.c index 4e2dc2e..401e36b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -15,7 +15,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.42 2001/11/30 14:59:01 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.43 2001/12/05 20:43:58 msofer Exp $ */ #include "tclInt.h" @@ -3306,7 +3306,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Var *varPtr2; char *pattern = NULL; char *name; - Tcl_Obj *namePtr, *valuePtr; + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; + int i, count; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); @@ -3318,6 +3319,14 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (objc == 4) { pattern = TclGetString(objv[3]); } + + /* + * Store the array names in a new object. + */ + + nameLstPtr = Tcl_NewObj(); + Tcl_IncrRefCount(nameLstPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3330,27 +3339,77 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + Tcl_DecrRefCount(nameLstPtr); return result; } + } + + /* + * Make sure the Var structure of the array is not removed by + * a trace while we're working. + */ + + varPtr->refCount++; + tmpResPtr = Tcl_NewObj(); + + /* + * Get the array values corresponding to each element name + */ + result = Tcl_ListObjGetElements(interp, nameLstPtr, &count, &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + + tmpResPtr = Tcl_NewObj(); + for (i = 0; i < count; i++) { + namePtr = *namePtrPtr++; valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + /* + * Some trace played a trick on us; we need to diagnose to + * adapt our behaviour: was the array element unset, or did + * the modification modify the complete array? + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * The array itself looks OK, the variable was undefined: + * forget it. + */ + + continue; + } else { + result = TCL_ERROR; + goto errorInArrayGet; + } } - result = Tcl_ListObjAppendElement(interp, resultPtr, + result = Tcl_ListObjAppendElement(interp, tmpResPtr, + namePtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + goto errorInArrayGet; } } + varPtr->refCount--; + Tcl_SetObjResult(interp, tmpResPtr); + Tcl_DecrRefCount(nameLstPtr); break; + + errorInArrayGet: + varPtr->refCount--; + Tcl_DecrRefCount(nameLstPtr); + Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */ + return result; } case ARRAY_NAMES: { Tcl_HashSearch search; diff --git a/tests/trace.test b/tests/trace.test index b82b399..beab9c6 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.14 2001/11/21 19:53:40 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.15 2001/12/05 20:43:58 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -140,6 +140,34 @@ test trace-1.10 {trace variable reads} { unset x set info } {} +test trace-1.11 {read traces that modify the array structure} { + catch {unset x} + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x(bar) ;#} + array get x +} {} +test trace-1.12 {read traces that modify the array structure} { + catch {unset x} + set x(bar) 0 + trace variable x r {unset -nocomplain x(bar) ;#} + trace variable x r {set x(foo) 1 ;#} + array get x +} {} +test trace-1.13 {read traces that modify the array structure} { + catch {unset x} + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x;#} + list [catch {array get x} res] $res +} {1 {can't read "x(bar)": no such variable}} +test trace-1.14 {read traces that modify the array structure} { + catch {unset x} + set x(bar) 0 + trace variable x r {unset -nocomplain x;#} + trace variable x r {set x(foo) 1 ;#} + list [catch {array get x} res] $res +} {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables |