diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 16 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 11 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 21 | ||||
| -rw-r--r-- | tests/namespace.test | 34 | ||||
| -rw-r--r-- | tests/trace.test | 23 |
7 files changed, 99 insertions, 20 deletions
@@ -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 } |