Attachment "arrayGet.patch" to
ticket [449893ffff]
added by
msofer
2001-12-02 07:39:39.
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.42
diff -u -r1.42 tclVar.c
--- generic/tclVar.c 2001/11/30 14:59:01 1.42
+++ generic/tclVar.c 2001/12/02 00:33:55
@@ -3306,7 +3306,8 @@
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 @@
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 @@
}
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, tmpResPtr,
+ namePtr);
+ if (result != TCL_OK) {
+ goto errorInArrayGet;
}
- result = Tcl_ListObjAppendElement(interp, resultPtr,
+ 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;
Index: tests/trace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/trace.test,v
retrieving revision 1.14
diff -u -r1.14 trace.test
--- tests/trace.test 2001/11/21 19:53:40 1.14
+++ tests/trace.test 2001/12/02 00:33:57
@@ -140,6 +140,34 @@
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
