From fa9ca5327da10d6516693b272a082e03a255c835 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 6 Sep 2007 18:13:19 +0000 Subject: * 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: --- ChangeLog | 17 ++++++++ generic/tclEvent.c | 107 ++++++++++++++++++++++++++++++++++++++------------ generic/tclIO.c | 10 +++-- generic/tclIOCmd.c | 4 +- generic/tclInt.decls | 8 +++- generic/tclIntDecls.h | 13 +++++- generic/tclInterp.c | 10 +++-- generic/tclStubInit.c | 3 +- generic/tclTimer.c | 4 +- 9 files changed, 135 insertions(+), 41 deletions(-) diff --git a/ChangeLog b/ChangeLog index 20ea4bf..b883584 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2007-09-06 Don Porter + + * 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: + 2007-09-06 Daniel Steffen * macosx/Tcl.xcode/project.pbxproj: discontinue unmaintained support 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; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e1c56b..145d27a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.122 2007/07/02 19:18:10 dgp Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.123 2007/09/06 18:13:19 dgp Exp $ */ #include "tclInt.h" @@ -7932,7 +7932,7 @@ TclChannelEventScriptInvoker( if (chanPtr->typePtr != NULL) { DeleteScriptRecord(interp, chanPtr, mask); } - Tcl_BackgroundError(interp); + TclBackgroundException(interp, result); } Tcl_Release((ClientData) interp); } @@ -8394,6 +8394,7 @@ CopyData( total = csPtr->total; if (cmdPtr && interp) { + int code; /* * Get a private copy of the command so we can mutate it by adding * arguments. Note that StopCopy frees our saved reference to the @@ -8409,8 +8410,9 @@ CopyData( if (errObj) { Tcl_ListObjAppendElement(interp, cmdPtr, errObj); } - if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { - Tcl_BackgroundError(interp); + code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + TclBackgroundException(interp, code); result = TCL_ERROR; } TclDecrRefCount(cmdPtr); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index ba610b5..9156b6d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -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: tclIOCmd.c,v 1.42 2007/06/28 21:10:38 patthoyts Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.43 2007/09/06 18:13:20 dgp Exp $ */ #include "tclInt.h" @@ -1284,7 +1284,7 @@ AcceptCallbackProc( result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, NULL); if (result != TCL_OK) { - Tcl_BackgroundError(interp); + TclBackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index ab6252a..57611b9 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.113 2007/08/07 17:28:38 msofer Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.114 2007/09/06 18:13:20 dgp Exp $ library tcl @@ -937,6 +937,12 @@ declare 235 generic { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } + +declare 236 generic { + void TclBackgroundException(Tcl_Interp *interp, int code) +} + + ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 876a4bf..157b189 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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: tclIntDecls.h,v 1.104 2007/08/07 17:28:39 msofer Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.105 2007/09/06 18:13:20 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -1051,6 +1051,12 @@ EXTERN Var * TclVarHashCreateVar (TclVarHashTable * tablePtr, EXTERN void TclInitVarHashTable (TclVarHashTable * tablePtr, Namespace * nsPtr); #endif +#ifndef TclBackgroundException_TCL_DECLARED +#define TclBackgroundException_TCL_DECLARED +/* 236 */ +EXTERN void TclBackgroundException (Tcl_Interp * interp, + int code); +#endif typedef struct TclIntStubs { int magic; @@ -1307,6 +1313,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame * contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable * tablePtr, const char * key, int * newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */ + void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */ } TclIntStubs; #ifdef __cplusplus @@ -2036,6 +2043,10 @@ extern TclIntStubs *tclIntStubsPtr; #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ #endif +#ifndef TclBackgroundException +#define TclBackgroundException \ + (tclIntStubsPtr->tclBackgroundException) /* 236 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1d28a95..a42c339 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.76 2007/06/20 18:46:13 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.77 2007/09/06 18:13:20 dgp Exp $ */ #include "tclInt.h" @@ -3615,12 +3615,14 @@ TimeLimitCallback( ClientData clientData) { Tcl_Interp *interp = (Tcl_Interp *) clientData; + int code; Tcl_Preserve((ClientData) interp); ((Interp *)interp)->limit.timeEvent = NULL; - if (Tcl_LimitCheck(interp) != TCL_OK) { + code = Tcl_LimitCheck(interp); + if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); - Tcl_BackgroundError(interp); + TclBackgroundException(interp, code); } Tcl_Release((ClientData) interp); } @@ -3788,7 +3790,7 @@ CallScriptLimitCallback( code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, TCL_EVAL_GLOBAL); if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { - Tcl_BackgroundError(limitCBPtr->interp); + TclBackgroundException(limitCBPtr->interp, code); } Tcl_Release(limitCBPtr->interp); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b197f66..15e963b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -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: tclStubInit.c,v 1.143 2007/08/07 17:28:39 msofer Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.144 2007/09/06 18:13:23 dgp Exp $ */ #include "tclInt.h" @@ -325,6 +325,7 @@ TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ + TclBackgroundException, /* 236 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 3e5ad1a..a14a129 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.28 2006/11/15 20:08:45 dgp Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.29 2007/09/06 18:13:23 dgp Exp $ */ #include "tclInt.h" @@ -1155,7 +1155,7 @@ AfterProc( #endif if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); - Tcl_BackgroundError(interp); + TclBackgroundException(interp, result); } Tcl_Release((ClientData) interp); -- cgit v0.12