* generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization

        * generic/tclCmdAH.c (Tcl_ErrorObjCmd):     of the management of
        * generic/tclCmdMZ.c (TclProcessReturn):    the errorCode value.
        * tests/error.test (error-6.4-9):

        * generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified
        * tests/namespace.test (namespace-8.5,6):       the save/restore
        of ::errorInfo and ::errorCode during global namespace teardown.
        Revised the comment to clarify why this is done, and added tests
        that will fail if this is not done.

        * generic/tclResult.c (TclTransferResult):      Added safety
        checks so that unexpected undefined ::errorInfo or ::errorCode
        will not lead to a segfault.

        * generic/tclTrace.c (TclCallVarTraces):     Save/restore the flag
        * tests/var.test (var-16.1):    values that define part of the
        interpreter state during variable traces.  [Bug 10381021].

10 files changed, 130 insertions, 64 deletions

diff --git a/ChangeLog b/ChangeLog
index bdcb2bd..06cfd7c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,24 @@
+2004-09-30  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c (Tcl_AddObjErrorInfo): More re-organization
+	* generic/tclCmdAH.c (Tcl_ErrorObjCmd):     of the management of
+	* generic/tclCmdMZ.c (TclProcessReturn):    the errorCode value.
+	* tests/error.test (error-6.4-9):
+
+        * generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified
+        * tests/namespace.test (namespace-8.5,6):       the save/restore
+        of ::errorInfo and ::errorCode during global namespace teardown.
+        Revised the comment to clarify why this is done, and added tests
+        that will fail if this is not done.
+
+        * generic/tclResult.c (TclTransferResult):      Added safety
+        checks so that unexpected undefined ::errorInfo or ::errorCode
+        will not lead to a segfault.
+
+        * generic/tclTrace.c (TclCallVarTraces):     Save/restore the flag
+        * tests/var.test (var-16.1):    values that define part of the
+        interpreter state during variable traces.  [Bug 10381021].
+
 2004-09-30  Miguel Sofer <msofer@users.sf.net>
 
 	* tests/subst.test (12.1-2): added tests for [Bug 1036649]
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6401e73..ea3e03c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBasic.c,v 1.119 2004/09/27 22:39:20 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.120 2004/09/30 23:06:47 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -4529,20 +4529,6 @@ Tcl_AddObjErrorInfo(interp, message, length)
 	    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 
 	            Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
 	}
-
-	/*
-	 * If the errorCode variable wasn't set by the code that generated
-	 * the error, set it to "NONE".
-	 *
-	 * NOTE: The main check for setting the default value of
-	 * errorCode to NONE is in Tcl_LogCommandInfo.  This one
-	 * should go away, but currently it's taking care of setting
-	 * up errorCode after compile errors.
-	 */
-
-	if (!(iPtr->flags & ERROR_CODE_SET)) {
-	    Tcl_SetErrorCode(interp, "NONE", NULL);
-	}
     }
 
     /*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index b1c1177..1af7958 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdAH.c,v 1.49 2004/09/27 19:59:36 kennykb Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.50 2004/09/30 23:06:47 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -623,8 +623,10 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
     
     if (objc == 4) {
 	Tcl_SetObjErrorCode(interp, objv[3]);
+    } else {
+	Tcl_SetErrorCode(interp, "NONE", NULL);
     }
-    
+
     Tcl_SetObjResult(interp, objv[1]);
     return TCL_ERROR;
 }
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 93eda56..2a41a1b 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.107 2004/09/22 22:23:39 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.108 2004/09/30 23:06:48 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -920,6 +920,8 @@ TclProcessReturn(interp, code, level, returnOpts)
 		    iPtr->returnErrorcodeKey, &valuePtr);
 	    if (valuePtr != NULL) {
 		Tcl_SetObjErrorCode(interp, valuePtr);
+	    } else {
+		Tcl_SetErrorCode(interp, "NONE", NULL);
 	    }
 
 	    valuePtr = NULL;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 9238001..9c7e7c2 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.56 2004/09/29 22:17:30 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.57 2004/09/30 23:06:48 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -860,45 +860,37 @@ TclTeardownNamespace(nsPtr)
 
     if (nsPtr == globalNsPtr) {
 	/*
-	 * This is the global namespace, so be careful to preserve the
-	 * "errorInfo" and "errorCode" variables. These might be needed
-	 * later on if errors occur while deleting commands. We are careful
-	 * to destroy and recreate the "errorInfo" and "errorCode"
-	 * variables, in case they had any traces on them.
+	 * This is the global namespace.  Tearing it down will destroy the
+	 * ::errorInfo and ::errorCode variables.  We save and restore them
+	 * in case there are any errors in progress, so the error details
+	 * they contain will not be lost.  See test namespace-8.5
 	 */
 
