summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2005-11-14 00:41:05 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2005-11-14 00:41:05 (GMT)
commit9264d5ca1bd013c78fc5f822303ce4c03bde8c74 (patch)
tree6ca36e542384ebbf3ca170a55c48aae2d07c3394
parentd6c73ab77833ab9488ab9930031dd0851a931cb4 (diff)
downloadtcl-9264d5ca1bd013c78fc5f822303ce4c03bde8c74.zip
tcl-9264d5ca1bd013c78fc5f822303ce4c03bde8c74.tar.gz
tcl-9264d5ca1bd013c78fc5f822303ce4c03bde8c74.tar.bz2
* generic/tclInt.h:
* generic/tclNamesp.c: * tests/namespace.test: fix for bugs #1354540 and #1355942. The new tests 7.3-6 and the modified 51.13 fail due to the unrelated [Bug 1355342] * tests/trace.test: added tests 20.13-16 for [Bug 1355342]
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclNamesp.c15
-rw-r--r--tests/namespace.test42
-rw-r--r--tests/trace.test24
5 files changed, 84 insertions, 12 deletions
diff --git a/ChangeLog b/ChangeLog
index 39f0d06..bd6dedb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2005-11-13 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclInt.h:
+ * generic/tclNamesp.c:
+ * tests/namespace.test: fix for bugs #1354540 and #1355942. The
+ new tests 7.3-6 and the modified 51.13 fail due to the unrelated
+ [Bug 1355342]
+
+ * tests/trace.test: added tests 20.13-16 for [Bug 1355342]
+
2005-11-12 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (Tcl_DeleteCommandFromToken):
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 480507d..8558e14 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.257 2005/11/12 04:08:05 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.258 2005/11/14 00:41:05 msofer Exp $
*/
#ifndef _TCLINT
@@ -308,10 +308,13 @@ struct NamespacePathEntry {
* 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
/*
* Flags passed to TclGetNamespaceForQualName:
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 123a584..a1b81c0 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.87 2005/11/12 23:15:50 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.88 2005/11/14 00:41:05 msofer Exp $
*/
#include "tclInt.h"
@@ -941,13 +941,17 @@ Tcl_DeleteNamespace(
}
}
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)) {
@@ -3277,13 +3281,14 @@ NamespaceDeleteCmd(
/*
* Destroying one namespace may cause another to be destroyed. Break this
* into two passes: first check to make sure that all namespaces on the
- * command line are valid, and report any errors.
+ * command line are valid, and report any errors.
*/
for (i = 2; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
- if (namespacePtr == NULL) {
+ if ((namespacePtr == NULL)
+ || (((Namespace *)namespacePtr)->flags & NS_KILLED)) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[i]),
"\" in namespace delete command", NULL);
diff --git a/tests/namespace.test b/tests/namespace.test
index 947beb6..ede0e00 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.46 2005/07/05 17:33:07 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.47 2005/11/14 00:41:05 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -133,6 +133,37 @@ 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} {
+ 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} {
+ # Currently fails due to [Bug 1355342]
+ 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} {
+ 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, active call frames in ns} {
+ # Currently fails due to [Bug 1355342]
+ 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}
@@ -2278,8 +2309,9 @@ test namespace-51.12 {name resolution path control} -body {
catch {namespace delete ::test_ns_3}
catch {namespace delete ::test_ns_4}
}
-# Fails right now due to unrelated bug...
-test namespace-51.13 {name resolution path control} -constraints knownBug -body {
+
+test namespace-51.13 {name resolution path control} -body {
+ # Currently fails due to [Bug 1355342]
set ::result {}
namespace eval ::test_ns_1 {
proc foo {} {lappend ::result 1}
@@ -2302,8 +2334,8 @@ test namespace-51.13 {name resolution path control} -constraints knownBug -body
}
bar
}
- # Should the result be "2 {} {2 3 1 1}" instead?
-} -result {2 {} {2 3 2 1}} -cleanup {
+ # Should the result be "2 {} {2 3 2 1}" instead?
+} -result {2 {} {2 3 1 1}} -cleanup {
catch {namespace delete ::test_ns_1}
catch {namespace delete ::test_ns_2}
catch {namespace delete ::test_ns_3}
diff --git a/tests/trace.test b/tests/trace.test
index befb0c8..7009503 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.45 2005/11/07 10:17:59 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.46 2005/11/14 00:41:06 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1484,6 +1484,28 @@ 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 }