Attachment "290-4-20061106.diff" to
ticket [1587317fff]
added by
ecky-l
2006-11-07 02:56:00.
Only in tcl.290/: .cdtproject
Only in tcl.290/: .project
Only in tcl.290/: .settings
diff -ubr tcl.orig/generic/tclBasic.c tcl.290/generic/tclBasic.c
--- tcl.orig/generic/tclBasic.c Sat Nov 4 00:09:33 2006
+++ tcl.290/generic/tclBasic.c Sat Nov 4 16:24:17 2006
@@ -399,6 +399,13 @@
iPtr->chanMsg = NULL;
/*
+ * TIP 290: initialize the exceptionCommand and exceptionCommandFlags members
+ */
+ iPtr->exceptionCommand = NULL;
+ iPtr->exceptionCommandFlags = 0;
+ iPtr->catchLevel = 0;
+
+ /*
* Initialize the compilation and execution statistics kept for this
* interpreter.
*/
@@ -3519,6 +3526,53 @@
if (savedVarFramePtr) {
iPtr->varFramePtr = savedVarFramePtr;
}
+
+ /*
+ * TIP 290 Execute the exceptHandler that was registered with the interp.
+ *
+ * Do this only if the error was not thrown already and dependend on
+ * -caught/-uncaught (stored in exceptionCommandFlags).
+ *
+ * The return code of the exception and the result are appended to the
+ * command before execution
+ */
+ if (code != TCL_OK && iPtr->exceptionCommand != NULL
+ && !(iPtr->exceptionCommandFlags & EXCEPTCMD_FINISHED)
+ && !(iPtr->exceptionCommandFlags & EXCEPTCMD_RUNNING)) {
+
+ int uncatched = (iPtr->catchLevel <= 0
+ && (iPtr->exceptionCommandFlags & EXCEPTCMD_ONUNCAUGHT));
+ int catched = (iPtr->catchLevel > 0
+ && (iPtr->exceptionCommandFlags & EXCEPTCMD_ONCAUGHT));
+ if (uncatched || catched) {
+ Tcl_DString cmdBuf;
+ int i, cmdLen;
+ char *cmdString;
+ Tcl_Obj *exceptCmd = Tcl_DuplicateObj(iPtr->exceptionCommand);
+ Tcl_ListObjAppendElement (interp, exceptCmd, Tcl_NewIntObj(code));
+ Tcl_ListObjAppendElement (interp, exceptCmd, Tcl_GetObjResult(interp));
+
+ /* 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->exceptionCommandFlags |= EXCEPTCMD_RUNNING;
+ code = Tcl_EvalObj(interp, exceptCmd);
+ iPtr->exceptionCommandFlags &= ~EXCEPTCMD_RUNNING;
+ iPtr->exceptionCommandFlags |= EXCEPTCMD_FINISHED;
+
+ if (cmdLen != 0) {
+ Tcl_DStringFree(&cmdBuf);
+ }
+
+ }
+ }
+
return code;
}
diff -ubr tcl.orig/generic/tclCmdAH.c tcl.290/generic/tclCmdAH.c
--- tcl.orig/generic/tclCmdAH.c Thu Nov 2 16:57:54 2006
+++ tcl.290/generic/tclCmdAH.c Sat Nov 4 13:13:50 2006
@@ -229,6 +229,7 @@
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
+ Interp *iPtr = (Interp*)interp;
int result;
if ((objc < 2) || (objc > 4)) {
@@ -244,7 +245,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 -ubr tcl.orig/generic/tclEvent.c tcl.290/generic/tclEvent.c
--- tcl.orig/generic/tclEvent.c Tue Sep 19 22:07:34 2006
+++ tcl.290/generic/tclEvent.c Sat Nov 4 16:07:34 2006
@@ -380,6 +380,7 @@
return code;
}
+
/*
*----------------------------------------------------------------------
*
diff -ubr tcl.orig/generic/tclExecute.c tcl.290/generic/tclExecute.c
--- tcl.orig/generic/tclExecute.c Thu Nov 2 15:58:08 2006
+++ tcl.290/generic/tclExecute.c Sat Nov 4 16:12:25 2006
@@ -183,14 +183,19 @@
* pair must surround any call inside TclExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
* to TclExecuteByteCode.
+ *
+ * TIP 290: keep the catch level if necessary
*/
#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++
+
/*
@@ -1794,6 +1799,13 @@
/*Tcl_ResetResult(interp);*/
result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
CACHE_STACK_INFO();
+
+ /*
+ * TIP 290: reset the EXCEPTCMD_FINISHED flag the top of catch stack
+ */
+ if (catchTop < 0) {
+ iPtr->exceptionCommandFlags &= ~EXCEPTCMD_FINISHED;
+ }
/*
* If the old stack is going to be released, it is safe to do so
diff -ubr tcl.orig/generic/tclInt.h tcl.290/generic/tclInt.h
--- tcl.orig/generic/tclInt.h Thu Nov 2 16:57:54 2006
+++ tcl.290/generic/tclInt.h Sat Nov 4 16:09:43 2006
@@ -1285,6 +1285,14 @@
};
/*
+ * TIP 290 Flags for running an exception command
+ */
+#define EXCEPTCMD_ONCAUGHT 1 /* Run the command on caught exceptions */
+#define EXCEPTCMD_ONUNCAUGHT 2 /* Run the command on uncaught exceptions */
+#define EXCEPTCMD_FINISHED 4 /* indicates that the command has been run for a particular exception */
+#define EXCEPTCMD_RUNNING 8 /* indicates that the exception command is currently running */
+
+/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of commands
* plus other state information related to interpreting commands, such as
@@ -1292,7 +1300,6 @@
* tclBasic.c, but almost every Tcl source file uses something in here.
*----------------------------------------------------------------
*/
-
typedef struct Interp {
/*
* Note: the first three fields must match exactly the fields in a
@@ -1555,6 +1562,15 @@
ByteCodeStats stats; /* Holds compilation and execution statistics
* for this interpreter. */
#endif /* TCL_COMPILE_STATS */
+
+ Tcl_Obj* exceptionCommand; /* A script that is executed on errors */
+ int exceptionCommandFlags; /* 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;
/*
diff -ubr tcl.orig/generic/tclTrace.c tcl.290/generic/tclTrace.c
--- tcl.orig/generic/tclTrace.c Mon Oct 23 21:36:55 2006
+++ tcl.290/generic/tclTrace.c Mon Nov 6 19:23:00 2006
@@ -101,6 +101,7 @@
static Tcl_TraceTypeObjCmd TraceVariableObjCmd;
static Tcl_TraceTypeObjCmd TraceCommandObjCmd;
static Tcl_TraceTypeObjCmd TraceExecutionObjCmd;
+static Tcl_TraceTypeObjCmd TraceExceptionObjCmd;
/*
* Each subcommand has a number of 'types' to which it can apply. Currently
@@ -110,12 +111,13 @@
*/
static CONST char *traceTypeOptions[] = {
- "execution", "command", "variable", NULL
+ "execution", "command", "variable", "exception", NULL
};
static Tcl_TraceTypeObjCmd *traceSubCmds[] = {
TraceExecutionObjCmd,
TraceCommandObjCmd,
TraceVariableObjCmd,
+ TraceExceptionObjCmd
};
/*
@@ -181,7 +183,7 @@
char *name, *flagOps, *p;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
- "add", "info", "remove",
+ "add", "info", "remove", "set", "unset",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
@@ -189,7 +191,7 @@
};
/* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptions {
- TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
+ TRACE_ADD, TRACE_INFO, TRACE_REMOVE, TRACE_SET, TRACE_UNSET,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
@@ -249,6 +251,23 @@
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
break;
}
+ case TRACE_SET:
+ case TRACE_UNSET: {
+ int typeIndex;
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "exception ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option",
+ 0, &typeIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (typeIndex < 3) {
+ return TCL_ERROR;
+ }
+ return TraceExceptionObjCmd(interp, optionIndex, objc, objv);
+ break;
+ }
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
@@ -614,6 +633,109 @@
}
}
return TCL_OK;
+}
+
+static int
+TraceExceptionObjCmd(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int optionIndex, /* Add, info or remove */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Interp *iPtr = (Interp*)interp;
+ enum traceOptions {
+ TRACE_ADD, TRACE_INFO, TRACE_REMOVE, TRACE_SET, TRACE_UNSET
+ };
+
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_INFO: {
+ /*
+ * 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->exceptionCommandFlags & EXCEPTCMD_ONCAUGHT));
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj("-uncaught", -1));
+ Tcl_ListObjAppendElement(interp, result,
+ Tcl_NewBooleanObj(iPtr->exceptionCommandFlags & EXCEPTCMD_ONUNCAUGHT));
+ if (iPtr->exceptionCommand == NULL) {
+ Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj("", -1));
+ } else {
+ Tcl_ListObjAppendElement(interp, result, iPtr->exceptionCommand);
+ }
+
+ Tcl_SetObjResult(interp, result);
+ return TCL_OK;
+ }
+ case TRACE_SET: {
+ break;
+ }
+ case TRACE_UNSET: {
+ Tcl_DecrRefCount(iPtr->exceptionCommand);
+ iPtr->exceptionCommand = NULL;
+ return TCL_OK;
+ }
+ default: {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "bad option, should be trace set|get|info exception", -1));
+ return TCL_ERROR;
+ }
+ }
+
+ if (objc == 4) {
+ iPtr->exceptionCommand = objv[3];
+ Tcl_IncrRefCount (iPtr->exceptionCommand);
+
+ return TCL_OK;
+ }
+
+ if (objc == 5) {
+ char *flag = Tcl_GetString(objv[3]);
+
+ if (*flag != '-') {
+ goto errorReturn;
+ }
+ if (strcmp(flag, "-caught") == 0) {
+ iPtr->exceptionCommandFlags = EXCEPTCMD_ONCAUGHT;
+ } else if (strcmp(flag, "-uncaught") == 0) {
+ iPtr->exceptionCommandFlags = EXCEPTCMD_ONUNCAUGHT;
+ } else {
+ goto errorReturn;
+ }
+
+ iPtr->exceptionCommand = objv[4];
+ Tcl_IncrRefCount(iPtr->exceptionCommand);
+
+ return TCL_OK;
+ }
+
+ if (objc == 6) {
+ char *flag1 = Tcl_GetString(objv[3]), *flag2 = Tcl_GetString(objv[4]);
+ 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->exceptionCommandFlags = EXCEPTCMD_ONCAUGHT|EXCEPTCMD_ONUNCAUGHT;
+ iPtr->exceptionCommand = objv[5];
+ Tcl_IncrRefCount(iPtr->exceptionCommand);
+
+ return TCL_OK;
+ }
+
+errorReturn:
+ iPtr->exceptionCommand = NULL;
+ iPtr->exceptionCommandFlags = 0;
+ Tcl_WrongNumArgs(interp, 3, objv, "?-caught? ?-uncaught? ?script?");
+ return TCL_ERROR;
}
/*
diff -ubr tcl.orig/tests/trace.test tcl.290/tests/trace.test
--- tcl.orig/tests/trace.test Fri Nov 3 23:24:43 2006
+++ tcl.290/tests/trace.test Mon Nov 6 19:34:46 2006
@@ -842,7 +842,7 @@
test trace-14.5 {trace command, invalid option} {
list [catch {trace gorp} msg] $msg
-} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
+} [list 1 "bad option \"gorp\": must be add, info, remove, set, unset, variable, vdelete, or vinfo"]
# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those
Only in tcl.290/win: 280-latest-20061104.diff