-        CONST char *str;
-        char *errorInfoStr, *errorCodeStr;
-
-        str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorInfo", TCL_GLOBAL_ONLY);
-        if (str != NULL) {
-            errorInfoStr = ckalloc((unsigned) (strlen(str)+1));
-            strcpy(errorInfoStr, str);
-        } else {
-            errorInfoStr = NULL;
-        }
-
-        str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorCode", TCL_GLOBAL_ONLY);
-        if (str != NULL) {
-            errorCodeStr = ckalloc((unsigned) (strlen(str)+1));
-            strcpy(errorCodeStr, str);
-        } else {
-            errorCodeStr = NULL;
-        }
-
-        TclDeleteVars(iPtr, &nsPtr->varTable);
-        Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+	Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
+		NULL, TCL_GLOBAL_ONLY);
+	Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
+		NULL, TCL_GLOBAL_ONLY);
+			                
+	if (errorInfo) {
+	    Tcl_IncrRefCount(errorInfo);
+	}   
+	if (errorCode) {
+	    Tcl_IncrRefCount(errorCode);
+	}
 
-        if (errorInfoStr != NULL) {
-            Tcl_SetVar((Tcl_Interp *) iPtr, "errorInfo", errorInfoStr,
-                TCL_GLOBAL_ONLY);
-            ckfree(errorInfoStr);
-        }
-        if (errorCodeStr != NULL) {
-            Tcl_SetVar((Tcl_Interp *) iPtr, "errorCode", errorCodeStr,
-                TCL_GLOBAL_ONLY);
-            ckfree(errorCodeStr);
-        }
+	TclDeleteVars(iPtr, &nsPtr->varTable);
+	Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+
+	if (errorInfo) {
+	    Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
+		    errorInfo, TCL_GLOBAL_ONLY);
+	    Tcl_DecrRefCount(errorInfo);
+	}   
+	if (errorCode) {
+	    Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
+		    errorCode, TCL_GLOBAL_ONLY);
+	    Tcl_DecrRefCount(errorCode);
+	}
     } else {
 	/*
 	 * Variable table should be cleared but not freed! TclDeleteVars
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 7c15182..9e83796 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclResult.c,v 1.10 2004/09/29 22:17:30 dkf Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.11 2004/09/30 23:06:48 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -1027,13 +1027,17 @@ TclTransferResult(sourceInterp, result, targetInterp)
         
 	objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
 		TCL_GLOBAL_ONLY);
-	Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
-		TCL_GLOBAL_ONLY);
-	((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
+	if (objPtr) {
+	    Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
+		    TCL_GLOBAL_ONLY);
+	    ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
+	}
 
 	objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
 		TCL_GLOBAL_ONLY);
-	Tcl_SetObjErrorCode(targetInterp, objPtr);
+	if (objPtr) {
+	    Tcl_SetObjErrorCode(targetInterp, objPtr);
+	}
     }
 
     /* This may need examination for safety */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index dd0ee44..25dad45 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclTrace.c,v 1.11 2004/08/02 20:55:38 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.12 2004/09/30 23:06:49 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2450,6 +2450,7 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
     int copiedName;
     int code = TCL_OK;
     int disposeFlags = 0;
+    int saveErrFlags = iPtr->flags;
 
     /*
      * If there are already similar trace procedures active for the
@@ -2572,6 +2573,9 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
      */
 
     done:
+    if (code == TCL_OK) {
+	iPtr->flags = saveErrFlags;
+    }
     if (code == TCL_ERROR) {
 	if (leaveErrMsg) {
 	    CONST char *type = "";
diff --git a/tests/error.test b/tests/error.test
index 3773df5..0cca88f 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: error.test,v 1.11 2004/09/20 15:52:05 dgp Exp $
+# RCS: @(#) $Id: error.test,v 1.12 2004/09/30 23:06:49 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -185,6 +185,36 @@ test error-6.3 {catch must reset error state} {
     catch {error outer [catch set]}
     list $errorCode $errorInfo
 } {NONE 1}
+test error-6.4 {catch must reset error state} {
+    catch {error [catch {error foo bar baz}] 1}
+    list $errorCode $errorInfo
+} {NONE 1}
+test error-6.5 {catch must reset error state} {
+    catch {error [catch {return -level 0 -code error -errorcode BUG}] 1}
+    list $errorCode $errorInfo
+} {NONE 1}
+test error-6.6 {catch must reset error state} {
+    catch {return -level 0 -code error -errorinfo [catch {error foo bar baz}]}
+    list $errorCode $errorInfo
+} {NONE 1}
+test error-6.7 {catch must reset error state} {
+    proc foo {} {
+	return -code error -errorinfo [catch {error foo bar baz}]
+    }
+    catch foo
+    list $errorCode
+} {NONE}
+test error-6.8 {catch must reset error state} {
+    catch {return -level 0 -code error [catch {error foo bar baz}]}
+    list $errorCode
+} {NONE}
+test error-6.9 {catch must reset error state} {
+    proc foo {} {
+	return -code error [catch {error foo bar baz}]
+    }
+    catch foo
+    list $errorCode
+} {NONE}
 
 # cleanup
 catch {rename p ""}
diff --git a/tests/namespace.test b/tests/namespace.test
index e11cfc6..2765f61 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: namespace.test,v 1.38 2004/09/24 01:14:43 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.39 2004/09/30 23:06:49 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -193,6 +193,24 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away}
          [namespace delete test_ns_export] \
          [info commands test_ns_import::*]
 } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
