Tcl Source Code

Artifact 5226c17002705b17f1c56740febbe6b150681f54:

Attachment "1115904.patch" to ticket [1115904fff] added by dgp 2005-02-04 23:56:42.

---

? solaris
? noe.patch
? solthread
? thread
? debug
? 1077005.patch
? safe.patch
? all
? solbug
? solall
? mask.patch
? tcl-die-dbgx-die.patch
? 1081541.patch
? 1083082.patch
? pod.patch
? 1101670.patch
? ip.patch
? undo.patch
? dgp.patch
? 1115904.patch
? library/package.tcl.ip
? unix/.nfs00000000000336a40000004f
? unix/dltest.marker
? unix/st1zQ1vB
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.140
diff -u -r1.140 tclBasic.c
--- generic/tclBasic.c	28 Jan 2005 01:49:50 -0000	1.140
+++ generic/tclBasic.c	4 Feb 2005 16:53:55 -0000
@@ -3538,16 +3538,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++) {
@@ -3583,7 +3573,16 @@
 
     error:
     /* Generate and log various pieces of error information. */
-
+	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/tclParse.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclParse.c,v
retrieving revision 1.39
diff -u -r1.39 tclParse.c
--- generic/tclParse.c	26 Oct 2004 21:52:37 -0000	1.39
+++ generic/tclParse.c	4 Feb 2005 16:53:56 -0000
@@ -2001,11 +2001,18 @@
 		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--;
 		appendObj = Tcl_GetObjResult(interp);
 		break;
+	    }
 
 	    case TCL_TOKEN_VARIABLE: {
 		Tcl_Obj *arrayIndex = NULL;
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.36
diff -u -r1.36 basic.test
--- tests/basic.test	18 Nov 2004 19:22:12 -0000	1.36
+++ tests/basic.test	4 Feb 2005 16:53:57 -0000
@@ -567,9 +567,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.19
diff -u -r1.19 parse.test
--- tests/parse.test	1 Oct 2004 03:10:36 -0000	1.19
+++ tests/parse.test	4 Feb 2005 16:53:58 -0000
@@ -944,6 +944,52 @@
     set a
 } 1
 
+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*}
+
     cleanupTests
 }