* generic/tclBasic.c: Added interp flag value ERR_LEGACY_COPY to

        * generic/tclInt.h:     control the timing with which the global
        * generic/tclNamesp.c:  variables ::errorCode and ::errorInfo get
        * generic/tclProc.c:    updated after an error.  This keeps more
        * generic/tclResult.c:  precise compatibility with Tcl 8.4.
        * tests/result.test (result-6.2):       [Bug 1649062]

7 files changed, 51 insertions, 12 deletions

diff --git a/ChangeLog b/ChangeLog
index d1d51b2..b117f35 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2007-06-05  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:	Added interp flag value ERR_LEGACY_COPY to
+	* generic/tclInt.h:	control the timing with which the global
+	* generic/tclNamesp.c:	variables ::errorCode and ::errorInfo get
+	* generic/tclProc.c:	updated after an error.  This keeps more
+	* generic/tclResult.c:	precise compatibility with Tcl 8.4.
+	* tests/result.test (result-6.2):	[Bug 1649062]
+
 2007-06-05  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclInt.h:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6471e6f..06cc63e 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.245 2007/05/30 18:12:57 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.246 2007/06/05 17:57:06 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -5227,6 +5227,7 @@ Tcl_AddObjErrorInfo(
      * the error message in the interpreter's result.
      */
 
+    iPtr->flags |= ERR_LEGACY_COPY;
     if (iPtr->errorInfo == NULL) {
 	if (iPtr->result[0] != 0) {
 	    /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b9c8f3a..ba41155 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.312 2007/06/05 17:50:56 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.313 2007/06/05 17:57:07 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1848,6 +1848,7 @@ typedef struct InterpList {
 #define SAFE_INTERP			 0x80
 #define INTERP_TRACE_IN_PROGRESS	0x200
 #define INTERP_ALTERNATE_WRONG_ARGS	0x400
+#define ERR_LEGACY_COPY			0x800
 
 /*
  * Maximum number of levels of nesting permitted in Tcl commands (used to
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index c090271..2d5d30b 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,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.134 2007/05/07 19:45:33 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.135 2007/06/05 17:57:07 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -622,7 +622,7 @@ ErrorCodeRead(
 {
     Interp *iPtr = (Interp *)interp;
 
-    if (Tcl_InterpDeleted(interp)) {
+    if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
 	return NULL;
     }
     if (iPtr->errorCode) {
@@ -696,7 +696,7 @@ ErrorInfoRead(
 {
     Interp *iPtr = (Interp *)interp;
 
-    if (Tcl_InterpDeleted(interp)) {
+    if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
 	return NULL;
     }
     if (iPtr->errorInfo) {
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 51b18115..f82458f 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.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: tclProc.c,v 1.115 2007/05/11 09:17:01 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.116 2007/06/05 17:57:07 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2026,6 +2026,9 @@ TclUpdateReturnInfo(
 	 */
 
 	code = iPtr->returnCode;
+	if (code == TCL_ERROR) {
+	    iPtr->flags |= ERR_LEGACY_COPY;
+	}
     }
     return code;
 }
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9512989..c77e634 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.36 2007/04/20 06:10:58 kennykb Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.37 2007/06/05 17:57:08 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -906,15 +906,19 @@ Tcl_ResetResult(
     iPtr->resultSpace[0] = 0;
     if (iPtr->errorCode) {
 	/* Legacy support */
-	Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
-		iPtr->errorCode, TCL_GLOBAL_ONLY);
+	if (iPtr->flags & ERR_LEGACY_COPY) {
+	    Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
+		    iPtr->errorCode, TCL_GLOBAL_ONLY);
+	}
 	Tcl_DecrRefCount(iPtr->errorCode);
 	iPtr->errorCode = NULL;
     }
     if (iPtr->errorInfo) {
 	/* Legacy support */
-	Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
-		iPtr->errorInfo, TCL_GLOBAL_ONLY);
+	if (iPtr->flags & ERR_LEGACY_COPY) {
+	    Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+		    iPtr->errorInfo, TCL_GLOBAL_ONLY);
+	}
 	Tcl_DecrRefCount(iPtr->errorInfo);
 	iPtr->errorInfo = NULL;
     }
@@ -924,7 +928,7 @@ Tcl_ResetResult(
 	Tcl_DecrRefCount(iPtr->returnOpts);
 	iPtr->returnOpts = NULL;
     }
-    iPtr->flags &= ~ERR_ALREADY_LOGGED;
+    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_LEGACY_COPY);
 }
 
 /*
@@ -1237,6 +1241,9 @@ TclProcessReturn(
 	iPtr->returnCode = code;
 	return TCL_RETURN;
     }
+    if (code == TCL_ERROR) {
+	iPtr->flags |= ERR_LEGACY_COPY;
+    }
     return code;
 }
 
diff --git a/tests/result.test b/tests/result.test
index fa21bf7..cefcaed 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -114,7 +114,25 @@ test result-6.1 {Bug 1209759} -constraints testreturn -body {
     # Might panic if bug is not fixed.
     proc foo {} {catch {return -level 2}; testreturn}
     foo
+} -cleanup {
+    rename foo {}
 } -returnCodes ok -result {}
+test result-6.2 {Bug 1649062} -setup {
+    proc foo {} {
+        if {[catch {
+            return -code error -errorinfo custom -errorcode CUSTOM foo
+        } err]} {
+            return [list $err $::errorCode $::errorInfo]
+        }
+    }
+    set ::errorInfo {}
+    set ::errorCode {}
+} -body {
+    foo
+} -cleanup {
+    rename foo {}
+} -result {foo {} {}}
+
 
 # cleanup
 cleanupTests