Attachment "allowExcept.patch1" to
ticket [219181ffff]
added by
msofer
2002-03-29 18:28:14.
Index: doc/AllowExc.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/AllowExc.3,v
retrieving revision 1.2
diff -u -r1.2 AllowExc.3
--- doc/AllowExc.3 14 Sep 1998 18:39:45 -0000 1.2
+++ doc/AllowExc.3 29 Mar 2002 11:03:58 -0000
@@ -27,9 +27,19 @@
.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. A TCL_RETURN completion code is
+normally processed further, so that only TCL_OK and TCL_ERROR are
+valid top-level return codes.
+.PP
+This completion-code conversion at top-level is performed by the
+evaluation functions \fBTcl_EvalObjEx\fR, \fBTcl_EvalFile\fR,
+\fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR,
+\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and
+\fBTcl_VarEvalVA\fR. The two token evaluation functions
+\fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR do \fBnot\fR
+check the execution level or convert their results.
.PP
However, if \fBTcl_AllowExceptions\fR is invoked immediately before
calling a procedure such as \fBTcl_Eval\fR, then arbitrary completion
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.55
diff -u -r1.55 tclBasic.c
--- generic/tclBasic.c 27 Mar 2002 19:20:54 -0000 1.55
+++ generic/tclBasic.c 29 Mar 2002 11:04:15 -0000
@@ -3092,6 +3092,7 @@
* 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
- && ((iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
+ && !allowExceptions) {
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
Index: generic/tclCompile.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCompile.h,v
retrieving revision 1.25
diff -u -r1.25 tclCompile.h
--- generic/tclCompile.h 15 Feb 2002 14:28:48 -0000 1.25
+++ generic/tclCompile.h 29 Mar 2002 11:04:25 -0000
@@ -748,7 +748,7 @@
*/
EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, int engineCall));
+ Tcl_Obj *objPtr));
/*
*----------------------------------------------------------------
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.50
diff -u -r1.50 tclExecute.c
--- generic/tclExecute.c 22 Mar 2002 22:54:35 -0000 1.50
+++ generic/tclExecute.c 29 Mar 2002 11:04:29 -0000
@@ -818,16 +818,11 @@
*/
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 @@
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 @@
* Resetting the flags must be done after any compilation.
*/
- evalFlags = iPtr->evalFlags;
iPtr->evalFlags = 0;
/*
@@ -926,7 +920,6 @@
*/
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 @@
*/
codePtr->refCount++;
+ iPtr->numLevels++;
result = TclExecuteByteCode(interp, codePtr);
+ iPtr->numLevels--;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -952,16 +947,17 @@
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 @@
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 @@
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) {
/*
Index: tests/basic.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/basic.test,v
retrieving revision 1.17
diff -u -r1.17 basic.test
--- tests/basic.test 27 Mar 2002 14:35:40 -0000 1.17
+++ tests/basic.test 29 Mar 2002 11:04:32 -0000
@@ -597,6 +597,47 @@
"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}
