new algorithm for [array get], safe when there are traces that modify the array [Bug #449893].

3 files changed, 102 insertions, 9 deletions

diff --git a/ChangeLog b/ChangeLog
index e3c7687..a5ef431 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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