diff options
author | dgp <dgp@noemail.net> | 2007-09-06 18:13:19 (GMT) |
---|---|---|
committer | dgp <dgp@noemail.net> | 2007-09-06 18:13:19 (GMT) |
commit | 5d8adfcb19e95a7cfe1bde6471bb69ee52aade77 (patch) | |
tree | 21db3085afb048eebeefccee941778b5e8733f74 /generic/tclEvent.c | |
parent | cfc0470326dd0ad12c30c7fef76094e433b0ff69 (diff) | |
download | tcl-5d8adfcb19e95a7cfe1bde6471bb69ee52aade77.zip tcl-5d8adfcb19e95a7cfe1bde6471bb69ee52aade77.tar.gz tcl-5d8adfcb19e95a7cfe1bde6471bb69ee52aade77.tar.bz2 |
* generic/tclInt.decls: New internal routine TclBackgroundException()
* generic/tclEvent.c: that for the first time permits non-TCL_ERROR
exceptions to trigger [interp bgerror] handling. Closes a gap in
TIP 221. When falling back to [bgerror] (which is designed only
to handle TCL_ERROR), convert exceptions into errors complaining
about the exception.
* generic/tclInterp.c: Convert Tcl_BackgroundError() callers to call
* generic/tclIO.c: TclBackgroundException().
* generic/tclIOCmd.c:
* generic/tclTimer.c:
* generic/tclIntDecls.h: make genstubs
* generic/tclStubInit.c:
FossilOrigin-Name: d487b6177f90c2e6ed098196aa542ca6db0f5a21
Diffstat (limited to 'generic/tclEvent.c')
-rw-r--r-- | generic/tclEvent.c | 107 |
1 files changed, 81 insertions, 26 deletions
diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 52fd371..4b37b1e 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.73 2007/07/02 17:13:48 dgp Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.74 2007/09/06 18:13:19 dgp Exp $ */ #include "tclInt.h" @@ -140,13 +140,25 @@ Tcl_BackgroundError( Tcl_Interp *interp) /* Interpreter in which an error has * occurred. */ { + TclBackgroundException(interp, TCL_ERROR); +} +void +TclBackgroundException( + Tcl_Interp *interp, /* Interpreter in which an exception has + * occurred. */ + int code) /* The exception code value */ +{ BgError *errPtr; ErrAssocData *assocPtr; + if (code == TCL_OK) { + return; + } + errPtr = (BgError *) ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); - errPtr->returnOpts = Tcl_GetReturnOptions(interp, TCL_ERROR); + errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); Tcl_IncrRefCount(errPtr->returnOpts); errPtr->nextPtr = NULL; @@ -297,45 +309,86 @@ TclDefaultBgErrorHandlerObjCmd( { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; - int code; + int code, level; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "msg options"); return TCL_ERROR; } + /* Construct the bgerror command */ + TclNewLiteralStringObj(tempObjv[0], "bgerror"); + Tcl_IncrRefCount(tempObjv[0]); + /* - * Restore important state variables to what they were at the time the - * error occurred. - * - * Need to set the variables, not the interp fields, because Tcl_EvalObjv - * calls Tcl_ResetResult which would destroy anything we write to the - * interp fields. + * Determine error message argument. Check the return options in case + * a non-error exception brought us here. */ - TclNewLiteralStringObj(keyPtr, "-errorcode"); + TclNewLiteralStringObj(keyPtr, "-level"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); - if (valuePtr) { - Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY); + Tcl_GetIntFromObj(NULL, valuePtr, &level); + if (level != 0) { + /* We're handling a TCL_RETURN exception */ + code = TCL_RETURN; + } else { + TclNewLiteralStringObj(keyPtr, "-code"); + Tcl_IncrRefCount(keyPtr); + Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + Tcl_DecrRefCount(keyPtr); + Tcl_GetIntFromObj(NULL, valuePtr, &code); } - - TclNewLiteralStringObj(keyPtr, "-errorinfo"); - Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); - Tcl_DecrRefCount(keyPtr); - if (valuePtr) { - Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY); + switch (code) { + case TCL_ERROR: + tempObjv[1] = objv[1]; + break; + case TCL_BREAK: + TclNewLiteralStringObj(tempObjv[1], + "invoked \"break\" outside of a loop"); + break; + case TCL_CONTINUE: + TclNewLiteralStringObj(tempObjv[1], + "invoked \"continue\" outside of a loop"); + break; + default: + tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code); + break; } + if (code == TCL_ERROR) { + /* + * Restore important state variables to what they were at the time + * the error occurred. + * + * Need to set the variables, not the interp fields, because + * Tcl_EvalObjv calls Tcl_ResetResult which would destroy + * anything we write to the interp fields. + */ - /* - * Create and invoke the bgerror command. - */ + TclNewLiteralStringObj(keyPtr, "-errorcode"); + Tcl_IncrRefCount(keyPtr); + Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + Tcl_DecrRefCount(keyPtr); + if (valuePtr) { + Tcl_SetVar2Ex(interp, "errorCode", NULL, valuePtr, TCL_GLOBAL_ONLY); + } - TclNewLiteralStringObj(tempObjv[0], "bgerror"); - Tcl_IncrRefCount(tempObjv[0]); - tempObjv[1] = objv[1]; + TclNewLiteralStringObj(keyPtr, "-errorinfo"); + Tcl_IncrRefCount(keyPtr); + Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + Tcl_DecrRefCount(keyPtr); + if (valuePtr) { + Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY); + } + } else { + Tcl_AppendObjToErrorInfo(interp, Tcl_DuplicateObj(tempObjv[1])); + } + Tcl_IncrRefCount(tempObjv[1]); + valuePtr = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + Tcl_IncrRefCount(valuePtr); + + /* Invoke the bgerror command. */ Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { @@ -368,7 +421,7 @@ TclDefaultBgErrorHandlerObjCmd( Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n",-1); Tcl_WriteChars(errChannel, " Original error: ", -1); - Tcl_WriteObj(errChannel, objv[1]); + Tcl_WriteObj(errChannel, tempObjv[1]); Tcl_WriteChars(errChannel, "\n", -1); Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); Tcl_WriteObj(errChannel, resultPtr); @@ -380,7 +433,9 @@ TclDefaultBgErrorHandlerObjCmd( } code = TCL_OK; } + Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(tempObjv[0]); + Tcl_DecrRefCount(tempObjv[1]); Tcl_ResetResult(interp); return code; } |