* 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]

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 {