summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclVar.c75
-rw-r--r--tests/trace.test30
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