diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 6 | ||||
| -rw-r--r-- | generic/tclProc.c | 5 | ||||
| -rw-r--r-- | generic/tclResult.c | 19 | ||||
| -rw-r--r-- | tests/result.test | 18 |
7 files changed, 51 insertions, 12 deletions
@@ -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 |