From 0a78bbbd2192fb9210fb701537a53b9bf225c8dd Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Mar 2007 18:06:13 +0000
Subject:         * generic/tclVar.c (TclArraySet):       Make efficient
 private copy of         * tests/var.test (var-17.1):    the "list" argument
 to [array set] to         avoid crash due to shimmering invalidating
 pointers.  [Bug 1669489].

---
 ChangeLog        |  6 ++++++
 generic/tclVar.c |  9 ++++++---
 tests/var.test   | 14 +++++++++++++-
 3 files changed, 25 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1e5d2cb..bb2855b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2007-03-12  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclVar.c (TclArraySet):	Make efficient private copy of
+	* tests/var.test (var-17.1):	the "list" argument to [array set] to
+	avoid crash due to shimmering invalidating pointers.  [Bug 1669489].
+
 2007-03-12  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
 
 	* generic/tclCmdIL.c (Tcl_LsortObjCmd): Fix problems with declaration
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 13d5dc6..17b859c 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.127 2007/02/20 23:24:03 nijtmans Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.128 2007/03/12 18:06:14 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3023,8 +3023,7 @@ TclArraySet(
 				 * 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 @@ TclArraySet(
 	 * 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 @@ TclArraySet(
 	 * 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 @@ TclArraySet(
 		break;
 	    }
 	}
+	Tcl_DecrRefCount(copyListObj);
 	return result;
     }
 
diff --git a/tests/var.test b/tests/var.test
index b3fc475..57c6fe4 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: var.test,v 1.27 2006/10/09 19:15:45 msofer Exp $
+# RCS: @(#) $Id: var.test,v 1.28 2007/03/12 18:06:14 dgp Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -702,6 +702,18 @@ test var-16.1 {CallVarTraces: save/restore interp error state} {
     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}
-- 
cgit v0.12