Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 60f97c6a23246d7147f554ea84da80a4bba306f8:

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