summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog16
-rw-r--r--generic/tclNamesp.c58
-rw-r--r--generic/tclResult.c15
-rw-r--r--generic/tclVar.c6
-rw-r--r--tests/namespace.test20
-rw-r--r--tests/var.test9
6 files changed, 82 insertions, 42 deletions
diff --git a/ChangeLog b/ChangeLog
index c0d2665..48e967d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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}