From a515e66f386d98551f2ec1185ab2d6a925b03b5f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Mar 2007 20:45:26 +0000
Subject:         * generic/tclExecute.c (INST_FOREACH_STEP4):    Make private
 copy         * tests/foreach.test (foreach-10.1):    of value list to be
 assigned         to variables so that shimmering of that list doesn't lead to
 invalid         pointers.  [Bug 1671087]

---
 ChangeLog            |  5 +++++
 generic/tclExecute.c |  8 +++++---
 tests/foreach.test   | 14 +++++++++++++-
 3 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 0a38290..4337a5d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 2007-03-12  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclExecute.c (INST_FOREACH_STEP4):	Make private copy
+	* tests/foreach.test (foreach-10.1):	of value list to be assigned
+	to variables so that shimmering of that list doesn't lead to invalid
+	pointers.  [Bug 1671087]
+
 	* generic/tclEvent.c (HandleBgErrors):	Make efficient private copy
 	* tests/event.test (event-5.3):	of the command prefix for the interp's
 	background error handling command to avoid panics due to pointers
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c64f171..6c39e01 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.260 2007/03/02 10:32:12 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.261 2007/03/12 20:45:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -5305,8 +5305,8 @@ TclExecuteByteCode(
 		numVars = varListPtr->numVars;
 
 		listVarPtr = &(compiledLocals[listTmpIndex]);
-		listPtr = listVarPtr->value.objPtr;
-		Tcl_ListObjGetElements(interp, listPtr, &listLen, &elements);
+		listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
+		Tcl_ListObjGetElements(NULL, listPtr, &listLen, &elements);
 
 		valIndex = (iterNum * numVars);
 		for (j = 0;  j < numVars;  j++) {
@@ -5343,11 +5343,13 @@ TclExecuteByteCode(
 			    TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
 				    opnd, varIndex), Tcl_GetObjResult(interp));
 			    result = TCL_ERROR;
+			    Tcl_DecrRefCount(listPtr);
 			    goto checkForCatch;
 			}
 		    }
 		    valIndex++;
 		}
+		Tcl_DecrRefCount(listPtr);
 		listTmpIndex++;
 	    }
 	}
diff --git a/tests/foreach.test b/tests/foreach.test
index a49ceaa..8fb5144 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: foreach.test,v 1.12 2007/03/01 17:55:16 dgp Exp $
+# RCS: @(#) $Id: foreach.test,v 1.13 2007/03/12 20:45:27 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -256,6 +256,18 @@ test foreach-9.1 {compiled empty var list} {
     list [catch { foo } msg] $msg
 } {1 {foreach varlist is empty}}
 
+test foreach-10.1 {foreach: [Bug 1671087]} -setup {
+    proc demo {} {
+	set vals {1 2 3 4}
+	trace add variable x write {string length $vals ;# }
+	foreach {x y} $vals {format $y}
+    }
+} -body {
+    demo
+} -cleanup {
+    rename demo {}
+} -result {}
+
 # cleanup
 catch {unset a}
 catch {unset x}
-- 
cgit v0.12