diff options
| -rw-r--r-- | generic/tclParse.c | 48 | ||||
| -rw-r--r-- | tests/subst.test | 80 |
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 - - - - - - - - - - - - |