summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2007-06-05 17:57:05 (GMT)
committerdgp <dgp@users.sourceforge.net>2007-06-05 17:57:05 (GMT)
commit0ce2a2cb2fb98447e3060196f2415dd267330e0d (patch)
treebaea8961dd7792cf7300ab1799771f4ebdc7ad72
parent68919c24042c4dd2b585f557d98d6bea70fa1cf4 (diff)
downloadtcl-0ce2a2cb2fb98447e3060196f2415dd267330e0d.zip
tcl-0ce2a2cb2fb98447e3060196f2415dd267330e0d.tar.gz
tcl-0ce2a2cb2fb98447e3060196f2415dd267330e0d.tar.bz2
* 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]
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c3
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclNamesp.c6
-rw-r--r--generic/tclProc.c5
-rw-r--r--generic/tclResult.c19
-rw-r--r--tests/result.test18
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