summaryrefslogtreecommitdiffstats
path: root/generic/tclEvent.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclEvent.c')
-rw-r--r--generic/tclEvent.c107
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;
}