summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclEvent.c107
-rw-r--r--generic/tclIO.c10
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclIntDecls.h13
-rw-r--r--generic/tclInterp.c10
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclTimer.c4
8 files changed, 118 insertions, 41 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;
}
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);
generated by cgit v0.12 at 2024-11-19 04:18:14 (GMT)