summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-11-01 22:13:39 (GMT)
committerhobbs <hobbs>2000-11-01 22:13:39 (GMT)
commit6c75b366647b489cbfab9c56648ec03e116c4252 (patch)
treeda60ed6a2d899771d24a0194e4d4025378f9b814
parent51d45cde58ea58db5d1b872e26b3a031971ea348 (diff)
downloadtcl-6c75b366647b489cbfab9c56648ec03e116c4252.zip
tcl-6c75b366647b489cbfab9c56648ec03e116c4252.tar.gz
tcl-6c75b366647b489cbfab9c56648ec03e116c4252.tar.bz2
* tests/subst.test: added tests for non-zero return code handling
by subst. * generic/tclParse.c (Tcl_EvalEx): corrected handling of non-zero, non-error return code cases for subst. [BUG: 119829]
-rw-r--r--generic/tclParse.c48
-rw-r--r--tests/subst.test80
2 files changed, 108 insertions, 20 deletions
diff --git a/generic/tclParse.c b/generic/tclParse.c
index ab50ac4..96678ef 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -9,12 +9,12 @@
* allow scripts to be evaluated directly, without compiling.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 1998-2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclParse.c,v 1.13 1999/11/10 02:51:57 hobbs Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.14 2000/11/01 22:13:39 hobbs Exp $
*/
#include "tclInt.h"
@@ -1456,15 +1456,51 @@ Tcl_EvalEx(interp, script, numBytes, flags)
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
- p = parse.commandStart + parse.commandSize;
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
Tcl_FreeParse(&parse);
- if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+
+ if ((nested != 0) && (p > script)) {
+ char *nextCmd = NULL; /* pointer to start of next command */
+
/*
* We get here in the special case where the TCL_BRACKET_TERM
- * flag was set in the interpreter and we reached a close
- * bracket in the script. Return immediately.
+ * flag was set in the interpreter.
+ *
+ * At this point, we want to find the end of the script
+ * (either end of script or the closing ']').
*/
+ while ((p[-1] != ']') && bytesLeft) {
+ if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse)
+ != TCL_OK) {
+ /*
+ * We were looking for the ']' to close the script.
+ * But if we find a syntax error, it is ok to quit
+ * early since in that case we no longer need to know
+ * where the ']' is (if there was one). We reset the
+ * pointer to the start of the command that after the
+ * one causing the return. -- hobbs
+ */
+
+ p = (nextCmd == NULL) ? parse.commandStart : nextCmd;
+ break;
+ }
+
+ if (nextCmd == NULL) {
+ nextCmd = parse.commandStart;
+ }
+
+ /*
+ * Advance to the next command in the script.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+ Tcl_FreeParse(&parse);
+ }
iPtr->termOffset = (p - 1) - script;
} else {
iPtr->termOffset = p - script;
diff --git a/tests/subst.test b/tests/subst.test
index b360b6f..1ebceb7 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -6,12 +6,12 @@
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 Ajuba Solutions.
#
# 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.6 2000/04/10 17:19:05 ericm Exp $
+# RCS: @(#) $Id: subst.test,v 1.7 2000/11/01 22:13:39 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -109,18 +109,70 @@ test subst-7.7 {switches} {
subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}
+test subst-8.1 {return in a subst} {
+ subst {foo [return {x}; bogus code] bar}
+} {foo x bar}
+test subst-8.2 {return in a subst} {
+ subst {foo [return x ; bogus code] bar}
+} {foo x bar}
+test subst-8.3 {return in a subst} {
+ subst {foo [if 1 { return {x}; bogus code }] bar}
+} {foo x bar}
+test subst-8.4 {return in a subst} {
+ subst {[eval {return hi}] there}
+} {hi there}
+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}
+test subst-8.7 {return in a subst, parse error} {
+ subst {foo [return {x} ; set a {}" ; stuff] bar}
+} {foo xset a {}" ; stuff] bar}
+test subst-8.8 {return in a subst, parse error} {
+ subst {foo [return {x} ; set bar baz ; set a {}" ; stuff] bar}
+} {foo xset bar baz ; set a {}" ; stuff] bar}
+
+test subst-9.1 {error in a subst} {
+ list [catch {subst {[error foo; bogus code]bar}} msg] $msg
+} {1 foo}
+test subst-9.2 {error in a subst} {
+ list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg
+} {1 foo}
+
+test subst-10.1 {break in a subst} {
+ subst {foo [break; bogus code] bar}
+} {foo bar}
+test subst-10.2 {break in a subst} {
+ subst {foo [break; return x; bogus code] bar}
+} {foo bar}
+test subst-10.3 {break in a subst} {
+ subst {foo [if 1 { break; bogus code}] bar}
+} {foo bar}
+test subst-10.4 {break in a subst, parse error} {
+ subst {foo [break ; set a {}{} ; stuff] bar}
+} {foo set a {}{} ; stuff] bar}
+test subst-10.5 {break in a subst, parse error} {
+ subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar}
+} {foo set bar baz ;set a {}{} ; stuff] bar}
+
+test subst-11.1 {continue in a subst} {
+ subst {foo [continue; bogus code] bar}
+} {foo bar}
+test subst-11.2 {continue in a subst} {
+ subst {foo [continue; return x; bogus code] bar}
+} {foo bar}
+test subst-11.3 {continue in a subst} {
+ subst {foo [if 1 { continue; bogus code}] bar}
+} {foo bar}
+test subst-11.4 {continue in a subst, parse error} {
+ subst {foo [continue ; set a {}{} ; stuff] bar}
+} {foo set a {}{} ; stuff] bar}
+test subst-11.5 {continue in a subst, parse error} {
+ subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
+} {foo set bar baz ;set a {}{} ; stuff] bar}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-