diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/AllowExc.3 | 12 | ||||
| -rw-r--r-- | generic/tclBasic.c | 28 | ||||
| -rw-r--r-- | generic/tclCompile.h | 4 | ||||
| -rw-r--r-- | generic/tclExecute.c | 46 | ||||
| -rw-r--r-- | tests/basic.test | 43 |
6 files changed, 102 insertions, 41 deletions
@@ -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} |