Attachment "errorscript.patch" to
ticket [1587317fff]
added by
ecky-l
2006-11-01 00:59:22.
diff -ubrN tcl8.5a5/generic/tclBasic.c tcl/generic/tclBasic.c
--- tcl8.5a5/generic/tclBasic.c Mon Oct 16 16:52:02 2006
+++ tcl/generic/tclBasic.c Tue Oct 31 17:45:38 2006
@@ -374,6 +374,13 @@
iPtr->chanMsg = NULL;
/*
+ * initialize the errorHandler and errorHandlerFlags members
+ */
+ iPtr->errorHandler = NULL;
+ iPtr->errorHandlerFlags = 0;
+ iPtr->catchLevel = 0;
+
+ /*
* Initialize the compilation and execution statistics kept for this
* interpreter.
*/
@@ -498,6 +505,12 @@
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
+ * Register the error handler registration command
+ */
+ Tcl_CreateObjCommand(interp, "::tcl::seterrorhandler",
+ TclSetErrorHandlerObjCmd, NULL, NULL);
+
+ /*
* Register the builtin math functions.
*/
@@ -3276,7 +3289,7 @@
* need (at most) two passes here.
*/
- reparseBecauseOfTraces:
+reparseBecauseOfTraces:
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if (cmdPtr == NULL) {
Namespace *currNsPtr = NULL; /* Used to check for and invoke any
@@ -3426,8 +3439,49 @@
(void) Tcl_GetObjResult(interp);
}
- done:
+done:
iPtr->varFramePtr = savedVarFramePtr;
+ /*
+ * Execute the errorHandler that was registered with the interp eventually.
+ * This should be done only if the error was not thrown already upwards
+ * the execution stack, if the environment matches the flags -caught and
+ * -uncaught and according to whether the error was really catched.
+ * Those flags are stored in errorHandlerFlags member.
+ */
+ if (code == TCL_ERROR && iPtr->errorHandler != NULL
+ && !(iPtr->errorHandlerFlags & ERRHANDLER_FINISHED)
+ && !(iPtr->errorHandlerFlags & ERRHANDLER_RUNNING)) {
+
+ int uncatched = (iPtr->catchLevel <= 0
+ && (iPtr->errorHandlerFlags & ERRHANDLER_ONUNCAUGHT));
+ int catched = (iPtr->catchLevel > 0
+ && (iPtr->errorHandlerFlags & ERRHANDLER_ONCAUGHT));
+ if (uncatched || catched) {
+ Tcl_DString cmdBuf;
+ int i, cmdLen;
+ char *cmdString;
+
+ /* Log the error, so that it is available in the handler */
+ Tcl_DStringInit(&cmdBuf);
+ for (i = 0; i < objc; i++) {
+ Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
+ }
+ cmdString = Tcl_DStringValue(&cmdBuf);
+ cmdLen = Tcl_DStringLength(&cmdBuf);
+ Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
+
+ iPtr->errorHandlerFlags |= ERRHANDLER_RUNNING;
+ code = Tcl_EvalObj(interp, iPtr->errorHandler);
+ iPtr->errorHandlerFlags &= ~ERRHANDLER_RUNNING;
+ iPtr->errorHandlerFlags |= ERRHANDLER_FINISHED;
+
+ if (cmdLen != 0) {
+ Tcl_DStringFree(&cmdBuf);
+ }
+
+ }
+ }
+
return code;
}
@@ -3826,7 +3880,7 @@
iPtr->varFramePtr = savedVarFramePtr;
return TCL_OK;
- error:
+error:
/*
* Generate and log various pieces of error information.
*/
diff -ubrN tcl8.5a5/generic/tclCmdAH.c tcl/generic/tclCmdAH.c
--- tcl8.5a5/generic/tclCmdAH.c Thu Aug 10 12:15:30 2006
+++ tcl/generic/tclCmdAH.c Sun Oct 29 10:40:01 2006
@@ -228,6 +228,7 @@
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
+ Interp *iPtr = (Interp*)interp;
int result;
if ((objc < 2) || (objc > 4)) {
@@ -243,7 +244,9 @@
optionVarNamePtr = objv[3];
}
+ iPtr->catchLevel++;
result = Tcl_EvalObjEx(interp, objv[1], 0);
+ iPtr->catchLevel--;
/*
* We disable catch in interpreters where the limit has been exceeded.
diff -ubrN tcl8.5a5/generic/tclEvent.c tcl/generic/tclEvent.c
--- tcl8.5a5/generic/tclEvent.c Tue Sep 19 22:07:34 2006
+++ tcl/generic/tclEvent.c Sun Oct 29 10:33:28 2006
@@ -380,6 +380,134 @@
return code;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetErrorHandlerObjCmd --
+ *
+ * This function is invoked to process the "::tcl::errorscript" Tcl command.
+ * It registers an arbitrary script for execution, when Tcl encounters an
+ * error in the execution. By this it is possible to break the execution in
+ * error case and introspect the program from within the error position. If
+ * no errorscript is registered, the error is processed as usual, which means
+ * the stack trace is unwound and an error message is created.
+ *
+ * Usage:
+ * ::tcl::errorscript ?-caught? ?-uncaught? script
+ *
+ * Arguments:
+ * -caught, -uncaught
+ * Identify whether caught or/and uncaught errors should be processed by the
+ * script. By default, only uncaught errors are processed
+ * script
+ * The script to execute in error case
+ *
+ * Results:
+ * Empty string
+ *
+ * Side effects:
+ * sets errorHandler and execErrorScript member of the interpreter structure
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSetErrorHandlerObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Interp *iPtr = (Interp*)interp;
+
+ if (objc == 1) {
+ /*
+ * Return the currently set error script plus a tuple for -caught and
+ * -uncaught that indicates when the script is executed
+ */
+ Tcl_Obj *result = Tcl_NewObj();
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj("-caught", -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewBooleanObj(iPtr->errorHandlerFlags & ERRHANDLER_ONCAUGHT));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj("-uncaught", -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewBooleanObj(iPtr->errorHandlerFlags & ERRHANDLER_ONUNCAUGHT));
+ if (iPtr->errorHandler == NULL) {
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj("", -1));
+ } else {
+ Tcl_ListObjAppendElement(interp, result, iPtr->errorHandler);
+ }
+
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+ }
+
+ if (objc == 2) {
+ char *script = Tcl_GetString (objv[1]);
+ if (strcmp(script, "") == 0 && iPtr->errorHandler != NULL) {
+ /*
+ * This is the signal to reset the error script. The script will not
+ * be executed, neither on caught not on uncaught errors
+ */
+ Tcl_DecrRefCount(iPtr->errorHandler);
+ iPtr->errorHandler = NULL;
+ return TCL_OK;
+ }
+
+ iPtr->errorHandler = objv[1];
+ Tcl_IncrRefCount (iPtr->errorHandler);
+
+ return TCL_OK;
+ }
+
+ if (objc == 3) {
+ char *flag = Tcl_GetString(objv[1]);
+
+ if (*flag != '-') {
+ goto errorReturn;
+ }
+ if (strcmp(flag, "-caught") == 0) {
+ iPtr->errorHandlerFlags = ERRHANDLER_ONCAUGHT;
+ } else if (strcmp(flag, "-uncaught") == 0) {
+ iPtr->errorHandlerFlags = ERRHANDLER_ONUNCAUGHT;
+ } else {
+ goto errorReturn;
+ }
+
+ iPtr->errorHandler = objv[2];
+ Tcl_IncrRefCount(iPtr->errorHandler);
+
+ return TCL_OK;
+ }
+
+ if (objc == 4) {
+ char *flag1 = Tcl_GetString(objv[1]), *flag2 = Tcl_GetString(objv[2]);
+ int valid = 0;
+ if (*flag1 != '-' || *flag2 != '-') {
+ goto errorReturn;
+ }
+
+ valid = (strcmp(flag1, "-caught") == 0 && strcmp(flag2, "-uncaught") == 0)
+ || (strcmp(flag1, "-uncaught") == 0 && strcmp(flag2, "-caught") == 0);
+ if (!valid) {
+ goto errorReturn;
+ }
+
+ iPtr->errorHandlerFlags = ERRHANDLER_ONCAUGHT|ERRHANDLER_ONUNCAUGHT;
+ iPtr->errorHandler = objv[3];
+ Tcl_IncrRefCount(iPtr->errorHandler);
+
+ return TCL_OK;
+ }
+
+errorReturn:
+ iPtr->errorHandler = NULL;
+ iPtr->errorHandlerFlags = 0;
+ Tcl_WrongNumArgs(interp, 1, objv, "?-caught? ?-uncaught? ?script?");
+ return TCL_ERROR;
+}
+
/*
*----------------------------------------------------------------------
*
diff -ubrN tcl8.5a5/generic/tclExecute.c tcl/generic/tclExecute.c
--- tcl8.5a5/generic/tclExecute.c Thu Sep 28 20:06:42 2006
+++ tcl/generic/tclExecute.c Sun Oct 29 10:37:28 2006
@@ -186,11 +186,14 @@
*/
#define CACHE_STACK_INFO() \
- tosPtr = eePtr->tosPtr
+ tosPtr = eePtr->tosPtr;\
+ if (catchTop != initCatchTop) iPtr->catchLevel--
#define DECACHE_STACK_INFO() \
eePtr->tosPtr = tosPtr;\
- checkInterp = 1
+ checkInterp = 1;\
+ if (catchTop != initCatchTop) iPtr->catchLevel++
+
/*
@@ -1796,6 +1799,14 @@
CACHE_STACK_INFO();
/*
+ * EL: reset the ERRHANDLER_FINISHED flag when we are at the top of
+ * the catch stack
+ */
+ if (catchTop < 0) {
+ iPtr->errorHandlerFlags &= ~ERRHANDLER_FINISHED;
+ }
+
+ /*
* If the old stack is going to be released, it is safe to do so
* now, since no references to objv are going to be used from now
* on.
diff -ubrN tcl8.5a5/generic/tclInt.h tcl/generic/tclInt.h
--- tcl8.5a5/generic/tclInt.h Sat Sep 30 19:00:12 2006
+++ tcl/generic/tclInt.h Sun Oct 29 10:39:10 2006
@@ -1276,6 +1276,10 @@
* tclBasic.c, but almost every Tcl source file uses something in here.
*----------------------------------------------------------------
*/
+#define ERRHANDLER_ONCAUGHT 1
+#define ERRHANDLER_ONUNCAUGHT 2
+#define ERRHANDLER_FINISHED 4
+#define ERRHANDLER_RUNNING 8
typedef struct Interp {
/*
@@ -1541,6 +1545,15 @@
ByteCodeStats stats; /* Holds compilation and execution statistics
* for this interpreter. */
#endif /* TCL_COMPILE_STATS */
+
+ Tcl_Obj* errorHandler; /* A script that is executed on errors */
+ int errorHandlerFlags; /* Flags for executing the Error Script. */
+ int catchLevel; /* Level of [catch] commands . Is incremented
+ * on each encountered [catch]. If it is greater
+ * than 0 during an error is thrown this means that
+ * the error was catched elsewhere. We can react
+ * accordingly
+ */
} Interp;
/*
@@ -2306,6 +2319,9 @@
Tcl_Time *timePtr, Tcl_TimerProc *proc,
ClientData clientData);
MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int TclSetErrorHandlerObjCmd(
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData,
