summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclNamesp.c88
-rw-r--r--tests/namespace.test43
3 files changed, 109 insertions, 28 deletions
diff --git a/ChangeLog b/ChangeLog
index 3a923e3..7f14a65 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2004-08-27 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclNamesp.c (FindEnsemble): Factor out the code to
+ convert a command name into an ensemble configuration and add
+ support for ignoring [namespace import] link chains. [Bug 1017022]
+
2004-08-27 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in: added customization of default module path roots
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d1da5ae..2365a22 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.45 2004/08/25 21:28:26 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.46 2004/08/27 09:07:06 dkf Exp $
*/
#include "tclInt.h"
@@ -229,6 +229,8 @@ static int NamespaceWhichCmd _ANSI_ARGS_((
static int SetNsNameFromAny _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
+static EnsembleConfig * FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *cmdNameObj, int flags));
static int NsEnsembleImplementationCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
@@ -4421,42 +4423,24 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv)
return TCL_OK;
}
- case ENS_EXISTS: {
- Command *cmdPtr;
- int flag;
-
+ case ENS_EXISTS:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
return TCL_ERROR;
}
- cmdPtr = (Command *)
- Tcl_FindCommand(interp, TclGetString(objv[3]), 0, 0);
- flag = (cmdPtr != NULL &&
- cmdPtr->objProc == NsEnsembleImplementationCmd);
- Tcl_SetBooleanObj(Tcl_GetObjResult(interp), flag);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
+ FindEnsemble(interp, objv[3], 0) != NULL);
return TCL_OK;
- }
-
- case ENS_CONFIG: {
- char *cmdName;
- Command *cmdPtr;
+ case ENS_CONFIG:
if (objc < 4 || (objc != 5 && objc & 1)) {
Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
return TCL_ERROR;
}
- cmdName = TclGetString(objv[3]);
- cmdPtr = (Command *)
- Tcl_FindCommand(interp, cmdName, 0, TCL_LEAVE_ERR_MSG);
- if (cmdPtr == NULL) {
+ ensemblePtr = FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
+ if (ensemblePtr == NULL) {
return TCL_ERROR;
}
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, cmdName, " is not an ensemble command",
- NULL);
- return TCL_ERROR;
- }
- ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
if (objc == 5) {
if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
@@ -4722,7 +4706,6 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv)
ensemblePtr->nsPtr->exportLookupEpoch++;
return TCL_OK;
}
- }
default:
Tcl_Panic("unexpected ensemble command");
@@ -4733,6 +4716,59 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * FindEnsemble --
+ *
+ * Given a command name, get the ensemble configuration structure
+ * for it, allowing for [namespace import]s. [Bug 1017022]
+ *
+ * Results:
+ * A pointer to the config struct, or NULL if the command either
+ * does not exist or is not an ensemble.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static EnsembleConfig *
+FindEnsemble(interp, cmdNameObj, flags)
+ Tcl_Interp *interp; /* Where to do the lookup, and where
+ * to write the errors if
+ * TCL_LEAVE_ERR_MSG is set in the
+ * flags. */
+ Tcl_Obj *cmdNameObj; /* Name of command to look up. */
+ int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other
+ * flags are probably not useful. */
+{
+ Command *cmdPtr;
+
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
+ if (cmdPtr == NULL) {
+ return NULL;
+ }
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ /*
+ * Reuse existing infrastructure for following import link
+ * chains rather than duplicating it.
+ */
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+
+ if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
+ "\" is not an ensemble command", NULL);
+ }
+ return NULL;
+ }
+ }
+ return (EnsembleConfig *) cmdPtr->objClientData;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NsEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
diff --git a/tests/namespace.test b/tests/namespace.test
index 0235d74..19c62ae 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.31 2004/08/25 21:37:29 dkf Exp $
+# RCS: @(#) $Id: namespace.test,v 1.32 2004/08/27 09:07:06 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -1649,7 +1649,8 @@ test namespace-47.6 {ensemble: unknown handler} {
while parsing result of ensemble unknown subcommand handler
invoked from within
"foo bar"}}
-test namespace-47.7 {ensemble: unknown handler and namespace import} {
+
+test namespace-48.1 {ensembles and namespace import: unknown handler} {
namespace eval foo {
namespace export bar
namespace ensemble create -command bar -unknown ::foo::u -subcomm x
@@ -1675,6 +1676,40 @@ test namespace-47.7 {ensemble: unknown handler and namespace import} {
namespace delete foo
set result
} {1 {bar is not an ensemble command} XXX 123 ::foo::bar {y 456} YYY 456}
+test namespace-48.2 {ensembles and namespace import: exists} {
+ namespace eval foo {
+ namespace ensemble create -command ::foo::bar
+ namespace export bar
+ }
+ set result [namespace ensemble exist foo::bar]
+ lappend result [namespace ensemble exist bar]
+ namespace import foo::bar
+ lappend result [namespace ensemble exist bar]
+ rename foo::bar foo::bar2
+ lappend result [namespace ensemble exist bar] \
+ [namespace ensemble exist spong]
+ rename bar spong
+ lappend result [namespace ensemble exist bar] \
+ [namespace ensemble exist spong]
+ rename foo::bar2 {}
+ lappend result [namespace ensemble exist spong]
+ namespace delete foo
+ set result
+} {1 0 1 1 0 0 1 0}
+test namespace-48.3 {ensembles and namespace import: config} {
+ catch {rename spong {}}
+ namespace eval foo {
+ namespace ensemble create -command ::foo::bar
+ namespace export bar boo
+ proc boo {} {}
+ }
+ namespace import foo::bar foo::boo
+ set result [namespace ensemble config bar -namespace]
+ lappend result [catch {namespace ensemble config boo} msg] $msg
+ lappend result [catch {namespace ensemble config spong} msg] $msg
+ namespace delete foo
+ set result
+} {::foo 1 {boo is not an ensemble command} 1 {invalid command name "spong"}}
# cleanup
catch {rename cmd1 {}}
@@ -1684,3 +1719,7 @@ catch {unset trigger}
namespace delete {expand}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End: