Tcl Source Code

Artifact b4a29d1c765ac178888a8dc96ae13d2b544b0690:

Attachment "1669489.patch" to ticket [1669489fff] added by dgp 2007-03-13 01:01:54.

---

Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.127
diff -u -r1.127 tclVar.c
--- generic/tclVar.c	20 Feb 2007 23:24:03 -0000	1.127
+++ generic/tclVar.c	12 Mar 2007 18:00:43 -0000
@@ -3023,8 +3023,7 @@
 				 * NULL, create an empty array. */
 {
     Var *varPtr, *arrayPtr;
-    Tcl_Obj **elemPtrs;
-    int result, elemLen, i, nameLen;
+    int result, i, nameLen;
     char *varName, *p;
 
     varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
@@ -3100,6 +3099,8 @@
 	 * Not a dictionary, so assume (and convert to, for
 	 * backward-compatability reasons) a list.
 	 */
+	int elemLen;
+	Tcl_Obj **elemPtrs, *copyListObj;
 
 	result = Tcl_ListObjGetElements(interp, arrayElemObj,
 		&elemLen, &elemPtrs);
@@ -3121,6 +3122,7 @@
 	 * loop and return an error.
 	 */
 
+	copyListObj = TclListObjCopy(NULL, arrayElemObj);
 	for (i=0 ; i<elemLen ; i+=2) {
 	    char *part2 = TclGetString(elemPtrs[i]);
 	    Var *elemVarPtr = TclLookupArrayElement(interp, varName,
@@ -3133,6 +3135,7 @@
 		break;
 	    }
 	}
+	Tcl_DecrRefCount(copyListObj);
 	return result;
     }
 
Index: tests/var.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/var.test,v
retrieving revision 1.27
diff -u -r1.27 var.test
--- tests/var.test	9 Oct 2006 19:15:45 -0000	1.27
+++ tests/var.test	12 Mar 2007 18:00:44 -0000
@@ -702,6 +702,18 @@
     set ::errorInfo
 } bar
 
+test var-17.1 {TclArraySet [Bug 1669489]} -setup {
+    unset -nocomplain ::a
+} -body {
+    namespace eval :: {
+	set elements {1 2 3 4}
+	trace add variable a write {string length $elements ;#}
+	array set a $elements
+    }
+} -cleanup {
+    unset -nocomplain ::a ::elements
+} -result {}
+
 catch {namespace delete ns}
 catch {unset arr}
 catch {unset v}