diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 15 | ||||
| -rw-r--r-- | tests/namespace.test | 42 | ||||
| -rw-r--r-- | tests/trace.test | 24 |
5 files changed, 84 insertions, 12 deletions
@@ -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 } |