+test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
+    interp create slave
+    slave eval {trace add execution error leave {namespace delete :: ;#}}
+    catch {slave eval error foo bar baz}
+    interp delete slave
+    set ::errorInfo
+} {bar
+    invoked from within
+"slave eval error foo bar baz"}
+test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
+    interp create slave 
+    slave eval {trace add variable errorCode write {namespace delete :: ;#}}
+    catch {slave eval error foo bar baz}
+    interp delete slave
+    set ::errorInfo
+} {bar
+    invoked from within
+"slave eval error foo bar baz"}
 
 test namespace-9.1 {Tcl_Import, empty import pattern} {
     catch {namespace delete {expand}[namespace children :: test_ns_*]}
diff --git a/tests/var.test b/tests/var.test
index df6b491..df9d553 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: var.test,v 1.25 2004/05/19 20:33:11 dkf Exp $
+# RCS: @(#) $Id: var.test,v 1.26 2004/09/30 23:06:49 dgp Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -695,6 +695,13 @@ test var-15.1 {segfault in [unset], [Bug 735335]} {
 } {}
 
 
+test var-16.1 {CallVarTraces: save/restore interp error state} {
+    trace add variable errorCode write { ;#}
+    catch {error foo bar baz}
+    trace remove variable errorCode write { ;#}
+    set errorInfo
+} bar
+
 catch {namespace delete ns}
 catch {unset arr}
 catch {unset v}