summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-03-29 21:01:11 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-03-29 21:01:11 (GMT)
commitcb3ffc68aefa6b11adf7c31ae97da681a91b8c04 (patch)
tree45d34400a0d6c9126eb259f658c44f63e2fc1b02
parentecdc61ad73b61ea283f30fa6cd4e25f39521f59e (diff)
downloadtcl-cb3ffc68aefa6b11adf7c31ae97da681a91b8c04.zip
tcl-cb3ffc68aefa6b11adf7c31ae97da681a91b8c04.tar.gz
tcl-cb3ffc68aefa6b11adf7c31ae97da681a91b8c04.tar.bz2
* 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]
-rw-r--r--ChangeLog10
-rw-r--r--doc/AllowExc.312
-rw-r--r--generic/tclBasic.c28
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclExecute.c46
-rw-r--r--tests/basic.test43
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}