diff options
| -rw-r--r-- | ChangeLog | 21 | ||||
| -rw-r--r-- | generic/tclBasic.c | 16 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 6 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 4 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 66 | ||||
| -rw-r--r-- | generic/tclResult.c | 14 | ||||
| -rw-r--r-- | generic/tclTrace.c | 6 | ||||
| -rw-r--r-- | tests/error.test | 32 | ||||
| -rw-r--r-- | tests/namespace.test | 20 | ||||
| -rw-r--r-- | tests/var.test | 9 |
10 files changed, 130 insertions, 64 deletions
@@ -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} |