Attachment "681841-final.patch" to
ticket [681841ffff]
added by
dgp
2003-02-14 01:08:44.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.72
diff -u -r1.72 tclBasic.c
--- generic/tclBasic.c 3 Feb 2003 20:16:52 -0000 1.72
+++ generic/tclBasic.c 13 Feb 2003 17:45:59 -0000
@@ -3579,13 +3579,6 @@
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
- /* For nested scripts, this variable will be set to point to the first
- * char after the end of the script - needed only to compare pointers,
- * nothing will be read nor written there.
- */
-
- CONST char *onePast = NULL;
-
/*
* The variables below keep track of how much state has been
* allocated while evaluating the script, so that it can be freed
@@ -3614,7 +3607,6 @@
bytesLeft = numBytes;
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
- onePast = script + numBytes;
} else {
nested = 0;
}
@@ -3627,14 +3619,13 @@
}
gotParse = 1;
- /*
- * A nested script can only terminate in ']'. If the script is not
- * nested, onePast is NULL and the second test is not performed.
- */
+ if (nested && parse.term == (script + numBytes)) {
+ /*
+ * A nested script can only terminate in ']'. If
+ * the parsing got terminated at the end of the script,
+ * there was no closing ']'. Report the syntax error.
+ */
- next = parse.commandStart + parse.commandSize;
- if ((next == onePast) && (onePast[-1] != ']')) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1));
code = TCL_ERROR;
goto error;
}
@@ -3702,15 +3693,17 @@
* Advance to the next command in the script.
*/
+ next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ if (nested && (*parse.term == ']')) {
/*
* 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 and the latest parsed command
+ * was terminated by tghe matching close-bracket we seek.
+ * Return immediately.
*/
iPtr->termOffset = (p - 1) - script;
@@ -3732,12 +3725,12 @@
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
- if ((parse.commandStart + commandLength) != (script + numBytes)) {
+ if (parse.term == parse.commandStart + commandLength - 1) {
/*
- * The command where the error occurred didn't end at the end
- * of the script (i.e. it ended at a terminator character such
- * as ";". Reduce the length by one so that the error message
- * doesn't include the terminator character.
+ * The terminator character (such as ; or ]) of the command where
+ * the error occurred is the last character in the parsed command.
+ * Reduce the length by one so that the error message doesn't
+ * include the terminator character.
*/
commandLength -= 1;
@@ -3749,60 +3742,91 @@
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
Tcl_FreeParse(&parse);
+ }
+ if (objv != staticObjArray) {
+ ckfree((char *) objv);
+ }
+ iPtr->varFramePtr = savedVarFramePtr;
- if ((nested != 0) && (p > script)) {
- CONST char *nextCmd = NULL; /* pointer to start of next command */
+ /*
+ * All that's left to do before returning is to set iPtr->termOffset
+ * to point past the end of the script we just evaluated.
+ */
- /*
- * We get here in the special case where the TCL_BRACKET_TERM
- * 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
- */
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+
+ if (!nested) {
+ iPtr->termOffset = p - script;
+ return code;
+ }
- p = (nextCmd == NULL) ? parse.commandStart : nextCmd;
- break;
- }
+ /*
+ * When we are nested (the TCL_BRACKET_TERM flag was set in the
+ * interpreter), we must find the matching close-bracket to
+ * end the script we are evaluating.
+ *
+ * When our return code is TCL_CONTINUE or TCL_RETURN, we want
+ * to correctly set iPtr->termOffset to point to that matching
+ * close-bracket so our caller can move to the part of the
+ * string beyond the script we were asked to evaluate.
+ * So we try to parse past the rest of the commands.
+ */
- if (nextCmd == NULL) {
- nextCmd = parse.commandStart;
- }
+ next = NULL;
+ while (bytesLeft && (*parse.term != ']')) {
+ if (TCL_OK != Tcl_ParseCommand(NULL, p, bytesLeft, 1, &parse)) {
+ /*
+ * Syntax error. Set the termOffset to the beginning of
+ * the last command parsed.
+ */
- /*
- * Advance to the next command in the script.
- */
-
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
- Tcl_FreeParse(&parse);
+ if (next == NULL) {
+ iPtr->termOffset = (parse.commandStart - 1) - script;
+ } else {
+ iPtr->termOffset = (next - 1) - script;
}
- iPtr->termOffset = (p - 1) - script;
- } else {
- iPtr->termOffset = p - script;
- }
+ return code;
+ }
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+ next = parse.commandStart;
+ Tcl_FreeParse(&parse);
}
- if (objv != staticObjArray) {
- ckfree((char *) objv);
+
+ if (bytesLeft) {
+ /*
+ * parse.term points to the close-bracket.
+ */
+
+ iPtr->termOffset = parse.term - script;
+ } else if (parse.term == script + numBytes) {
+ /*
+ * There was no close-bracket. Syntax error.
+ */
+
+ iPtr->termOffset = parse.term - script;
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing close-bracket", -1));
+ return TCL_ERROR;
+ } else if (*parse.term != ']') {
+ /*
+ * There was no close-bracket. Syntax error.
+ */
+
+ iPtr->termOffset = (parse.term + 1) - script;
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing close-bracket", -1));
+ return TCL_ERROR;
+ } else {
+ /*
+ * parse.term points to the close-bracket.
+ */
+ iPtr->termOffset = parse.term - script;
}
- iPtr->varFramePtr = savedVarFramePtr;
return code;
}
Index: generic/tclCompExpr.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompExpr.c,v
retrieving revision 1.12
diff -u -r1.12 tclCompExpr.c
--- generic/tclCompExpr.c 5 Aug 2002 03:24:40 -0000 1.12
+++ generic/tclCompExpr.c 13 Feb 2003 17:45:59 -0000
@@ -398,7 +398,7 @@
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 1, envPtr);
+ tokenPtr->size-2, /*nested*/ 0, envPtr);
if (code != TCL_OK) {
goto done;
}
Index: generic/tclCompile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.c,v
retrieving revision 1.41
diff -u -r1.41 tclCompile.c
--- generic/tclCompile.c 24 Sep 2002 12:53:33 -0000 1.41
+++ generic/tclCompile.c 13 Feb 2003 17:45:59 -0000
@@ -798,7 +798,9 @@
int
TclCompileScript(interp, script, numBytes, nested, envPtr)
- Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Interp *interp; /* Used for error and status reporting.
+ * Also serves as context for finding and
+ * compiling commands. May not be NULL. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
@@ -824,7 +826,6 @@
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
int commandLength, objIndex, code;
- char prev;
Tcl_DString ds;
Tcl_DStringInit(&ds);
@@ -843,12 +844,55 @@
p = script;
bytesLeft = numBytes;
gotParse = 0;
- while (bytesLeft > 0) {
+ do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
+ if (nested) {
+ /*
+ * This is an unusual situation where the caller has passed us
+ * a non-zero value for "nested". How unusual? Well, this
+ * procedure, TclCompileScript, is internal to Tcl, so all
+ * callers should be within Tcl itself. All but one of those
+ * callers explicitly pass in (nested = 0). The exceptional
+ * caller is TclSetByteCodeFromAny, which will pass in
+ * (nested = 1) if and only if the flag TCL_BRACKET_TERM
+ * is set in the evalFlags field of interp.
+ *
+ * It appears that the TCL_BRACKET_TERM flag is only ever set
+ * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
+ * which clears the flag before passing the interp along.
+ * So, I don't think this procedure, TclCompileScript, is
+ * **ever** called with (nested != 0).
+ *
+ * This means that the branches in this procedure that are
+ * only active when (nested != 0) are probably never exercised.
+ * This means that any bugs in them go unnoticed, and any bug
+ * fixes in them have a semi-theoretical nature.
+ *
+ * All that said, the spec for this procedure says it should
+ * handle the (nested != 0) case, so here's an attempt to fix
+ * bugs (Tcl Bug 681841) in that case. Just in case some
+ * callers eventually come along and expect it to work...
+ */
+
+ if (parse.term == (script + numBytes)) {
+ /*
+ * The (nested != 0) case is meant to indicate that the
+ * caller found an open bracket ([) and asked us to
+ * parse and compile Tcl commands up to the matching
+ * close bracket (]). We have to detect and handle
+ * the case where the close bracket is missing.
+ */
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("missing close-bracket", -1));
+ code = TCL_ERROR;
+ goto error;
+ }
+ }
if (parse.numWords > 0) {
/*
* If not the first command, pop the previous command's result
@@ -870,15 +914,10 @@
*/
commandLength = parse.commandSize;
- prev = '\0';
- if (commandLength > 0) {
- prev = parse.commandStart[commandLength-1];
- }
- if (((parse.commandStart+commandLength) != (script+numBytes))
- || ((prev=='\n') || (nested && (prev==']')))) {
+ if (parse.term == parse.commandStart + commandLength - 1) {
/*
- * The command didn't end at the end of the script (i.e. it
- * ended at a terminator character such as ";". Reduce the
+ * The command terminator character (such as ; or ]) is
+ * the last character in the parsed command. Reduce the
* length by one so that the trace message doesn't include
* the terminator character.
*/
@@ -963,7 +1002,7 @@
* claimed to be in (*envPtr).
*/
envPtr->numCommands--;
- goto error;
+ goto log;
}
}
@@ -993,7 +1032,7 @@
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
- goto error;
+ goto log;
}
}
}
@@ -1031,16 +1070,17 @@
p = next;
Tcl_FreeParse(&parse);
gotParse = 0;
- if (nested && (p[-1] == ']')) {
+ if (nested && (*parse.term == ']')) {
/*
* We get here in the special case where TCL_BRACKET_TERM was
- * set in the interpreter and we reached a close bracket in the
- * script. Stop compilation.
+ * set in the interpreter and the latest parsed command was
+ * terminated by the matching close-bracket we were looking for.
+ * Stop compilation.
*/
break;
}
- }
+ } while (bytesLeft > 0);
/*
* If the source script yielded no instructions (e.g., if it was empty),
@@ -1052,7 +1092,13 @@
envPtr);
}
- if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ if (nested) {
+ /*
+ * When (nested != 0) back up 1 character to have
+ * iPtr->termOffset indicate the offset to the matching
+ * close-bracket.
+ */
+
iPtr->termOffset = (p - 1) - script;
} else {
iPtr->termOffset = (p - script);
@@ -1069,21 +1115,18 @@
*/
commandLength = parse.commandSize;
- prev = '\0';
- if (commandLength > 0) {
- prev = parse.commandStart[commandLength-1];
- }
- if (((parse.commandStart+commandLength) != (script+numBytes))
- || ((prev == '\n') || (nested && (prev == ']')))) {
+ if (parse.term == parse.commandStart + commandLength - 1) {
/*
- * The command where the error occurred didn't end at the end
- * of the script (i.e. it ended at a terminator character such
- * as ";". Reduce the length by one so that the error message
- * doesn't include the terminator character.
+ * The terminator character (such as ; or ]) of the command where
+ * the error occurred is the last character in the parsed command.
+ * Reduce the length by one so that the error message doesn't
+ * include the terminator character.
*/
commandLength -= 1;
}
+
+ log:
LogCompilationInfo(interp, script, parse.commandStart, commandLength);
if (gotParse) {
Tcl_FreeParse(&parse);
@@ -1163,7 +1206,7 @@
}
code = TclCompileScript(interp, tokenPtr->start+1,
- tokenPtr->size-2, /*nested*/ 1, envPtr);
+ tokenPtr->size-2, /*nested*/ 0, envPtr);
if (code != TCL_OK) {
goto error;
}
Index: generic/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.24
diff -u -r1.24 tclParse.c
--- generic/tclParse.c 11 Feb 2003 18:34:43 -0000 1.24
+++ generic/tclParse.c 13 Feb 2003 17:46:00 -0000
@@ -306,6 +306,7 @@
scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
src += scanned; numBytes -= scanned;
if (numBytes == 0) {
+ parsePtr->term = src;
break;
}
if ((type & terminators) != 0) {
@@ -376,6 +377,7 @@
}
if (numBytes == 0) {
+ parsePtr->term = src;
break;
}
if ((type & terminators) != 0) {
@@ -408,7 +410,7 @@
if (parsePtr->commandStart == NULL) {
parsePtr->commandStart = string;
}
- parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
+ parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
return TCL_ERROR;
}
@@ -859,10 +861,24 @@
}
src = nested.commandStart + nested.commandSize;
numBytes = parsePtr->end - src;
+
+ /*
+ * This is equivalent to Tcl_FreeParse(&nested), but
+ * presumably inlined here for sake of runtime optimization
+ */
+
if (nested.tokenPtr != nested.staticTokens) {
ckfree((char *) nested.tokenPtr);
}
- if ((*nested.term == ']') && !nested.incomplete) {
+
+ /*
+ * Check for the closing ']' that ends the command
+ * substitution. It must have been the last character of
+ * the parsed command.
+ */
+
+ if ((nested.term < parsePtr->end) && (*nested.term == ']')
+ && !nested.incomplete) {
break;
}
if (numBytes == 0) {
Index: generic/tclParseExpr.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParseExpr.c,v
retrieving revision 1.16
diff -u -r1.16 tclParseExpr.c
--- generic/tclParseExpr.c 11 Dec 2002 20:30:16 -0000 1.16
+++ generic/tclParseExpr.c 13 Feb 2003 17:46:00 -0000
@@ -1287,10 +1287,23 @@
return TCL_ERROR;
}
src = (nested.commandStart + nested.commandSize);
+
+ /*
+ * This is equivalent to Tcl_FreeParse(&nested), but
+ * presumably inlined here for sake of runtime optimization
+ */
+
if (nested.tokenPtr != nested.staticTokens) {
ckfree((char *) nested.tokenPtr);
}
- if ((src[-1] == ']') && !nested.incomplete) {
+
+ /*
+ * Check for the closing ']' that ends the command substitution.
+ * It must have been the last character of the parsed command.
+ */
+
+ if ((nested.term < parsePtr->end) && (*nested.term == ']')
+ && !nested.incomplete) {
break;
}
if (src == parsePtr->end) {
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.24
diff -u -r1.24 basic.test
--- tests/basic.test 4 Feb 2003 17:06:52 -0000 1.24
+++ tests/basic.test 13 Feb 2003 17:46:00 -0000
@@ -638,6 +638,10 @@
"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_*]}
Index: tests/main.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/main.test,v
retrieving revision 1.12
diff -u -r1.12 main.test
--- tests/main.test 31 Jan 2003 18:54:32 -0000 1.12
+++ tests/main.test 13 Feb 2003 17:46:00 -0000
@@ -277,13 +277,13 @@
} -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
Index: tests/misc.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/misc.test,v
retrieving revision 1.5
diff -u -r1.5 misc.test
--- tests/misc.test 10 Apr 2000 17:19:02 -0000 1.5
+++ tests/misc.test 13 Feb 2003 17:46:00 -0000
@@ -51,13 +51,20 @@
# 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
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.10
diff -u -r1.10 parse.test
--- tests/parse.test 11 Feb 2003 18:27:37 -0000 1.10
+++ tests/parse.test 13 Feb 2003 17:46:00 -0000
@@ -209,6 +209,10 @@
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.17 {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
Index: tests/parseExpr.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parseExpr.test,v
retrieving revision 1.9
diff -u -r1.9 parseExpr.test
--- tests/parseExpr.test 11 Dec 2002 20:30:16 -0000 1.9
+++ tests/parseExpr.test 13 Feb 2003 17:46:00 -0000
@@ -491,6 +491,10 @@
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
Index: tests/subst.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/subst.test,v
retrieving revision 1.12
diff -u -r1.12 subst.test
--- tests/subst.test 8 Aug 2002 15:28:55 -0000 1.12
+++ tests/subst.test 13 Feb 2003 17:46:01 -0000
@@ -156,8 +156,8 @@
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}
