Attachment "1115904-84.patch" to
ticket [1115904fff]
added by
dgp
2005-03-18 23:34:47.
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.1453.2.416
diff -u -r1.1453.2.416 ChangeLog
--- ChangeLog 18 Mar 2005 15:32:27 -0000 1.1453.2.416
+++ ChangeLog 18 Mar 2005 16:29:06 -0000
@@ -1,8 +1,17 @@
2005-03-17 Don Porter <[email protected]>
- * generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks
- for immediate operand usage to permit leading space and sign
- characters. [Bug 1165671]
+ * generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks
+ for immediate operand usage to permit leading space and sign
+ characters. Restores more efficient bytecode for [incr x -1]
+ that got lost in the CONST string reforms of Tcl 8.4. [Bug 1165671]
+
+ * generic/tclBasic.c (Tcl_EvalEx,TclEvalTokensStandard):
+ * generic/tclCmdMZ.c (Tcl_SubstObj):
+ * tests/basic.test (basic-46.4): Restored recursion limit
+ * tests/parse.test (parse-19.*): testing in nested command
+ substitutions within direct script evaluation (Tcl_EvalEx)
+ that got lost in the parser reforms of Tcl 8.1. Added tests for
+ correct behavior. [Bug 1115904]
2005-03-15 Vince Darley <[email protected]>
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.75.2.13
diff -u -r1.75.2.13 tclBasic.c
--- generic/tclBasic.c 10 Feb 2005 19:03:59 -0000 1.75.2.13
+++ generic/tclBasic.c 18 Mar 2005 16:29:06 -0000
@@ -3405,14 +3405,21 @@
p = buffer;
break;
- case TCL_TOKEN_COMMAND:
- code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
- 0);
+ case TCL_TOKEN_COMMAND: {
+ Interp *iPtr = (Interp *) interp;
+ iPtr->numLevels++;
+ code = TclInterpReady(interp);
+ if (code == TCL_OK) {
+ code = Tcl_EvalEx(interp,
+ tokenPtr->start+1, tokenPtr->size-2, 0);
+ }
+ iPtr->numLevels--;
if (code != TCL_OK) {
goto done;
}
valuePtr = Tcl_GetObjResult(interp);
break;
+ }
case TCL_TOKEN_VARIABLE:
if (tokenPtr->numComponents == 1) {
@@ -3683,16 +3690,6 @@
parse.commandStart, parse.commandSize, 0);
iPtr->numLevels--;
if (code != TCL_OK) {
- if (iPtr->numLevels == 0) {
- if (code == TCL_RETURN) {
- code = TclUpdateReturnInfo(iPtr);
- }
- if ((code != TCL_OK) && (code != TCL_ERROR)
- && !allowExceptions) {
- ProcessUnexpectedResult(interp, code);
- code = TCL_ERROR;
- }
- }
goto error;
}
for (i = 0; i < objectsUsed; i++) {
@@ -3749,6 +3746,16 @@
* to the command.
*/
+ if (iPtr->numLevels == 0) {
+ if (code == TCL_RETURN) {
+ code = TclUpdateReturnInfo(iPtr);
+ }
+ if ((code != TCL_OK) && (code != TCL_ERROR)
+ && !allowExceptions) {
+ ProcessUnexpectedResult(interp, code);
+ code = TCL_ERROR;
+ }
+ }
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.82.2.14
diff -u -r1.82.2.14 tclCmdMZ.c
--- generic/tclCmdMZ.c 10 Mar 2005 20:22:42 -0000 1.82.2.14
+++ generic/tclCmdMZ.c 18 Mar 2005 16:29:07 -0000
@@ -20,6 +20,7 @@
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
+#include "tclCompile.h"
/*
* Structure used to hold information about variable traces:
@@ -2652,7 +2653,12 @@
Tcl_AppendToObj(resultObj, old, p-old);
}
iPtr->evalFlags = TCL_BRACKET_TERM;
- code = Tcl_EvalEx(interp, p+1, -1, 0);
+ iPtr->numLevels++;
+ code = TclInterpReady(interp);
+ if (code == TCL_OK) {
+ code = Tcl_EvalEx(interp, p+1, -1, 0);
+ }
+ iPtr->numLevels--;
switch (code) {
case TCL_ERROR:
goto errorResult;
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.25.2.6
diff -u -r1.25.2.6 basic.test
--- tests/basic.test 10 Feb 2005 18:58:36 -0000 1.25.2.6
+++ tests/basic.test 18 Mar 2005 16:29:07 -0000
@@ -652,9 +652,7 @@
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
- while executing
-"break"
- invoked from within
+ while executing*
"foo \[set a 1] \[break]"
(file "*BREAKtest" line 2)}
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.11.2.1
diff -u -r1.11.2.1 parse.test
--- tests/parse.test 27 Mar 2003 13:49:22 -0000 1.11.2.1
+++ tests/parse.test 18 Mar 2005 16:29:07 -0000
@@ -744,6 +744,52 @@
catch {eval {w[continue]}}
} 4
+test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
+ testevalex
+} -setup {
+ interp create i
+ load {} Tcltest i
+ i eval {proc {} args {}}
+ interp recursionlimit i 3
+} -body {
+ i eval {testevalex {[]}}
+} -cleanup {
+ interp delete i
+}
+
+test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
+ testevalex
+} -setup {
+ interp create i
+ load {} Tcltest i
+ i eval {proc {} args {}}
+ interp recursionlimit i 3
+} -body {
+ i eval {testevalex {[[]]}}
+} -cleanup {
+ interp delete i
+} -returnCodes error -match glob -result {too many nested*}
+
+test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
+ interp create i
+ i eval {proc {} args {}}
+ interp recursionlimit i 3
+} -body {
+ i eval {subst {[]}}
+} -cleanup {
+ interp delete i
+}
+
+test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
+ interp create i
+ i eval {proc {} args {}}
+ interp recursionlimit i 3
+} -body {
+ i eval {subst {[[]]}}
+} -cleanup {
+ interp delete i
+} -returnCodes error -match glob -result {too many nested*}
+
# cleanup
catch {unset a}
::tcltest::cleanupTests
