From f10d81b895d8ca9d30428aac9884685fb284986a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 8 Apr 2010 13:26:23 +0000
Subject: 	* generic/tclCompCmdsSZ.c (TclSubstCompile): If the first
 token does 	not result in a *guaranteed* push of a Tcl_Obj on the stack,
 we must 	push an empty object. Otherwise it is possible to get to a
 'concat1' 	or 'done' without enough values on the stack, resulting in a
 crash. 	Thanks to Joe Mistachkin for identifying a script that could
 trigger 	this case.

---
 ChangeLog               |  9 +++++++++
 generic/tclCompCmdsSZ.c | 25 ++++++++++++++++++++++---
 tests/subst.test        | 20 +++++++++++++++++---
 3 files changed, 48 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 2df8edc..a232ac5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2010-04-08  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmdsSZ.c (TclSubstCompile): If the first token does
+	not result in a *guaranteed* push of a Tcl_Obj on the stack, we must
+	push an empty object. Otherwise it is possible to get to a 'concat1'
+	or 'done' without enough values on the stack, resulting in a crash.
+	Thanks to Joe Mistachkin for identifying a script that could trigger
+	this case.
+
 2010-04-07  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/catch.n, doc/info.n, doc/return.n: Formatting.
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index b19dfc8..3d45833 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -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: tclCompCmdsSZ.c,v 1.7 2010/03/27 22:40:14 nijtmans Exp $
+ * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.8 2010/04/08 13:26:24 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -659,7 +659,21 @@ TclSubstCompile(
 
     TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
 
-    for (tokenPtr = parse.tokenPtr, endTokenPtr = tokenPtr + parse.numTokens;
+    /*
+     * Tricky point! If the first token does not result in a *guaranteed* push
+     * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it
+     * is possible to get to an INST_CONCAT1 or INST_DONE without enough
+     * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for
+     * identifying a script that could trigger this case.
+     */
+
+    tokenPtr = parse.tokenPtr;
+    if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
+	PushLiteral(envPtr, "", 0);
+	count++;
+    }
+
+    for (endTokenPtr = tokenPtr + parse.numTokens;
 	    tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
 	int length, literal, catchRange, breakJump;
 	char buf[TCL_UTF_MAX];
@@ -790,7 +804,11 @@ TclSubstCompile(
 	    Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
 		    CurrentOffset(envPtr) - otherFixup.codeOffset);
 	}
-	/* Pull the result to top of stack, discard options dict */
+
+	/*
+	 * Pull the result to top of stack, discard options dict.
+	 */
+
 	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
 	TclEmitOpcode(INST_POP, envPtr);
 
@@ -802,6 +820,7 @@ TclSubstCompile(
 	 * through them all.  So, we now have a stack requirements estimate
 	 * that is too low.  Here we manually fix that up.
 	 */
+
 	TclAdjustStackDepth(5, envPtr);
 
 	/* OK destination */
diff --git a/tests/subst.test b/tests/subst.test
index a7d6feb..1b9ccf6 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -11,13 +11,13 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: subst.test,v 1.19 2008/04/23 15:44:38 dkf Exp $
+# RCS: @(#) $Id: subst.test,v 1.20 2010/04/08 13:26:25 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2.1
     namespace import -force ::tcltest::*
 }
-
+
 test subst-1.1 {basics} -returnCodes error -body {
     subst
 } -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
@@ -261,7 +261,21 @@ test subst-12.5 {nasty case, Bug 1036649} {
     }
     lappend res $x
 } {1 {missing close-bracket} 0}
-
+test subst-12.6 {nasty case with compilation} {
+    set x unset
+    set y unset
+    list [eval [list subst {[set x 1;break;incr x][set y $x]}]] $x $y
+} {{} 1 unset}
+test subst-12.7 {nasty case with compilation} {
+    set x unset
+    set y unset
+    list [eval [list subst {[set x 1;continue;incr x][set y $x]}]] $x $y
+} {1 1 1}
+
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12