summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2007-03-12 20:45:26 (GMT)
committerdgp <dgp@users.sourceforge.net>2007-03-12 20:45:26 (GMT)
commita515e66f386d98551f2ec1185ab2d6a925b03b5f (patch)
tree4b7cb67b16150414d6d59dc83ba0e72bcb4f525b
parenteff94c7a58c193ba8ea8e4b527d89bd7f9a404aa (diff)
downloadtcl-a515e66f386d98551f2ec1185ab2d6a925b03b5f.zip
tcl-a515e66f386d98551f2ec1185ab2d6a925b03b5f.tar.gz
tcl-a515e66f386d98551f2ec1185ab2d6a925b03b5f.tar.bz2
* 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]
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclExecute.c8
-rw-r--r--tests/foreach.test14
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}