diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | doc/Ensemble.3 | 42 | ||||
| -rw-r--r-- | doc/namespace.n | 30 | ||||
| -rw-r--r-- | generic/tcl.decls | 13 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 16 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 285 | ||||
| -rw-r--r-- | tests/namespace.test | 223 |
7 files changed, 569 insertions, 53 deletions
@@ -1,3 +1,16 @@ +2008-09-28 Donal K. Fellows <dkf@users.sf.net> + + TIP #314 IMPLEMENTATION + + * generic/tclCompCmds.c (TclCompileEnsemble) + * generic/tclNamesp.c (NamespaceEnsembleCmd) + (Tcl_SetEnsembleParameterList, Tcl_GetEnsembleParameterList) + (NsEnsembleImplementationCmdNR): + * generic/tcl.decls, doc/Ensemble.3, doc/namespace.n + * tests/namespace.test: Allow the handling of a (fixed) number of + formal parameters between an ensemble's command and subcommand at + invokation time. [Patch 1901783] + 2008-09-28 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: Fix the numLevels computations on diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index 5fbdea1..07e67db 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Ensemble.3,v 1.6 2008/04/20 02:52:29 georgeps Exp $ +'\" RCS: @(#) $Id: Ensemble.3,v 1.7 2008/09/28 22:17:37 dkf Exp $ '\" '\" This documents the C API introduced in TIP#235 '\" @@ -38,6 +38,14 @@ int int \fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR) .sp +.VS 8.6 +int +\fBTcl_GetEnsembleParameterList\fR(\fIinterp, token, listObjPtr\fR) +.sp +int +\fBTcl_SetEnsembleParameterList\fR(\fIinterp, token, listObj\fR) +.VE 8.6 +.sp int \fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR) .sp @@ -88,17 +96,18 @@ dictionary is to be removed. Pointer to a variable into which to write the current ensemble mapping dictionary. .AP Tcl_Obj *listObj in -A list value to use for the defined list of subcommands in the -dictionary or the unknown subcommmand handler command prefix. May be -NULL if the subcommand list or unknown handler are to be removed. +A list value to use for the list of formal pre-subcommand parameters, the +defined list of subcommands in the dictionary or the unknown subcommmand +handler command prefix. May be NULL if the subcommand list or unknown handler +are to be removed. .AP Tcl_Obj **listObjPtr out -Pointer to a variable into which to write the current defined list of -subcommands or the current unknown handler prefix. +Pointer to a variable into which to write the current list of formal +pre-subcommand parameters, the defined list of subcommands or the current +unknown handler prefix. .AP Tcl_Namespace **namespacePtrPtr out Pointer to a variable into which to write the handle of the namespace to which the ensemble is bound. .BE - .SH DESCRIPTION An ensemble is a command, bound to some namespace, which consists of a collection of subcommands implemented by other Tcl commands. The first @@ -128,6 +137,7 @@ Every ensemble has four read-write properties and a read-only property. The properties are: .TP \fBflags\fR (read-write) +. The set of flags for the ensemble, expressed as a bit-field. Currently, the only public flag is TCL_ENSEMBLE_PREFIX which is set when unambiguous prefixes of subcommands are permitted to @@ -138,6 +148,7 @@ functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). .TP \fBmapping dictionary\fR (read-write) +. A dictionary containing a mapping from subcommand names to lists of words to use as a command prefix (replacing the first two words of the command which are the ensemble command itself and the subcommand @@ -151,7 +162,21 @@ ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. .TP +\fBformal pre-subcommand parameter list\fR (read-write) +.VS 8.6 +A list of formal parameter names (the names only being used when generating +error messages) that come at invokation of the ensemble between the name of +the ensemble and the subcommand argument. NULL (the default) is equivalent to +the empty list. May be read and written using +\fBTcl_GetEnsembleParameterList\fR and \fBTcl_SetEnsembleParameterList\fR +respectively. The result of both of those functions is a Tcl result code +(TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the +dictionary obtained from \fBTcl_GetEnsembleParameterList\fR should always be +treated as immutable even if it is unshared. +.VE 8.6 +.TP \fBsubcommand list\fR (read-write) +. A list of all the subcommand names for the ensemble, or NULL if this is to be derived from either the keys of the mapping dictionary (see above) or (if that is also NULL) from the set of commands exported by @@ -164,6 +189,7 @@ token does not refer to an ensemble) and the list obtained from immutable even if it is unshared. .TP \fBunknown subcommand handler command prefix\fR (read-write) +. A list of words to prepend on the front of any subcommand when the subcommand is unknown to the ensemble (according to the current prefix handling rule); see the \fBnamespace ensemble\fR command for more @@ -177,12 +203,12 @@ not refer to an ensemble) and the list obtained from immutable even if it is unshared. .TP \fBbound namespace\fR (read-only) +. The namespace to which the ensemble is bound; when the namespace is deleted, so too will the ensemble, and this namespace is also the namespace whose list of exported commands is used if both the mapping dictionary and the subcommand list properties are NULL. May be read using \fBTcl_GetEnsembleNamespace\fR which returns a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble). - .SH "SEE ALSO" namespace(n), Tcl_DeleteCommandFromToken(3) diff --git a/doc/namespace.n b/doc/namespace.n index f2bc686..faee9c8 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -7,7 +7,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.n,v 1.33 2008/09/26 19:36:50 dgp Exp $ +'\" RCS: @(#) $Id: namespace.n,v 1.34 2008/09/28 22:17:39 dkf Exp $ '\" .so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" @@ -731,6 +731,14 @@ name. Note that when this option is non-empty and the \fB\-subcommands\fR option is empty, the ensemble subcommand names will be exactly those words that have mappings in the dictionary. .TP +\fB\-parameters\fR +.VS 8.6 +This option gives a list of named arguments (the names being used during +generation of error messages) that are passed by the caller of the ensemble +between the name of the ensemble and the subcommand argument. By default, it +is the empty list. +.VE 8.6 +.TP \fB\-prefixes\fR . This option (which is enabled by default) controls whether the @@ -874,7 +882,27 @@ Remove all imported commands from the current namespace: .CS namespace forget {*}[namespace import] .CE +.PP +.VS 8.6 +Create an ensemble for simple working with numbers, using the +\fB\-parameters\fR option to allow the operator to be put between the first +and second arguments. +.CS +\fBnamespace eval\fR do { + \fBnamespace export\fR * + \fBnamespace ensemble\fR create -parameters x + proc plus {x y} {expr { $x + $y }} + proc minus {x y} {expr { $x - $y }} +} + +# In use, the ensemble works like this: +puts [do 1 plus [do 9 minus 7]] +.CE +.VE 8.6 .SH "SEE ALSO" interp(n), upvar(n), variable(n) .SH KEYWORDS command, ensemble, exported, internal, variable +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/generic/tcl.decls b/generic/tcl.decls index 0d8fea6..8a65b76 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.144 2008/09/24 09:41:13 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.145 2008/09/28 22:17:39 dkf Exp $ library tcl @@ -2187,6 +2187,17 @@ declare 601 generic { unsigned Tcl_GetBlockSizeFromStat(const Tcl_StatBuf *statPtr) } +# TIP#314 (ensembles with parameters) +declare 602 generic { + int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj *paramList) +} +declare 603 generic { + int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, + Tcl_Obj **paramListPtr) +} + + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index dae4417..877bb11 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.146 2008/07/27 22:18:22 nijtmans Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.147 2008/09/28 22:17:39 dkf Exp $ */ #include "tclInt.h" @@ -6219,6 +6219,20 @@ TclCompileEnsemble( } /* + * Also refuse to compile anything that uses a formal parameter list for + * now, on the grounds that it is too complex. + */ + + if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK + || listObj != NULL) { + /* + * Figuring out how to compile this has become too much. Bail out. + */ + + return TCL_ERROR; + } + + /* * Next, get the flags. We need them on several code paths. */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e08ab4e..c05913d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,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.177 2008/09/26 19:36:50 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.178 2008/09/28 22:17:39 dkf Exp $ */ #include "tclInt.h" @@ -55,12 +55,12 @@ static Tcl_ThreadDataKey dataKey; */ typedef struct ResolvedNsName { - Namespace *nsPtr; /* A cached pointer to the Namespace that the - * name resolved to. */ - Namespace *refNsPtr; /* Points to the namespace context in which the - * name was resolved. NULL if the name is fully - * qualified and thus the resolution does not - * depend on the context. */ + Namespace *nsPtr; /* A cached pointer to the Namespace that the + * name resolved to. */ + Namespace *refNsPtr; /* Points to the namespace context in which + * the name was resolved. NULL if the name is + * fully qualified and thus the resolution + * does not depend on the context. */ int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This @@ -139,6 +139,11 @@ typedef struct EnsembleConfig { * subcommand will be reparsed by the ensemble * core, presumably because the ensemble * itself has been updated. */ + Tcl_Obj *parameterList; /* List of ensemble parameter names. */ + int numParameters; /* Cached number of parameters. This is either + * 0 (if the parameterList field is NULL) or + * the length of the list in the parameterList + * field. */ } EnsembleConfig; #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead @@ -4807,16 +4812,19 @@ NamespaceEnsembleCmd( ENS_CONFIG, ENS_CREATE, ENS_EXISTS }; static const char *createOptions[] = { - "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL + "-command", "-map", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL }; enum EnsCreateOpts { - CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN + CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN }; static const char *configOptions[] = { - "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL + "-map", "-namespace", "-parameters", "-prefixes", "-subcommands", + "-unknown", NULL }; enum EnsConfigOpts { - CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN + CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS, + CONF_UNKNOWN }; int index; @@ -4851,6 +4859,7 @@ NamespaceEnsembleCmd( Tcl_Obj *mapObj = NULL; int permitPrefix = 1; Tcl_Obj *unknownObj = NULL; + Tcl_Obj *paramObj = NULL; objv += 3; objc -= 3; @@ -4891,6 +4900,15 @@ NamespaceEnsembleCmd( } subcmdObj = (len > 0 ? objv[1] : NULL); continue; + case CRT_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; case CRT_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; @@ -4997,6 +5015,7 @@ NamespaceEnsembleCmd( Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); /* * Tricky! Must ensure that the result is not shared (command delete @@ -5020,7 +5039,8 @@ NamespaceEnsembleCmd( case ENS_CONFIG: if (objc < 4 || (objc != 5 && objc & 1)) { - Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?-option value ...? ?arg ...?"); + Tcl_WrongNumArgs(interp, 3, objv, + "cmdname ?-option value ...? ?arg ...?"); return TCL_ERROR; } token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); @@ -5042,6 +5062,12 @@ NamespaceEnsembleCmd( Tcl_SetObjResult(interp, resultObj); } break; + case CONF_PARAM: + Tcl_GetEnsembleParameterList(NULL, token, &resultObj); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + } + break; case CONF_MAP: Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); if (resultObj != NULL) { @@ -5099,6 +5125,13 @@ NamespaceEnsembleCmd( Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, -1)); + /* -parameters option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(configOptions[CONF_PARAM], -1)); + Tcl_GetEnsembleParameterList(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + /* -prefix option */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); @@ -5126,12 +5159,13 @@ NamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; - Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ int permitPrefix, flags = 0; /* silence gcc 4 warning */ Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); Tcl_GetEnsembleFlags(NULL, token, &flags); permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; @@ -5164,6 +5198,15 @@ NamespaceEnsembleCmd( } subcmdObj = (len > 0 ? objv[1] : NULL); continue; + case CONF_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; @@ -5273,6 +5316,7 @@ NamespaceEnsembleCmd( : flags&~TCL_ENSEMBLE_PREFIX); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); + Tcl_SetEnsembleParameterList(interp, token, paramObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); Tcl_SetEnsembleFlags(interp, token, flags); return TCL_OK; @@ -5339,6 +5383,8 @@ Tcl_CreateEnsemble( ensemblePtr->subcmdList = NULL; ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; + ensemblePtr->numParameters = 0; + ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = Tcl_NRCreateCommand(interp, name, NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, @@ -5441,6 +5487,81 @@ Tcl_SetEnsembleSubcommandList( /* *---------------------------------------------------------------------- * + * Tcl_SetEnsembleParameterList -- + * + * Set the parameter list for a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an ensemble + * or the parameter list - if non-NULL - is not a list). + * + * Side effects: + * The ensemble is updated and marked for recompilation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetEnsembleParameterList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj *paramList) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + Tcl_Obj *oldList; + int length; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + return TCL_ERROR; + } + if (paramList == NULL) { + length = 0; + } else { + if (TclListObjLength(interp, paramList, &length) != TCL_OK) { + return TCL_ERROR; + } + if (length < 1) { + paramList = NULL; + } + } + + ensemblePtr = cmdPtr->objClientData; + oldList = ensemblePtr->parameterList; + ensemblePtr->parameterList = paramList; + if (paramList != NULL) { + Tcl_IncrRefCount(paramList); + } + if (oldList != NULL) { + TclDecrRefCount(oldList); + } + ensemblePtr->numParameters = length; + + /* + * Trigger an eventual recomputation of the ensemble command set. Note + * that this is slightly tricky, as it means that we are not actually + * counting the number of namespace export actions, but it is the simplest + * way to go! + */ + + ensemblePtr->nsPtr->exportLookupEpoch++; + + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (cmdPtr->compileProc != NULL) { + ((Interp *)interp)->compileEpoch++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleMappingDict -- * * Set the mapping dictionary for a particular ensemble. @@ -5713,6 +5834,46 @@ Tcl_GetEnsembleSubcommandList( /* *---------------------------------------------------------------------- * + * Tcl_GetEnsembleParameterList -- + * + * Get the list of parameters associated with a particular ensemble. + * + * Results: + * Tcl result code (error if command token does not indicate an + * ensemble). The list of parameters is returned by updating the + * variable pointed to by the last parameter (NULL if there are + * no parameters). + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetEnsembleParameterList( + Tcl_Interp *interp, + Tcl_Command token, + Tcl_Obj **paramListPtr) +{ + Command *cmdPtr = (Command *) token; + EnsembleConfig *ensemblePtr; + + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_AppendResult(interp, "command is not an ensemble", NULL); + } + return TCL_ERROR; + } + + ensemblePtr = cmdPtr->objClientData; + *paramListPtr = ensemblePtr->parameterList; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetEnsembleMappingDict -- * * Get the command mapping dictionary associated with a particular @@ -6083,12 +6244,39 @@ NsEnsembleImplementationCmdNR( * names. */ int reparseCount = 0; /* Number of reparses. */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); + /* + * Must recheck objc, since numParameters might have changed. Cf. test + * namespace-53.9. + */ + + restartEnsembleParse: + if (objc < 2 + ensemblePtr->numParameters) { + /* + * We don't have a subcommand argument. Make error message. + */ + + Tcl_DString buf; /* Message being built */ + Tcl_Obj **elemPtrs; /* Parameter names */ + int len; /* Number of parameters to append */ + + Tcl_DStringInit(&buf); + if (ensemblePtr->parameterList == NULL) { + len = 0; + } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList, + &len, &elemPtrs) != TCL_OK) { + Tcl_Panic("List of ensemble parameters is not a list"); + } + for (; len>0; len--,elemPtrs++) { + Tcl_DStringAppend(&buf, Tcl_GetString(*elemPtrs), -1); + Tcl_DStringAppend(&buf, " ", -1); + } + Tcl_DStringAppend(&buf, "subcommand ?arg ...?", -1); + Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + return TCL_ERROR; } - restartEnsembleParse: if (ensemblePtr->nsPtr->flags & NS_DYING) { /* * Don't know how we got here, but make things give up quickly. @@ -6114,8 +6302,9 @@ NsEnsembleImplementationCmdNR( * part where we do the invocation of the subcommand. */ - if (objv[1]->typePtr == &tclEnsembleCmdType) { - EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.otherValuePtr; + if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ + EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] + ->internalRep.otherValuePtr; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && @@ -6136,7 +6325,7 @@ NsEnsembleImplementationCmdNR( */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(objv[1])); + TclGetString(objv[1 + ensemblePtr->numParameters])); if (hPtr != NULL) { char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); @@ -6146,7 +6335,8 @@ NsEnsembleImplementationCmdNR( * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], + ensemblePtr, fullName, prefixObj); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Could not map, no prefixing, go to unknown/error handling. @@ -6167,8 +6357,8 @@ NsEnsembleImplementationCmdNR( int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; - subcmdName = TclGetString(objv[1]); - stringLength = objv[1]->length; + subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]); + stringLength = objv[1 + ensemblePtr->numParameters]->length; for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -6214,7 +6404,8 @@ NsEnsembleImplementationCmdNR( * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], + ensemblePtr, fullName, prefixObj); } Tcl_IncrRefCount(prefixObj); @@ -6226,8 +6417,12 @@ NsEnsembleImplementationCmdNR( * number of arguments to this ensemble command), populating it and then * feeding it back through the main command-lookup engine. In theory, we * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, but we don't do - * that (the cacheing of the command object used should help with that.) + * have the namespace in which it is guaranteed to exist, + * + * ((Q: That's not true if the -map option is used, is it?)) + * + * but we don't do that (the cacheing of the command object used should + * help with that.) */ { @@ -6262,7 +6457,11 @@ NsEnsembleImplementationCmdNR( listRepPtr->elemCount = copyObjc; copyObjv = &listRepPtr->elements; memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(copyObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + memcpy(copyObjv+prefixObjc, objv+1, + sizeof(Tcl_Obj *) * ensemblePtr->numParameters); + memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters, + objv+ensemblePtr->numParameters+2, + sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2)); for (i=0; i < copyObjc; i++) { Tcl_IncrRefCount(copyObjv[i]); @@ -6272,20 +6471,25 @@ NsEnsembleImplementationCmdNR( /* * Record what arguments the script sent in so that things like - * Tcl_WrongNumArgs can give the correct error message. + * Tcl_WrongNumArgs can give the correct error message. Parameters + * count both as inserted and removed arguments. */ if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + iPtr->ensembleRewrite.numRemovedObjs = + 2 + ensemblePtr->numParameters; + iPtr->ensembleRewrite.numInsertedObjs = + prefixObjc + ensemblePtr->numParameters; TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } else { - register int ni = iPtr->ensembleRewrite.numInsertedObjs; - - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; + register int ni = 2 + ensemblePtr->numParameters + - iPtr->ensembleRewrite.numInsertedObjs; + /* Position in objv of new front of insertion + * relative to old one. */ + if (ni > 0) { + iPtr->ensembleRewrite.numRemovedObjs += ni; iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; } else { iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; @@ -6328,18 +6532,20 @@ NsEnsembleImplementationCmdNR( Tcl_ResetResult(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), + Tcl_AppendResult(interp, "unknown subcommand \"", + TclGetString(objv[1+ensemblePtr->numParameters]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } Tcl_AppendResult(interp, "unknown ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); + "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]), + "\": must be ", NULL); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); } else { @@ -6353,7 +6559,7 @@ NsEnsembleImplementationCmdNR( ensemblePtr->subcommandArrayPtr[i], NULL); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1]), NULL); + TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } @@ -6650,6 +6856,9 @@ DeleteEnsembleConfig( if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } + if (ensemblePtr->parameterList != NULL) { + Tcl_DecrRefCount(ensemblePtr->parameterList); + } if (ensemblePtr->subcommandDict != NULL) { Tcl_DecrRefCount(ensemblePtr->subcommandDict); } diff --git a/tests/namespace.test b/tests/namespace.test index a0035e6..bf2156d 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.73 2008/07/19 22:50:38 nijtmans Exp $ +# RCS: @(#) $Id: namespace.test,v 1.74 2008/09/28 22:17:40 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1700,7 +1700,7 @@ test namespace-45.1 {ensemble: introspection} { } namespace delete ns set result -} {-map {} -namespace ::ns -prefixes 1 -subcommands {} -unknown {}} +} {-map {} -namespace ::ns -parameters {} -prefixes 1 -subcommands {} -unknown {}} test namespace-45.2 {ensemble: introspection} { namespace eval ns { namespace export x @@ -1914,7 +1914,7 @@ test namespace-47.5 {ensemble: unknown handler} { lappend result [catch {foo bar} msg] $msg [namespace ensemble config foo] rename foo {} set result -} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}} +} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -parameters {} -prefixes 1 -subcommands {} -unknown bar}} test namespace-47.6 {ensemble: unknown handler} { namespace ensemble create -command foo -unknown bar proc bar {args} { @@ -1981,7 +1981,7 @@ test namespace-48.1 {ensembles and namespace import: unknown handler} { bar z 789 namespace delete foo set result -} {{-map {} -namespace ::foo -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789} +} {{-map {} -namespace ::foo -parameters {} -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789} test namespace-48.2 {ensembles and namespace import: exists} { namespace eval foo { namespace ensemble create -command ::foo::bar @@ -2635,6 +2635,221 @@ test namespace-52.12 {unknown: error case must not reset handler} -body { namespace delete foo } -result ok +# TIP 314 - ensembles with parameters + +test namespace-53.1 {ensembles: parameters} { + namespace eval ns { + namespace export x + proc x {para} {list 1 $para} + namespace ensemble create -parameters {para1} + } + list [info command ns] [ns bar x] [namespace delete ns] [info command ns] +} {ns {1 bar} {} {}} + +test namespace-53.2 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x + proc x {para} {list 1 $para} + namespace ensemble create + } +} -body { + namespace ensemble configure ns -parameters {para1} + rename ns foo + list [info command foo] [foo bar x] [namespace delete ns] [info command foo] +} -result {foo {1 bar} {} {}} + +test namespace-53.3 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {para} {list 1 $para} + proc x2 {para} {list 2 $para} + namespace ensemble create -parameters param1 + } +} -body { + set result [list [ns x2 x1] [ns x1 x2]] + lappend result [catch {ns x} msg] $msg + lappend result [catch {ns x x} msg] $msg + rename ns {} + lappend result [info command ns::x1] + namespace delete ns + lappend result [info command ns::x1] +} -result\ + {{1 x2} {2 x1}\ + 1 {wrong # args: should be "ns param1 subcommand ?arg ...?"}\ + 1 {unknown or ambiguous subcommand "x": must be x1, or x2}\ + ::ns::x1 {}} + +test namespace-53.4 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1 a2} {list 1 $a1 $a2} + proc x2 {a1 a2} {list 2 $a1 $a2} + proc x3 {a1 a2} {list 3 $a1 $a2} + namespace ensemble create + } +} -body { + set result {} + lappend result [ns x1 x2 x3] + namespace ensemble configure ns -parameters p1 + lappend result [ns x1 x2 x3] + namespace ensemble configure ns -parameters {p1 p2} + lappend result [ns x1 x2 x3] +} -cleanup { + namespace delete ns +} -result {{1 x2 x3} {2 x1 x3} {3 x1 x2}} + +test namespace-53.5 {ensembles: parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {para} {list 1 $para} + proc x2 {para} {list 2 $para} + proc x3 {para} {list 3 $para} + namespace ensemble create + } +} -body { + set result [list [catch {ns x x1} msg] $msg] + lappend result [catch {ns x1 x} msg] $msg + namespace ensemble configure ns -parameters p1 + lappend result [catch {ns x1 x} msg] $msg + lappend result [catch {ns x x1} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\ + 0 {1 x}\ + 1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\ + 0 {1 x}} + +test namespace-53.6 {ensembles: nested} -setup { + namespace eval ns { + namespace export x* + namespace eval x0 { + proc z {args} {list 0 $args} + namespace export z + namespace ensemble create + } + proc x1 {args} {list 1 $args} + proc x2 {args} {list 2 $args} + proc x3 {args} {list 3 $args} + namespace ensemble create -parameters p + } +} -body { + list [ns z x0] [ns z x1] [ns z x2] [ns z x3] +} -cleanup { + namespace delete ns +} -result {{0 {}} {1 z} {2 z} {3 z}} + +test namespace-53.7 {ensembles: parameters & wrong # args} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1 a2 a3 a4} {list x1 $a1 $a2 $a3 $a4} + namespace ensemble create -parameters p1 + } +} -body { + set result {} + lappend result [catch {ns} msg] $msg + lappend result [catch {ns x1} msg] $msg + lappend result [catch {ns x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1 x1} msg] $msg + lappend result [catch {ns x1 x1 x1 x1 x1} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\ + 1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\ + 0 {x1 x1 x1 x1 x1}} + +test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup { + namespace eval ns { + namespace export x* + proc x1 {a1} {list 1 $a1} + proc Magic {ensemble subcmd args} { + namespace ensemble configure $ensemble\ + -parameters [lrange p1 [llength [ + namespace ensemble configure $ensemble -parameters + ]] 0] + list + } + namespace ensemble create -unknown ::ns::Magic + } +} -body { + set result {} + lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x3} msg] $msg [namespace ensemble configure ns -parameters] +} -cleanup { + namespace delete ns +} -result\ + {0 {1 x2} {}\ + 0 {1 x2} p1\ + 1 {unknown or ambiguous subcommand "x2": must be x1} {}} + +test namespace-53.9 {ensemble: unknown handler changing -parameters,\ + thereby eating all args} -setup { + namespace eval ns { + namespace export x* + proc x1 {args} {list 1 $args} + proc Magic {ensemble subcmd args} { + namespace ensemble configure $ensemble\ + -parameters {p1 p2 p3 p4 p5} + list + } + namespace ensemble create -unknown ::ns::Magic + } +} -body { + set result {} + lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters] + lappend result [catch {ns a1 a2 a3 a4 a5 x1} msg] $msg [namespace ensemble configure ns -parameters] +} -cleanup { + namespace delete ns +} -result\ + {0 {1 x2} {}\ + 1 {wrong # args: should be "ns p1 p2 p3 p4 p5 subcommand ?arg ...?"} {p1 p2 p3 p4 p5}\ + 0 {1 {a1 a2 a3 a4 a5}} {p1 p2 p3 p4 p5}} + +test namespace-53.10 {ensembles: nested rewrite} -setup { + namespace eval ns { + namespace export x + namespace eval x { + proc z0 {} {list 0} + proc z1 {a1} {list 1 $a1} + proc z2 {a1 a2} {list 2 $a1 $a2} + proc z3 {a1 a2 a3} {list 3 $a1 $a2 $a3} + namespace export z* + namespace ensemble create + } + namespace ensemble create -parameters p + } +} -body { + set result {} + # In these cases, parsing the subensemble does not grab a new word. + lappend result [catch {ns z0 x} msg] $msg + lappend result [catch {ns z1 x} msg] $msg + lappend result [catch {ns z2 x} msg] $msg + lappend result [catch {ns z2 x v} msg] $msg + namespace ensemble configure ns::x -parameters q1 + # In these cases, parsing the subensemble grabs a new word. + lappend result [catch {ns v x z0} msg] $msg + lappend result [catch {ns v x z1} msg] $msg + lappend result [catch {ns v x z2} msg] $msg + lappend result [catch {ns v x z2 v2} msg] $msg +} -cleanup { + namespace delete ns +} -result\ + {0 0\ + 1 {wrong # args: should be "ns z1 x a1"}\ + 1 {wrong # args: should be "ns z2 x a1 a2"}\ + 1 {wrong # args: should be "ns z2 x a1 a2"}\ + 1 {wrong # args: should be "::ns::x::z0"}\ + 0 {1 v}\ + 1 {wrong # args: should be "ns v x z2 a2"}\ + 0 {2 v v2}} + # cleanup catch {rename cmd1 {}} catch {unset l} |