diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 88 | ||||
| -rw-r--r-- | tests/namespace.test | 43 |
3 files changed, 109 insertions, 28 deletions
@@ -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: |