summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2005-11-18 23:07:26 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2005-11-18 23:07:26 (GMT)
commitc97535ea03fe482ec1293e11b276eb40fd2faeb8 (patch)
tree55f1b4ed5f653180f0ac89f9dfb2510b141648c0
parentcb651f0210eff616b6ee84c8c2146bd5f1f2f320 (diff)
downloadtcl-c97535ea03fe482ec1293e11b276eb40fd2faeb8.zip
tcl-c97535ea03fe482ec1293e11b276eb40fd2faeb8.tar.gz
tcl-c97535ea03fe482ec1293e11b276eb40fd2faeb8.tar.bz2
* generic/tclBasic.c (Tcl_DeleteCommandFromToken):
* generic/tclCmdMZ.c (TraceCommandProc): * generic/tclInt.h (NS_KILLED): * generic/tclNamesp.c (Tcl_DeleteNamespace * tests/namespace.test (namespace-7.3-6): * tests/trace.test (trace-20.13-16): fix [Bugs 1355942/1355342].
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBasic.c16
-rw-r--r--generic/tclCmdMZ.c11
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclNamesp.c21
-rw-r--r--tests/namespace.test34
-rw-r--r--tests/trace.test23
7 files changed, 99 insertions, 20 deletions
diff --git a/ChangeLog b/ChangeLog
index 1b3cf33..afba03a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2005-11-18 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c (Tcl_DeleteCommandFromToken):
+ * generic/tclCmdMZ.c (TraceCommandProc):
+ * generic/tclInt.h (NS_KILLED):
+ * generic/tclNamesp.c (Tcl_DeleteNamespace
+ * tests/namespace.test (namespace-7.3-6):
+ * tests/trace.test (trace-20.13-16): fix [Bugs 1355942/1355342].
+
2005-11-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIO.c (TclFinalizeIOSubsystem): preserve statePtr
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4871844..b3474bb 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.75.2.18 2005/10/23 22:01:28 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.19 2005/11/18 23:07:26 msofer Exp $
*/
#include "tclInt.h"
@@ -2431,6 +2431,13 @@ Tcl_DeleteCommandFromToken(interp, cmd)
cmdPtr->flags |= CMD_IS_DELETED;
/*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
+ /*
* Call trace procedures for the command being deleted. Then delete
* its traces.
*/
@@ -2485,13 +2492,6 @@ Tcl_DeleteCommandFromToken(interp, cmd)
}
/*
- * Bump the command epoch counter. This will invalidate all cached
- * references that point to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
* If this command was imported into other namespaces, then imported
* commands were created that refer back to this command. Delete these
* imported commands now.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index ea272b7..9aaa6cb 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.82.2.24 2005/11/08 14:53:12 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.25 2005/11/18 23:07:27 msofer Exp $
*/
#include "tclInt.h"
@@ -4167,9 +4167,18 @@ TraceCommandProc(clientData, interp, oldName, newName, flags)
* Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
* command we're tracing has just gone away. Then decrement the
* clientData refCount that was set up by trace creation.
+ *
+ * Note that we save the (return) state of the interpreter to prevent
+ * bizarre error messages.
*/
+
+ Tcl_SaveResult(interp, &state);
+ stateCode = iPtr->returnCode;
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
+ Tcl_RestoreResult(interp, &state);
+ iPtr->returnCode = stateCode;
+
tcmdPtr->refCount--;
}
tcmdPtr->refCount--;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 60fe1d8..014ba06 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.118.2.19 2005/11/04 01:15:20 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.118.2.20 2005/11/18 23:07:27 msofer Exp $
*/
#ifndef _TCLINT
@@ -270,10 +270,13 @@ typedef struct Namespace {
* in any byte code code unit that refers to the namespace has
* been freed (i.e., when the namespace's refCount is 0), the
* namespace's storage will be freed.
+ * NS_KILLED 1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942]
*/
#define NS_DYING 0x01
#define NS_DEAD 0x02
+#define NS_KILLED 0x04
/*
* Flag passed to TclGetNamespaceForQualName to have it create all namespace
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 029051c..0400c1e 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.9 2005/11/04 01:15:20 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.10 2005/11/18 23:07:27 msofer Exp $
*/
#include "tclInt.h"
@@ -612,13 +612,17 @@ Tcl_DeleteNamespace(namespacePtr)
}
}
nsPtr->parentPtr = NULL;
- } else {
+ } else if (!(nsPtr->flags & NS_KILLED)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
- * interpreter is being torn down.
+ * interpreter is being torn down. Set the NS_KILLED flag to avoid
+ * recursive calls here - if the namespace is really in the process of
+ * being deleted, ignore any second call.
*/
+ nsPtr->flags |= (NS_DYING|NS_KILLED);
+
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
@@ -2048,11 +2052,12 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
- if (entryPtr != NULL) {
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
- }
- }
+ if (entryPtr != NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ }
+ }
}
+
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
@@ -2887,7 +2892,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv)
name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
- if (namespacePtr == NULL) {
+ if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[i]),
"\" in namespace delete command", (char *) NULL);
diff --git a/tests/namespace.test b/tests/namespace.test
index 9887ddc..2c36171 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.7 2005/11/08 18:28:56 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.21.2.8 2005/11/18 23:07:27 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -133,6 +133,38 @@ test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} {
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
+test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
+test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
diff --git a/tests/trace.test b/tests/trace.test
index 4eba508..91cc98b 100644
--- a/tests/trace.test
+++ b/tests/trace.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: trace.test,v 1.26.2.12 2005/11/07 10:28:01 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.26.2.13 2005/11/18 23:07:27 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1481,6 +1481,27 @@ test trace-20.12 {delete trace renames command} {
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
+test trace-20.13 {rename trace discards result [Bug 1355342]} {
+ proc foo {} {}
+ trace add command foo rename {set w Aha!;#}
+ list [rename foo bar] [rename bar {}]
+} {{} {}}
+test trace-20.14 {rename trace discards error result [Bug 1355342]} {
+ proc foo {} {}
+ trace add command foo rename {error}
+ list [rename foo bar] [rename bar {}]
+} {{} {}}
+test trace-20.15 {delete trace discards result [Bug 1355342]} {
+ proc foo {} {}
+ trace add command foo delete {set w Aha!;#}
+ rename foo {}
+} {}
+test trace-20.16 {delete trace discards error result [Bug 1355342]} {
+ proc foo {} {}
+ trace add command foo delete {error}
+ rename foo {}
+} {}
+
proc foo {b} { set a $b }