* Corrected problems with Tcl_AllowExceptions

        having influence over the wrong scope of Tcl_*Eval* calls.  Patch
        from Miguel Sofer.  Report from Jean-Claude Wippler.  [Bug 219181]

6 files changed, 102 insertions, 41 deletions

diff --git a/ChangeLog b/ChangeLog
index a3ff502..fd6125e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2002-03-29  Don Porter  <dgp@users.sourceforge.net>
+
+	* doc/AllowExc.3:
+	* generic/tclBasic.c (Tcl_EvalObjv,Tcl_EvalEx,Tcl_EvalObjEx):
+	* generic/tclCompile.h (TclCompEvalObj):
+	* generic/tclExecute.c (TclCompEvalObj,TclExecuteByteCode):
+	* tests/basic.test: Corrected problems with Tcl_AllowExceptions
+	having influence over the wrong scope of Tcl_*Eval* calls.  Patch
+	from Miguel Sofer.  Report from Jean-Claude Wippler.  [Bug 219181]
+
 2002-03-28  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclVar.c: Refactored CallTraces to collect repeated
diff --git a/doc/AllowExc.3 b/doc/AllowExc.3
index 1145fa4..17d6ec0 100644
--- a/doc/AllowExc.3
+++ b/doc/AllowExc.3
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: AllowExc.3,v 1.2 1998/09/14 18:39:45 stanton Exp $
+'\" RCS: @(#) $Id: AllowExc.3,v 1.3 2002/03/29 21:01:11 dgp Exp $
 '\" 
 .so man.macros
 .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures"
@@ -27,12 +27,16 @@ Interpreter in which script will be evaluated.
 .PP
 If a script is evaluated at top-level (i.e. no other scripts are
 pending evaluation when the script is invoked), and if the script
-terminates with a completion code other than TCL_OK, TCL_CONTINUE
+terminates with a completion code other than TCL_OK, TCL_ERROR
 or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR
-return with an appropriate message.
+return with an appropriate message.  The particular script
+evaluation procedures of Tcl that act in the manner are
+\fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR,
+\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and
+\fBTcl_VarEvalVA\fR. 
 .PP
 However, if \fBTcl_AllowExceptions\fR is invoked immediately before
-calling a procedure such as \fBTcl_Eval\fR, then arbitrary completion
+calling one of those a procedures, then arbitrary completion
 codes are permitted from the script, and they are returned without
 modification.
 This is useful in cases where the caller can deal with exceptions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e8372ea..bb72114 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.55 2002/03/27 19:20:54 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.56 2002/03/29 21:01:11 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3092,6 +3092,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
 				 * string was generated. */
     int code = TCL_OK;
     int i;
+    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
 
     for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
 	if (iPtr->numLevels <= tracePtr->level) {
@@ -3118,6 +3119,23 @@ Tcl_EvalObjv(interp, objc, objv, flags)
 		flags);
 	iPtr->numLevels--;
     }
+
+    /*
+     * If we are again at the top level, process any unusual 
+     * return code returned by the evaluated code. 
+     */
+	
+    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) {
 
 	/* 
@@ -3488,6 +3506,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
     int i, code, commandLength, bytesLeft, nested;
     CallFrame *savedVarFramePtr;   /* Saves old copy of iPtr->varFramePtr
 				    * 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,
@@ -3591,7 +3610,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
 			code = TclUpdateReturnInfo(iPtr);
 		    }
 		    if ((code != TCL_OK) && (code != TCL_ERROR) 
-			&& ((iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
+			&& !allowExceptions) {
 			ProcessUnexpectedResult(interp, code);
 			code = TCL_ERROR;
 		    }
@@ -3841,6 +3860,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
     int result;
     CallFrame *savedVarFramePtr;	/* Saves old copy of iPtr->varFramePtr
 					 * in case TCL_EVAL_GLOBAL was set. */
+    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
 
     Tcl_IncrRefCount(objPtr);
 
@@ -3880,7 +3900,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
 	    iPtr->varFramePtr = NULL;
 	}
 
-	result = TclCompEvalObj(interp, objPtr, /* engineCall */ 0);
+	result = TclCompEvalObj(interp, objPtr);
 
 	/*
 	 * If we are again at the top level, process any unusual 
@@ -3892,7 +3912,7 @@ Tcl_EvalObjEx(interp, objPtr, flags)
 		result = TclUpdateReturnInfo(iPtr);
 	    }
 	    if ((result != TCL_OK) && (result != TCL_ERROR) 
-	        && ((iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
+	        && !allowExceptions) {
 		ProcessUnexpectedResult(interp, result);
 		result = TCL_ERROR;
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e0bf175..074cb91 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompile.h,v 1.25 2002/02/15 14:28:48 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.26 2002/03/29 21:01:11 dgp Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -748,7 +748,7 @@ EXTERN int              TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));
  */
 
 EXTERN int		TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
