diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 123 | ||||
| -rw-r--r-- | tests/namespace.test | 116 |
3 files changed, 199 insertions, 46 deletions
@@ -1,3 +1,9 @@ +2004-09-09 Don Porter <dgp@users.sourceforge.net> + + * generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty + * tests/namespace.test: logic that relied exclusively on string + matching and failed in the presence of [rename]s. [Bug 560297] + 2004-09-08 Don Porter <dgp@users.sourceforge.net> * generic/tclBasic.c (Tcl_CreateInterp): Removed obsolete diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 9d88b82..cd4b8f2 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.48 2004/08/27 13:59:28 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.49 2004/09/09 15:44:23 dgp Exp $ */ #include "tclInt.h" @@ -1095,8 +1095,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) */ TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, - &dummyPtr, &simplePattern); + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1333,8 +1333,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, - &dummyPtr, &simplePattern); + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1467,17 +1467,22 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * * Tcl_ForgetImport -- * - * Deletes previously imported commands. Given a pattern that may - * include the name of an exporting namespace, this procedure first - * finds all matching exported commands. It then looks in the namespace - * specified by namespacePtr for any corresponding previously imported - * commands, which it deletes. If namespacePtr is NULL, commands are - * deleted from the current namespace. + * Deletes commands previously imported into the namespace indicated. The + * by namespacePtr, or the current namespace of interp, when + * namespacePtr is NULL. The pattern controls which imported commands + * are deleted. A simple pattern, one without namespace separators, + * matches the current command names of imported commands in the + * namespace. Matching imported commands are deleted. A qualified + * pattern is interpreted as deletion selection on the basis of where + * the command is imported from. The original command and "first link" + * command for each imported command are determined, and they are matched + * against the pattern. A match leads to deletion of the imported + * command. * * Results: - * Returns TCL_OK if successful. If there is an error, returns - * TCL_ERROR and puts an error message in the interpreter's result - * object. + * Returns TCL_ERROR and records an error message in the interp + * result if a namespace qualified pattern refers to a namespace + * that does not exist. Otherwise, returns TCL_OK. * * Side effects: * May delete commands. @@ -1492,17 +1497,13 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * previously imported commands should be * removed. NULL for current namespace. */ CONST char *pattern; /* String pattern indicating which imported - * commands to remove. This pattern should - * be qualified by the name of the - * namespace from which the command(s) were - * imported. */ + * commands to remove. */ { - Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr; + Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Command *cmdPtr; /* * If the specified namespace is NULL, use the current namespace. @@ -1515,42 +1516,74 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) } /* - * From the pattern, find the namespace from which we are importing - * and get the simple pattern (no namespace qualifiers or ::'s) at - * the end. + * Parse the pattern into its namespace-qualification (if any) + * and the simple pattern. */ TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, - &actualCtxPtr, &simplePattern); + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); - if (importNsPtr == NULL) { + if (sourceNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown namespace in namespace forget pattern \"", pattern, "\"", (char *) NULL); return TCL_ERROR; } - /* - * Scan through the command table in the source namespace and look for - * exported commands that match the string pattern. If the current - * namespace has an imported command that refers to one of those real - * commands, delete it. - */ + if (strcmp(pattern, simplePattern) == 0) { + /* + * The pattern is simple. + * Delete any imported commands that match it. + */ - for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); - (hPtr != NULL); - hPtr = Tcl_NextHashEntry(&search)) { - cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); - if (Tcl_StringMatch(cmdName, simplePattern)) { - hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); - if (hPtr != NULL) { /* cmd of same name in current namespace */ - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (cmdPtr->deleteProc == DeleteImportedCmd) { - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - } - } - } + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + (hPtr != NULL); + hPtr = Tcl_NextHashEntry(&search)) { + Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != DeleteImportedCmd) { + continue; + } + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern)) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } + } + return TCL_OK; + } + + /* The pattern was namespace-qualified */ + + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_CmdInfo info; + Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); + Tcl_Command origin = TclGetOriginalCommand(token); + + if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { + continue; /* Not an imported command */ + } + if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { + /* + * Original not in namespace we're matching. + * Check the first link in the import chain. + */ + Command *cmdPtr = (Command *) token; + ImportedCmdData *dataPtr = + (ImportedCmdData *) cmdPtr->objClientData; + Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; + if (firstToken == origin) { + continue; + } + Tcl_GetCommandInfoFromToken(firstToken, &info); + if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { + continue; + } + origin = firstToken; + } + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { + Tcl_DeleteCommandFromToken(interp, token); + } } return TCL_OK; } diff --git a/tests/namespace.test b/tests/namespace.test index f49c09b..02aa0e5 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.34 2004/08/27 13:59:29 dkf Exp $ +# RCS: @(#) $Id: namespace.test,v 1.35 2004/09/09 15:44:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -270,6 +270,120 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { } } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] +test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval unrelated { + proc cmd {} {} + } + namespace eval my \ + [list namespace import [namespace current]::origin::cmd] +} -body { + namespace eval my \ + [list namespace forget [namespace current]::unrelated::cmd] + my::cmd +} -cleanup { + namespace delete origin unrelated my +} + +test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval my \ + [list namespace import [namespace current]::origin::cmd] + namespace eval my rename cmd newname +} -body { + namespace eval my \ + [list namespace forget [namespace current]::origin::cmd] + my::newname +} -cleanup { + namespace delete origin my +} -returnCodes error -match glob -result * + +test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval my \ + [list namespace import [namespace current]::origin::cmd] + namespace eval your {} + namespace eval my \ + [list rename cmd [namespace current]::your::newname] +} -body { + namespace eval your namespace forget newname + your::newname +} -cleanup { + namespace delete origin my your +} -returnCodes error -match glob -result * + +test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval link namespace export cmd + namespace eval link \ + [list namespace import [namespace current]::origin::cmd] + namespace eval link2 namespace export cmd + namespace eval link2 \ + [list namespace import [namespace current]::link::cmd] + namespace eval my \ + [list namespace import [namespace current]::link2::cmd] +} -body { + namespace eval my \ + [list namespace forget [namespace current]::origin::cmd] + my::cmd +} -cleanup { + namespace delete origin link link2 my +} -returnCodes error -match glob -result * + +test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval link namespace export cmd + namespace eval link \ + [list namespace import [namespace current]::origin::cmd] + namespace eval link2 namespace export cmd + namespace eval link2 \ + [list namespace import [namespace current]::link::cmd] + namespace eval my \ + [list namespace import [namespace current]::link2::cmd] +} -body { + namespace eval my \ + [list namespace forget [namespace current]::link::cmd] + my::cmd +} -cleanup { + namespace delete origin link link2 my +} + +test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { + namespace eval origin { + namespace export cmd + proc cmd {} {} + } + namespace eval link namespace export cmd + namespace eval link \ + [list namespace import [namespace current]::origin::cmd] + namespace eval link2 namespace export cmd + namespace eval link2 \ + [list namespace import [namespace current]::link::cmd] + namespace eval my \ + [list namespace import [namespace current]::link2::cmd] +} -body { + namespace eval my \ + [list namespace forget [namespace current]::link2::cmd] + my::cmd +} -cleanup { + namespace delete origin link link2 my +} -returnCodes error -match glob -result * + test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { catch {namespace delete {expand}[namespace children :: test_ns_*]} namespace eval test_ns_export { |