Don Porter's fix for bad parsing of nested scripts [Bug 681841].

6 files changed, 34 insertions, 15 deletions

diff --git a/tests/basic.test b/tests/basic.test
index dbc5216..c45a763 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -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: basic.test,v 1.24 2003/02/04 17:06:52 vincentdarley Exp $
+# RCS: @(#) $Id: basic.test,v 1.25 2003/02/16 01:36:32 msofer Exp $
 #
 
 package require tcltest 2
@@ -638,6 +638,10 @@ test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
 "return -code return"
     (file "BREAKtest" line 2)}}
 
+test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
+    subst {a[set b [format cd]}
+} -returnCodes error -result {missing close-bracket}
+
 
 # cleanup
 catch {eval namespace delete [namespace children :: test_ns_*]}
diff --git a/tests/main.test b/tests/main.test
index c005c41..6778b88 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -1,6 +1,6 @@
 # This file contains a collection of tests for generic/tclMain.c.
 #
-# RCS: @(#) $Id: main.test,v 1.12 2003/01/31 18:54:32 dgp Exp $
+# RCS: @(#) $Id: main.test,v 1.13 2003/02/16 01:36:32 msofer Exp $
 
 if {[catch {package require tcltest 2.0.2}]} {
     puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -277,13 +277,13 @@ namespace eval ::tcl::test::main {
     } -body {
 	set code [catch {exec [interpreter] script >& result} result]
 	set f [open result]
-	list $code $result [read $f]
+	join [list $code $result [read $f]] \n
     } -cleanup {
 	close $f
 	file delete result
 	removeFile script
-    } -match glob -result [list 1 {child process exited abnormally}\
-	"missing close-brace\n    while executing*"]
+    } -match glob -result [join [list 1 {child process exited abnormally}\
+	"missing close-brace\n    while executing*"] \n]
 
     test Tcl_Main-3.5 {
 	Tcl_Main: startup script sets main loop
diff --git a/tests/misc.test b/tests/misc.test
index 12ef1bd..d6536b7 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -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: misc.test,v 1.5 2000/04/10 17:19:02 ericm Exp $
+# RCS: @(#) $Id: misc.test,v 1.6 2003/02/16 01:36:32 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -51,13 +51,20 @@ test misc-1.2 {error in variable ref. in command in array reference} {
 	# this is a bogus comment
     "
     set msg {}
-    list [catch tstProc msg] $msg $errorInfo
-} {1 {missing close-brace for variable name} {missing close-brace for variable name
+    join [list [catch tstProc msg] $msg $errorInfo] \n
+} [subst -novariables -nocommands {1
+missing close-brace for variable name
+missing close-brace for variable name
     while compiling
-"set tst $a([winfo name "
+"set tst $a([winfo name $\{zz)
+	# this is a bogus comment
+	# this is a bogus comment
+	# this is a bogus comment
+	# this is a bogus comment
+	# this is a ..."
     (compiling body of proc "tstProc", line 4)
     invoked from within
-"tstProc"}}
+"tstProc"}]
 
 # cleanup
 ::tcltest::cleanupTests
diff --git a/tests/parse.test b/tests/parse.test
index 8dcf480..95330be 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: parse.test,v 1.10 2003/02/11 18:27:37 hobbs Exp $
+# RCS: @(#) $Id: parse.test,v 1.11 2003/02/16 01:36:32 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -209,6 +209,10 @@ test parse-6.16 {ParseTokens procedure, backslash substitution} {
 test parse-6.17 {ParseTokens procedure, null characters} {
     testparser [bytestring "foo\0zz"] 0
 } "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}"
+test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} {
+    # Test for Bug 681841
+    list [catch {testparser {[a]} 2} msg] $msg
+} {1 {missing close-bracket}}
 
 test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
     testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index ad5bd17..7b87b85 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: parseExpr.test,v 1.9 2002/12/11 20:30:16 dgp Exp $
+# RCS: @(#) $Id: parseExpr.test,v 1.10 2003/02/16 01:36:32 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -491,6 +491,10 @@ test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message}
 test parseExpr-15.35 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
     list [catch {testexprparser {(: 123 : 456)} -1} msg] $msg
 } {1 {syntax error in expression "(: 123 : 456)": unexpected ternary 'else' separator}}
+test parseExpr-15.36 {ParsePrimaryExpr procedure, missing close-bracket} {
+    # Test for Bug 681841
+    list [catch {testexprparser {[set a [format bc]} -1} msg] $msg
+} {1 {missing close-bracket}}
 
 test parseExpr-16.1 {GetLexeme procedure, whitespace before lexeme} {
     testexprparser {   123} -1
diff --git a/tests/subst.test b/tests/subst.test
index 0ff69f8..0e46f02 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -11,7 +11,7 @@
 # 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.12 2002/08/08 15:28:55 msofer Exp $
+# RCS: @(#) $Id: subst.test,v 1.13 2003/02/16 01:36:32 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -156,8 +156,8 @@ test subst-8.5 {return in a subst} {
     subst {foo [return {]}; bogus code] bar}
 } {foo ] bar}
 test subst-8.6 {return in a subst} {
-    subst {foo [return {x}; bogus code bar}
-} {foo x}
+    list [catch {subst {foo [return {x}; bogus code bar}} msg] $msg
+} {1 {missing close-bracket}}
 test subst-8.7 {return in a subst, parse error} {
     subst {foo [return {x} ; set a {}" ; stuff] bar}
 } {foo xset a {}" ; stuff] bar}