Attachment "errorstack.patch" to
ticket [2868499fff]
added by
ferrieux
2009-10-07 14:04:27.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.404
diff -u -r1.404 tclBasic.c
--- generic/tclBasic.c 11 Sep 2009 20:13:27 -0000 1.404
+++ generic/tclBasic.c 7 Oct 2009 07:01:19 -0000
@@ -424,6 +424,41 @@
/*
*----------------------------------------------------------------------
*
+ * ErrorStackRead --
+ *
+ * Called when the ::tcl::errorStack variable is read. Copies the current value
+ * of the interp's errorStack field into ::tcl::errorStack.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+ErrorStackRead(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ const char *name1,
+ const char *name2,
+ int flags)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (Tcl_InterpDeleted(interp) || (!iPtr->useErrorStack)) {
+ return NULL;
+ }
+ Tcl_ObjSetVar2(interp, iPtr->esVar, NULL,
+ iPtr->errorStack, 0);
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -530,6 +565,12 @@
iPtr->errorInfo = NULL;
TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
Tcl_IncrRefCount(iPtr->eiVar);
+ TclNewLiteralStringObj(iPtr->esVar, "::tcl::errorStack");
+ Tcl_IncrRefCount(iPtr->esVar);
+ iPtr->errorStack = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(iPtr->errorStack);
+ iPtr->useErrorStack=0;
+ iPtr->resetErrorStack = 1;
iPtr->errorCode = NULL;
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
Tcl_IncrRefCount(iPtr->ecVar);
@@ -792,6 +833,16 @@
Tcl_RepresentationCmd, NULL, NULL);
/*
+ * TIP 348
+ */
+
+ Tcl_LinkVar(interp, "::tcl::useErrorStack",
+ (char *) &iPtr->useErrorStack,
+ TCL_LINK_BOOLEAN);
+
+ Tcl_TraceVar(interp, "::tcl::errorStack", TCL_TRACE_READS, ErrorStackRead, NULL);
+
+ /*
* Create the 'tailcall' command
*/
@@ -1470,6 +1521,8 @@
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
+ Tcl_DecrRefCount(iPtr->esVar);
+ Tcl_DecrRefCount(iPtr->errorStack);
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.445
diff -u -r1.445 tclInt.h
--- generic/tclInt.h 30 Sep 2009 03:11:26 -0000 1.445
+++ generic/tclInt.h 7 Oct 2009 07:01:20 -0000
@@ -1895,6 +1895,10 @@
Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */
Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */
Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable. */
+ Tcl_Obj *errorStack; /* ::tcl::errorStack value (as a Tcl_Obj). */
+ Tcl_Obj *esVar; /* cached ref to ::errorStack variable. */
+ int resetErrorStack; /* controls cleaning up of ::errorStack */
+ int useErrorStack; /* linked var gating ::errorStack overhead */
int returnLevel; /* [return -level] parameter. */
/*
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.193
diff -u -r1.193 tclNamesp.c
--- generic/tclNamesp.c 30 Sep 2009 03:11:26 -0000 1.193
+++ generic/tclNamesp.c 7 Oct 2009 07:01:22 -0000
@@ -7633,6 +7633,41 @@
TCL_GLOBAL_ONLY);
}
}
+
+ /*
+ * TIP #348
+ */
+
+ if (iPtr->useErrorStack) {
+ int len;
+
+ if (Tcl_IsShared(iPtr->errorStack)) {
+ Tcl_Obj *newObj;
+
+ newObj = Tcl_DuplicateObj(iPtr->errorStack);
+ Tcl_DecrRefCount(iPtr->errorStack);
+ Tcl_IncrRefCount(newObj);
+ iPtr->errorStack = newObj;
+ }
+ Tcl_ListObjLength(interp, iPtr->errorStack, &len);
+ if (iPtr->resetErrorStack) {
+ iPtr->resetErrorStack = 0;
+ /* reset while keeping the list intrep as much as possible */
+ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
+ len=0;
+ }
+ if (iPtr->varFramePtr != iPtr->rootFramePtr) {
+ Tcl_Obj *listPtr;
+ int result;
+
+ listPtr=Tcl_NewListObj(iPtr->varFramePtr->objc,
+ iPtr->varFramePtr->objv);
+ result = Tcl_ListObjReplace(interp, iPtr->errorStack, len, 1, 1, &listPtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ }
+ }
}
/*
@@ -7640,5 +7675,7 @@
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
Index: generic/tclResult.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclResult.c,v
retrieving revision 1.54
diff -u -r1.54 tclResult.c
--- generic/tclResult.c 17 Dec 2008 16:47:38 -0000 1.54
+++ generic/tclResult.c 7 Oct 2009 07:01:22 -0000
@@ -922,6 +922,7 @@
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
+ iPtr->resetErrorStack = 1;
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
if (iPtr->returnOpts) {
Index: tests/error.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/error.test,v
retrieving revision 1.22
diff -u -r1.22 error.test
--- tests/error.test 28 Sep 2009 18:02:20 -0000 1.22
+++ tests/error.test 7 Oct 2009 07:01:22 -0000
@@ -152,6 +152,29 @@
set ::errorCode bogus
list [catch {error msg1 msg2 {}} msg] $msg $::errorInfo $::errorCode
} {1 msg1 msg2 {}}
+test error-4.6 {errorStack disabled by default} {
+ set ::tcl::errorStack NOPE
+ proc f x {g $x$x}
+ proc g x {error G:$x}
+ catch {f 12}
+ set ::tcl::errorStack
+} NOPE
+test error-4.7 {errorStack disabled by useErrorStack} {
+ set ::tcl::useErrorStack 0
+ set ::tcl::errorStack NOPE
+ proc f x {g $x$x}
+ proc g x {error G:$x}
+ catch {f 12}
+ set ::tcl::errorStack
+} NOPE
+test error-4.8 {errorStack enabled by useErrorStack} -body {
+ set ::tcl::useErrorStack 1
+ set ::tcl::errorStack NOPE
+ proc f x {g $x$x}
+ proc g x {error G:$x}
+ catch {f 12}
+ set ::tcl::errorStack
+} -match glob -result {{g 1212} {f 12} {namespace eval *}}
# Errors in error command itself
@@ -207,6 +230,16 @@
catch foo
list $::errorCode
} {NONE}
+test error-6.10 {catch must reset errorStack} -body {
+ set ::tcl::useErrorStack 1
+ proc f x {g $x$x}
+ proc g x {error G:$x}
+ catch {f 12}
+ set e1 $::tcl::errorStack
+ catch {f 13}
+ set e2 $::tcl::errorStack
+ list $e1 $e2
+} -match glob -result {{{g 1212} {f 12} {namespace eval *}} {{g 1313} {f 13} {namespace eval *}}}
test error-7.1 {Bug 1397843} -body {
variable cmds
