diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 58 | ||||
| -rw-r--r-- | generic/tclResult.c | 15 | ||||
| -rw-r--r-- | generic/tclVar.c | 6 | ||||
| -rw-r--r-- | tests/namespace.test | 20 | ||||
| -rw-r--r-- | tests/var.test | 9 |
6 files changed, 82 insertions, 42 deletions
@@ -1,3 +1,19 @@ +2004-09-30 Don Porter <dgp@users.sourceforge.net> + + * 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/tclVar.c (CallVarTraces): 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.2): test correction. diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7e238d0..d319100 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -19,7 +19,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.31.2.4 2004/09/10 18:22:09 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.5 2004/09/30 22:45:14 dgp Exp $ */ #include "tclInt.h" @@ -713,45 +713,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; + Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo", + NULL, TCL_GLOBAL_ONLY); + Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode", + NULL, TCL_GLOBAL_ONLY); - 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; - } + if (errorInfo) { + Tcl_IncrRefCount(errorInfo); + } + if (errorCode) { + Tcl_IncrRefCount(errorCode); + } TclDeleteVars(iPtr, &nsPtr->varTable); Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); - 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); - } + 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 9cfbd63..badaf89 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.5.2.1 2003/07/16 21:25:07 hobbs Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.5.2.2 2004/09/30 22:45:15 dgp Exp $ */ #include "tclInt.h" @@ -1029,15 +1029,18 @@ TclTransferResult(sourceInterp, result, targetInterp) objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); - Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, - TCL_GLOBAL_ONLY); + 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_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr, - TCL_GLOBAL_ONLY); + if (objPtr) { + Tcl_SetObjErrorCode(targetInterp, objPtr); + } - ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET); } ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; diff --git a/generic/tclVar.c b/generic/tclVar.c index 8478394..03b005e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.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: tclVar.c,v 1.69.2.6 2004/08/16 14:18:26 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.69.2.7 2004/09/30 22:45:15 dgp Exp $ */ #include "tclInt.h" @@ -4133,6 +4133,7 @@ CallVarTraces(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 @@ -4255,6 +4256,9 @@ CallVarTraces(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/namespace.test b/tests/namespace.test index 1751eb5..daa6ecd 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.21.2.2 2004/09/09 17:12:13 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.21.2.3 2004/09/30 22:45:17 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 {eval namespace delete [namespace children :: test_ns_*]} diff --git a/tests/var.test b/tests/var.test index 2f0c1df..64f52707 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.20.2.2 2003/05/12 17:31:51 msofer Exp $ +# RCS: @(#) $Id: var.test,v 1.20.2.3 2004/09/30 22:45:17 dgp Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -694,6 +694,13 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test unset useSomeUnlikelyNameHere } {} +test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} { + 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} |