-			    Tcl_Obj *objPtr, int engineCall));
+			    Tcl_Obj *objPtr));
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 92e345f..d737299 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.50 2002/03/22 22:54:35 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.51 2002/03/29 21:01:12 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -818,16 +818,11 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
  */
 
 int
-TclCompEvalObj(interp, objPtr, engineCall)
+TclCompEvalObj(interp, objPtr)
     Tcl_Interp *interp;
     Tcl_Obj *objPtr;
-    int engineCall;                    /* Set to 1 if it is an internal 
-					* engine call, 0 if called from 
-					* Tcl_EvalObjEx */
 {
     register Interp *iPtr = (Interp *) interp;
-    int evalFlags;			/* Interp->evalFlags value when the
-					 * procedure was called. */
     register ByteCode* codePtr;		/* Tcl Internal type of bytecode. */
     int oldCount = iPtr->cmdCount;	/* Used to tell whether any commands
 					 * at all were executed. */
@@ -896,7 +891,7 @@ TclCompEvalObj(interp, objPtr, engineCall)
 	iPtr->errorLine = 1; 
 	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
 	if (result != TCL_OK) {
-	    return result;;
+	    return result;
 	}
     } else {
 	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
@@ -917,7 +912,6 @@ TclCompEvalObj(interp, objPtr, engineCall)
      * Resetting the flags must be done after any compilation.
      */
 
-    evalFlags = iPtr->evalFlags;
     iPtr->evalFlags = 0;
 
     /*
@@ -926,7 +920,6 @@ TclCompEvalObj(interp, objPtr, engineCall)
      */
 
     numSrcBytes = codePtr->numSrcBytes;
-    iPtr->numLevels++;
     if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
 	/*
 	 * Increment the code's ref count while it is being executed. If
@@ -934,7 +927,9 @@ TclCompEvalObj(interp, objPtr, engineCall)
 	 */
 	
 	codePtr->refCount++;
+	iPtr->numLevels++;
 	result = TclExecuteByteCode(interp, codePtr);
+	iPtr->numLevels--;
 	codePtr->refCount--;
 	if (codePtr->refCount <= 0) {
 	    TclCleanupByteCode(codePtr);
@@ -952,16 +947,17 @@ TclCompEvalObj(interp, objPtr, engineCall)
 
     if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
 	result = Tcl_AsyncInvoke(interp, result);
-    }
-
-    /*
-     * If an error occurred, record information about what was being
-     * executed when the error occurred.
-     */
+    
 
-    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
-	script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
-	Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
+	/*
+	 * If an error occurred, record information about what was being
+	 * executed when the error occurred.
+	 */
+	
+	if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+	    Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
+	}
     }
 
     /*
@@ -973,16 +969,6 @@ TclCompEvalObj(interp, objPtr, engineCall)
 
     iPtr->termOffset = numSrcBytes;
     iPtr->flags &= ~ERR_ALREADY_LOGGED;
-    iPtr->numLevels--;
-
-    /* 
-     * Tcl_EvalObjEx needs the evalFlags for error reporting at
-     * iPtr->numLevels 0 - we pass it here, it will reset them.
-     */
-
-    if (!engineCall) {
-	iPtr->evalFlags = evalFlags;
-    }
 
     return result;
 }
@@ -1411,7 +1397,7 @@ TclExecuteByteCode(interp, codePtr)
 	case INST_EVAL_STK:
 	    objPtr = POP_OBJECT();
 	    DECACHE_STACK_INFO();
-	    result = TclCompEvalObj(interp, objPtr, /* engineCall */ 1);
+	    result = TclCompEvalObj(interp, objPtr);
 	    CACHE_STACK_INFO();
 	    if (result == TCL_OK) {
 		/*
diff --git a/tests/basic.test b/tests/basic.test
index a459e07..8a3e703 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: basic.test,v 1.17 2002/03/27 14:35:40 msofer Exp $
+# RCS: @(#) $Id: basic.test,v 1.18 2002/03/29 21:01:12 dgp Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -597,6 +597,47 @@ invoked "break" outside of a loop
 "break"
     (file "BREAKtest" line 3)}}    
 
+test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {
+    makeFile {
+	interp alias {} patch {} info patchlevel
+	patch
+	break
+    } BREAKtest
+    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
+    removeFile BREAKtest
+    set res
+} {1 {invoked "break" outside of a loop
+    while executing
+"break"
+    (file "BREAKtest" line 4)}}    
+
+test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {
+    makeFile {
+	foo [set a 1] [break]
+    } BREAKtest
+    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
+    removeFile BREAKtest
+    set res
+} {1 {invoked "break" outside of a loop
+    while executing
+"break"
+    invoked from within
+"foo [set a 1] [break]"
+    (file "BREAKtest" line 2)}}
+
+test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {
+    makeFile {
+	return -code return
+    } BREAKtest
+    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
+    removeFile BREAKtest
+    set res
+} {1 {command returned bad code: 2
+    while executing
+"return -code return"
+    (file "BREAKtest" line 2)}}
+
+
 # cleanup
 catch {eval namespace delete [namespace children :: test_ns_*]}
 catch {namespace delete george}