Implement TIP 314. [Patch 1901783]

1 files changed, 247 insertions, 38 deletions

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, &paramObj);
 	    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);
     }