summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-09-09 15:44:15 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-09-09 15:44:15 (GMT)
commitd78ee8b94bc6fcdd3bbd3b5d1c9cb5107a360e20 (patch)
tree993634e4710551fb7d9a8197455f470d1ad377c6
parent650847f3b6562e21662bff6f2eefea5bfb2628d1 (diff)
downloadtcl-d78ee8b94bc6fcdd3bbd3b5d1c9cb5107a360e20.zip
tcl-d78ee8b94bc6fcdd3bbd3b5d1c9cb5107a360e20.tar.gz
tcl-d78ee8b94bc6fcdd3bbd3b5d1c9cb5107a360e20.tar.bz2
* 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]
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclNamesp.c123
-rw-r--r--tests/namespace.test116
3 files changed, 199 insertions, 46 deletions
diff --git a/ChangeLog b/ChangeLog
index 5ad7a97..a3c7559 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 {