summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-02-13 18:11:05 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-02-13 18:11:05 (GMT)
commit865200e0f391f7d31fcb7686023bbebf52b06067 (patch)
treeb953a07055fc0d11a2d1d735b830a26ef7f263b4 /generic/tclNamesp.c
parente41e7e0ccb2301f8565b998e12838088ecd4cef0 (diff)
downloadtcl-865200e0f391f7d31fcb7686023bbebf52b06067.zip
tcl-865200e0f391f7d31fcb7686023bbebf52b06067.tar.gz
tcl-865200e0f391f7d31fcb7686023bbebf52b06067.tar.bz2
Hive off the ensemble code into its own file.
Split the [switch] compiler for sanity's sake.
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c2899
1 files changed, 90 insertions, 2809 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index f8ee460..fbbab98 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.199 2010/01/03 20:29:11 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.200 2010/02/13 18:11:06 dkf Exp $
*/
#include "tclInt.h"
@@ -70,87 +70,6 @@ typedef struct ResolvedNsName {
} ResolvedNsName;
/*
- * The client data for an ensemble command. This consists of the table of
- * commands that are actually exported by the namespace, and an epoch counter
- * that, combined with the exportLookupEpoch field of the namespace structure,
- * defines whether the table contains valid data or will need to be recomputed
- * next time the ensemble command is called.
- */
-
-typedef struct EnsembleConfig {
- Namespace *nsPtr; /* The namspace backing this ensemble up. */
- Tcl_Command token; /* The token for the command that provides
- * ensemble support for the namespace, or NULL
- * if the command has been deleted (or never
- * existed; the global namespace never has an
- * ensemble command.) */
- int epoch; /* The epoch at which this ensemble's table of
- * exported commands is valid. */
- char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
- * consistent points, this will have the same
- * number of entries as there are entries in
- * the subcommandTable hash. */
- Tcl_HashTable subcommandTable;
- /* Hash table of ensemble subcommand names,
- * which are its keys so this also provides
- * the storage management for those subcommand
- * names. The contents of the entry values are
- * object version the prefix lists to use when
- * substituting for the command/subcommand to
- * build the ensemble implementation command.
- * Has to be stored here as well as in
- * subcommandDict because that field is NULL
- * when we are deriving the ensemble from the
- * namespace exports list. FUTURE WORK: use
- * object hash table here. */
- struct EnsembleConfig *next;/* The next ensemble in the linked list of
- * ensembles associated with a namespace. If
- * this field points to this ensemble, the
- * structure has already been unlinked from
- * all lists, and cannot be found by scanning
- * the list from the namespace's ensemble
- * field. */
- int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD
- * and ENSEMBLE_COMPILE. */
-
- /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
-
- Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
- * subcommands to their implementing command
- * prefixes, or NULL if we are to build the
- * map automatically from the namespace
- * exports. */
- Tcl_Obj *subcmdList; /* List of commands that this ensemble
- * actually provides, and whose implementation
- * will be built using the subcommandDict (if
- * present and defined) and by simple mapping
- * to the namespace otherwise. If NULL,
- * indicates that we are using the (dynamic)
- * list of currently exported commands. */
- Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
- * no match is found (according to the rule
- * defined by flag bit TCL_ENSEMBLE_PREFIX) or
- * NULL to use the default error-generating
- * behaviour. The script execution gets all
- * the arguments to the ensemble command
- * (including objv[0]) and will have the
- * results passed directly back to the caller
- * (including the error code) unless the code
- * is TCL_CONTINUE in which case the
- * 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
- * and on its way out. */
-
-/*
* Declarations for functions local to this file:
*/
@@ -160,9 +79,6 @@ static int DoImport(Tcl_Interp *interp,
const char *cmdName, const char *pattern,
Namespace *importNsPtr, int allowOverwrite);
static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr);
-static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
- EnsembleConfig *ensemblePtr, int objc,
- Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp,
@@ -188,8 +104,6 @@ static int NamespaceCurrentCmd(ClientData dummy,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int NamespaceEnsembleCmd(ClientData dummy,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
@@ -221,20 +135,6 @@ static int NamespaceUnknownCmd(ClientData dummy,
static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static int NsEnsembleImplementationCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static int NsEnsembleImplementationCmdNR(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
-static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
-static int NsEnsembleStringOrder(const void *strPtr1,
- const void *strPtr2);
-static void DeleteEnsembleConfig(ClientData clientData);
-static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
- EnsembleConfig *ensemblePtr,
- const char *subcmdName, Tcl_Obj *prefixObjPtr);
-static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
-static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
-static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static void UnlinkNsPath(Namespace *nsPtr);
static Tcl_NRPostProc NsEval_Callback;
@@ -253,21 +153,6 @@ static const Tcl_ObjType nsNameType = {
NULL, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
-
-/*
- * This structure defines a Tcl object type that contains a reference to an
- * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
- * to cache the mapping between the subcommand itself and the real command
- * that implements it.
- */
-
-const Tcl_ObjType tclEnsembleCmdType = {
- "ensembleCommand", /* the type's name */
- FreeEnsembleCmdRep, /* freeIntRepProc */
- DupEnsembleCmdRep, /* dupIntRepProc */
- StringOfEnsembleCmdRep, /* updateStringProc */
- NULL /* setFromAnyProc */
-};
/*
*----------------------------------------------------------------------
@@ -430,7 +315,7 @@ Tcl_PushCallFrame(
framePtr->clientData = NULL;
framePtr->localCachePtr = NULL;
framePtr->tailcallPtr = NULL;
-
+
/*
* Push the new call frame onto the interpreter's stack of procedure call
* frames making it the current frame.
@@ -556,7 +441,7 @@ void
TclPopStackFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
- CallFrame *freePtr = ((Interp *)interp)->framePtr;
+ CallFrame *freePtr = ((Interp *) interp)->framePtr;
Tcl_PopCallFrame(interp);
TclStackFree(interp, freePtr);
@@ -619,7 +504,7 @@ ErrorCodeRead(
const char *name2,
int flags)
{
- Interp *iPtr = (Interp *)interp;
+ Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
@@ -852,7 +737,7 @@ Tcl_CreateNamespace(
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(
- TclGetNamespaceChildTable((Tcl_Namespace *)parentPtr),
+ TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr),
simpleName, &newEntry);
Tcl_SetHashValue(entryPtr, nsPtr);
} else {
@@ -973,14 +858,14 @@ Tcl_DeleteNamespace(
entryPtr != NULL;) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (cmdPtr->nreProc == NRInterpCoroutine) {
- Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command)cmdPtr);
- entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
+ (Tcl_Command) cmdPtr);
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
} else {
entryPtr = entryPtr->nextPtr;
}
- }
-
-
+ }
+
/*
* If the namespace has associated ensemble commands, delete them first.
* This leaves the actual contents of the namespace alone (unless they are
@@ -1183,6 +1068,7 @@ TclTeardownNamespace(
}
if (nsPtr->commandPathSourceList != NULL) {
NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+
do {
if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) {
nsPathPtr->creatorNsPtr->cmdRefEpoch++;
@@ -1290,6 +1176,33 @@ NamespaceFree(
/*
*----------------------------------------------------------------------
*
+ * TclNsDecrRefCount --
+ *
+ * Drops a reference to a namespace and frees it if the namespace has
+ * been deleted and the last reference has just been dropped.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclNsDecrRefCount(
+ Namespace *nsPtr)
+{
+ nsPtr->refCount--;
+ if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
+ NamespaceFree(nsPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Export --
*
* Makes all the commands matching a pattern available to later be
@@ -1616,6 +1529,7 @@ Tcl_Import(
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
+
if (Tcl_StringMatch(cmdName, simplePattern) &&
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
allowOverwrite) == TCL_ERROR) {
@@ -1834,13 +1748,13 @@ Tcl_ForgetImport(
*/
if (TclMatchIsTrivial(simplePattern)) {
- Command *cmdPtr;
-
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
- if ((hPtr != NULL)
- && (cmdPtr = Tcl_GetHashValue(hPtr))
- && (cmdPtr->deleteProc == DeleteImportedCmd)) {
- Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ if (hPtr != NULL) {
+ Command *cmdPtr = Tcl_GetHashValue(hPtr);
+
+ if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+ }
}
return TCL_OK;
}
@@ -1970,7 +1884,7 @@ InvokeImportedNRCmd(
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
- ((Interp *)interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
@@ -2424,7 +2338,9 @@ Tcl_FindNamespace(
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
- } else if (flags & TCL_LEAVE_ERR_MSG) {
+ }
+
+ if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
@@ -2739,7 +2655,7 @@ TclResetShadowedCmdRefs(
* for a fresh compilation of every bytecode.
*/
- if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
+ if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){
nsPtr->resolverEpoch++;
}
}
@@ -2753,6 +2669,7 @@ TclResetShadowedCmdRefs(
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
+
trailPtr = (Namespace **) TclStackRealloc(interp,
trailPtr, newSize * sizeof(Namespace *));
trailSize = newSize;
@@ -2917,7 +2834,7 @@ TclNRNamespaceObjCmd(
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx
};
- int index, result;
+ int index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
@@ -2928,72 +2845,54 @@ TclNRNamespaceObjCmd(
* Return an index reflecting the particular subcommand.
*/
- result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
- "option", /*flags*/ 0, (int *) &index);
- if (result != TCL_OK) {
- return result;
+ if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", /*flags*/ 0,
+ (int *) &index) != TCL_OK) {
+ return TCL_ERROR;
}
switch (index) {
case NSChildrenIdx:
- result = NamespaceChildrenCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceChildrenCmd(clientData, interp, objc, objv);
case NSCodeIdx:
- result = NamespaceCodeCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceCodeCmd(clientData, interp, objc, objv);
case NSCurrentIdx:
- result = NamespaceCurrentCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceCurrentCmd(clientData, interp, objc, objv);
case NSDeleteIdx:
- result = NamespaceDeleteCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceDeleteCmd(clientData, interp, objc, objv);
case NSEnsembleIdx:
- result = NamespaceEnsembleCmd(clientData, interp, objc, objv);
- break;
+ return TclNamespaceEnsembleCmd(clientData, interp, objc, objv);
case NSEvalIdx:
- result = NamespaceEvalCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceEvalCmd(clientData, interp, objc, objv);
case NSExistsIdx:
- result = NamespaceExistsCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceExistsCmd(clientData, interp, objc, objv);
case NSExportIdx:
- result = NamespaceExportCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceExportCmd(clientData, interp, objc, objv);
case NSForgetIdx:
- result = NamespaceForgetCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceForgetCmd(clientData, interp, objc, objv);
case NSImportIdx:
- result = NamespaceImportCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceImportCmd(clientData, interp, objc, objv);
case NSInscopeIdx:
- result = NamespaceInscopeCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceInscopeCmd(clientData, interp, objc, objv);
case NSOriginIdx:
- result = NamespaceOriginCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceOriginCmd(clientData, interp, objc, objv);
case NSParentIdx:
- result = NamespaceParentCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceParentCmd(clientData, interp, objc, objv);
case NSPathIdx:
- result = NamespacePathCmd(clientData, interp, objc, objv);
- break;
+ return NamespacePathCmd(clientData, interp, objc, objv);
case NSQualifiersIdx:
- result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceQualifiersCmd(clientData, interp, objc, objv);
case NSTailIdx:
- result = NamespaceTailCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceTailCmd(clientData, interp, objc, objv);
case NSUpvarIdx:
- result = NamespaceUpvarCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceUpvarCmd(clientData, interp, objc, objv);
case NSUnknownIdx:
- result = NamespaceUnknownCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceUnknownCmd(clientData, interp, objc, objv);
case NSWhichIdx:
- result = NamespaceWhichCmd(clientData, interp, objc, objv);
- break;
+ return NamespaceWhichCmd(clientData, interp, objc, objv);
+ default:
+ Tcl_Panic("unhandled namespace subcommand");
}
- return result;
+ return TCL_ERROR;
}
/*
@@ -3320,7 +3219,7 @@ NamespaceDeleteCmd(
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
if ((namespacePtr == NULL)
- || (((Namespace *)namespacePtr)->flags & NS_KILLED)) {
+ || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[i]),
"\" in namespace delete command", NULL);
@@ -3379,7 +3278,7 @@ NamespaceEvalCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- CmdFrame* invoker;
+ CmdFrame *invoker;
int word;
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
@@ -3607,6 +3506,7 @@ NamespaceExportCmd(
*/
Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
+
result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr,
listPtr);
if (result != TCL_OK) {
@@ -4202,6 +4102,7 @@ UnlinkNsPath(
int i;
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
+
if (nsPathPtr->prevPtr != NULL) {
nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
}
@@ -4242,6 +4143,7 @@ TclInvalidateNsPath(
Namespace *nsPtr)
{
NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+
while (nsPathPtr != NULL) {
if (nsPathPtr->nsPtr != NULL) {
nsPathPtr->creatorNsPtr->cmdRefEpoch++;
@@ -4405,10 +4307,10 @@ Tcl_GetNamespaceUnknownHandler(
* exists. */
Tcl_Namespace *nsPtr) /* The namespace. */
{
- Namespace *currNsPtr = (Namespace *)nsPtr;
+ Namespace *currNsPtr = (Namespace *) nsPtr;
if (currNsPtr->unknownHandlerPtr == NULL &&
- currNsPtr == ((Interp *)interp)->globalNsPtr) {
+ currNsPtr == ((Interp *) interp)->globalNsPtr) {
/*
* Default handler for global namespace is "::unknown". For all other
* namespaces, it is NULL (which falls back on the global unknown
@@ -4449,7 +4351,7 @@ Tcl_SetNamespaceUnknownHandler(
Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
{
int lstlen = 0;
- Namespace *currNsPtr = (Namespace *)nsPtr;
+ Namespace *currNsPtr = (Namespace *) nsPtr;
/*
* Ensure that we check for errors *first* before we change anything.
@@ -4601,8 +4503,7 @@ NamespaceUpvarCmd(
const char *myName;
if (objc < 3 || !(objc & 1)) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "ns ?otherVar myVar ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "ns ?otherVar myVar ...?");
return TCL_ERROR;
}
@@ -4615,7 +4516,7 @@ NamespaceUpvarCmd(
for (; objc>0 ; objc-=2, objv+=2) {
/*
- * Locate the other variable
+ * Locate the other variable.
*/
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
@@ -4744,9 +4645,7 @@ FreeNsNameInternalRep(
register Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
- register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- objPtr->internalRep.twoPtrValue.ptr1;
- Namespace *nsPtr;
+ ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Decrement the reference count of the namespace. If there are no more
@@ -4755,18 +4654,13 @@ FreeNsNameInternalRep(
resNamePtr->refCount--;
if (resNamePtr->refCount == 0) {
-
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
* it.
*/
- nsPtr = resNamePtr->nsPtr;
- nsPtr->refCount--;
- if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
- NamespaceFree(nsPtr);
- }
+ TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree((char *) resNamePtr);
}
objPtr->typePtr = NULL;
@@ -4796,8 +4690,7 @@ DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- register ResolvedNsName *resNamePtr = (ResolvedNsName *)
- srcPtr->internalRep.twoPtrValue.ptr1;
+ ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
resNamePtr->refCount++;
@@ -4933,2618 +4826,6 @@ TclGetNamespaceChildTable(
/*
*----------------------------------------------------------------------
*
- * NamespaceEnsembleCmd --
- *
- * Invoked to implement the "namespace ensemble" command that creates and
- * manipulates ensembles built on top of namespaces. Handles the
- * following syntax:
- *
- * namespace ensemble name ?dictionary?
- *
- * Results:
- * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
- *
- * Side effects:
- * Creates the ensemble for the namespace if one did not previously
- * exist. Alternatively, alters the way that the ensemble's subcommand =>
- * implementation prefix is configured.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NamespaceEnsembleCmd(
- ClientData dummy,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Namespace *nsPtr;
- Tcl_Command token;
- static const char *const subcommands[] = {
- "configure", "create", "exists", NULL
- };
- enum EnsSubcmds {
- ENS_CONFIG, ENS_CREATE, ENS_EXISTS
- };
- static const char *const createOptions[] = {
- "-command", "-map", "-parameters", "-prefixes", "-subcommands",
- "-unknown", NULL
- };
- enum EnsCreateOpts {
- CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
- };
- static const char *const configOptions[] = {
- "-map", "-namespace", "-parameters", "-prefixes", "-subcommands",
- "-unknown", NULL
- };
- enum EnsConfigOpts {
- CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS,
- CONF_UNKNOWN
- };
- int index;
-
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "tried to manipulate ensemble of deleted namespace", NULL);
- }
- return TCL_ERROR;
- }
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum EnsSubcmds) index) {
- case ENS_CREATE: {
- const char *name;
- Tcl_DictSearch search;
- Tcl_Obj *listObj;
- int done, len, allocatedMapFlag = 0;
- /*
- * Defaults
- */
- Tcl_Obj *subcmdObj = NULL;
- Tcl_Obj *mapObj = NULL;
- int permitPrefix = 1;
- Tcl_Obj *unknownObj = NULL;
- Tcl_Obj *paramObj = NULL;
-
- /*
- * Check that we've got option-value pairs... [Bug 1558654]
- */
-
- if ((objc & 1) == 0) {
- Tcl_WrongNumArgs(interp, 3, objv, "?option value ...?");
- return TCL_ERROR;
- }
- objv += 3;
- objc -= 3;
-
- /*
- * Work out what name to use for the command to create. If supplied,
- * it is either fully specified or relative to the current namespace.
- * If not supplied, it is exactly the name of the current namespace.
- */
-
- name = nsPtr->fullName;
-
- /*
- * Parse the option list, applying type checks as we go. Note that we
- * are not incrementing any reference counts in the objects at this
- * stage, so the presence of an option multiple times won't cause any
- * memory leaks.
- */
-
- for (; objc>1 ; objc-=2,objv+=2) {
- if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
- 0, &index) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- switch ((enum EnsCreateOpts) index) {
- case CRT_CMD:
- name = TclGetString(objv[1]);
- continue;
- case CRT_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- 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;
-
- /*
- * Verify that the map is sensible.
- */
-
- if (Tcl_DictObjFirst(interp, objv[1], &search,
- &subcmdObj, &listObj, &done) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (done) {
- mapObj = NULL;
- continue;
- }
- do {
- Tcl_Obj **listv;
- const char *cmd;
-
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (len < 1) {
- Tcl_SetResult(interp,
- "ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- cmd = TclGetString(listv[0]);
- if (!(cmd[0] == ':' && cmd[1] == ':')) {
- Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
-
- if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
- }
- Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
- if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
- }
- Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
- }
- Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
- } while (!done);
-
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- mapObj = (patchedDict ? patchedDict : objv[1]);
- if (patchedDict) {
- allocatedMapFlag = 1;
- }
- continue;
- }
- case CRT_PREFIX:
- if (Tcl_GetBooleanFromObj(interp, objv[1],
- &permitPrefix) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- continue;
- case CRT_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- unknownObj = (len > 0 ? objv[1] : NULL);
- continue;
- }
- }
-
- /*
- * Create the ensemble. Note that this might delete another ensemble
- * linked to the same namespace, so we must be careful. However, we
- * should be OK because we only link the namespace into the list once
- * we've created it (and after any deletions have occurred.)
- */
-
- token = Tcl_CreateEnsemble(interp, name, NULL,
- (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
- 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
- * traces could have corrupted the pristine object that we started
- * with). [Snit test rename-1.5]
- */
-
- Tcl_ResetResult(interp);
- Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
- return TCL_OK;
- }
-
- case ENS_EXISTS:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
- Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
- return TCL_OK;
-
- case ENS_CONFIG:
- if (objc < 4 || (objc != 5 && objc & 1)) {
- Tcl_WrongNumArgs(interp, 3, objv,
- "cmdname ?-option value ...? ?arg ...?");
- return TCL_ERROR;
- }
- token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
- if (token == NULL) {
- return TCL_ERROR;
- }
-
- if (objc == 5) {
- Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
-
- if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum EnsConfigOpts) index) {
- case CONF_SUBCMDS:
- Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
- if (resultObj != NULL) {
- 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) {
- Tcl_SetObjResult(interp, resultObj);
- }
- break;
- case CONF_NAMESPACE: {
- Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
-
- Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName,
- TCL_VOLATILE);
- break;
- }
- case CONF_PREFIX: {
- int flags = 0; /* silence gcc 4 warning */
-
- Tcl_GetEnsembleFlags(NULL, token, &flags);
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
- break;
- }
- case CONF_UNKNOWN:
- Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
- if (resultObj != NULL) {
- Tcl_SetObjResult(interp, resultObj);
- }
- break;
- }
- return TCL_OK;
-
- } else if (objc == 4) {
- /*
- * Produce list of all information.
- */
-
- Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
- Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
- int flags = 0; /* silence gcc 4 warning */
-
- TclNewObj(resultObj);
-
- /* -map option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_MAP], -1));
- Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- /* -namespace option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
- Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
- Tcl_ListObjAppendElement(NULL, resultObj,
- 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));
- Tcl_GetEnsembleFlags(NULL, token, &flags);
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
-
- /* -subcommands option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
- Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- /* -unknown option */
- Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
- Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
- Tcl_ListObjAppendElement(NULL, resultObj,
- (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
-
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- } else {
- Tcl_DictSearch search;
- Tcl_Obj *listObj;
- int done, len, allocatedMapFlag = 0;
- 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;
-
- objv += 4;
- objc -= 4;
-
- /*
- * Parse the option list, applying type checks as we go. Note that
- * we are not incrementing any reference counts in the objects at
- * this stage, so the presence of an option multiple times won't
- * cause any memory leaks.
- */
-
- for (; objc>0 ; objc-=2,objv+=2) {
- if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
- "option", 0, &index) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- switch ((enum EnsConfigOpts) index) {
- case CONF_SUBCMDS:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- 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;
-
- /*
- * Verify that the map is sensible.
- */
-
- if (Tcl_DictObjFirst(interp, objv[1], &search,
- &subcmdObj, &listObj, &done) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (done) {
- mapObj = NULL;
- continue;
- }
- do {
- Tcl_Obj **listv;
- const char *cmd;
-
- if (TclListObjGetElements(interp, listObj, &len,
- &listv) != TCL_OK) {
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- if (len < 1) {
- Tcl_SetResult(interp,
- "ensemble subcommand implementations "
- "must be non-empty lists", TCL_STATIC);
- Tcl_DictObjDone(&search);
- if (patchedDict) {
- Tcl_DecrRefCount(patchedDict);
- }
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- cmd = TclGetString(listv[0]);
- if (!(cmd[0] == ':' && cmd[1] == ':')) {
- Tcl_Obj *newList = Tcl_NewListObj(len, listv);
- Tcl_Obj *newCmd =
- Tcl_NewStringObj(nsPtr->fullName, -1);
- if (nsPtr->parentPtr) {
- Tcl_AppendStringsToObj(newCmd, "::", NULL);
- }
- Tcl_AppendObjToObj(newCmd, listv[0]);
- Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
- if (patchedDict == NULL) {
- patchedDict = Tcl_DuplicateObj(objv[1]);
- }
- Tcl_DictObjPut(NULL, patchedDict, subcmdObj,
- newList);
- }
- Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
- } while (!done);
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- mapObj = (patchedDict ? patchedDict : objv[1]);
- if (patchedDict) {
- allocatedMapFlag = 1;
- }
- continue;
- }
- case CONF_NAMESPACE:
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- Tcl_AppendResult(interp, "option -namespace is read-only",
- NULL);
- return TCL_ERROR;
- case CONF_PREFIX:
- if (Tcl_GetBooleanFromObj(interp, objv[1],
- &permitPrefix) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- continue;
- case CONF_UNKNOWN:
- if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
- if (allocatedMapFlag) {
- Tcl_DecrRefCount(mapObj);
- }
- return TCL_ERROR;
- }
- unknownObj = (len > 0 ? objv[1] : NULL);
- continue;
- }
- }
-
- /*
- * Update the namespace now that we've finished the parsing stage.
- */
-
- flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
- : 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;
- }
-
- default:
- Tcl_Panic("unexpected ensemble command");
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateEnsemble --
- *
- * Create a simple ensemble attached to the given namespace.
- *
- * Results:
- * The token for the command created.
- *
- * Side effects:
- * The ensemble is created and marked for compilation.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-Tcl_CreateEnsemble(
- Tcl_Interp *interp,
- const char *name,
- Tcl_Namespace *namespacePtr,
- int flags)
-{
- Namespace *nsPtr = (Namespace *) namespacePtr;
- EnsembleConfig *ensemblePtr = (EnsembleConfig *)
- ckalloc(sizeof(EnsembleConfig));
- Tcl_Obj *nameObj = NULL;
-
- if (nsPtr == NULL) {
- nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- }
-
- /*
- * Make the name of the ensemble into a fully qualified name. This might
- * allocate a temporary object.
- */
-
- if (!(name[0] == ':' && name[1] == ':')) {
- nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
- if (nsPtr->parentPtr == NULL) {
- Tcl_AppendStringsToObj(nameObj, name, NULL);
- } else {
- Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
- }
- Tcl_IncrRefCount(nameObj);
- name = TclGetString(nameObj);
- }
-
- ensemblePtr->nsPtr = nsPtr;
- ensemblePtr->epoch = 0;
- Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
- ensemblePtr->subcommandArrayPtr = NULL;
- 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,
- ensemblePtr, DeleteEnsembleConfig);
- ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
- nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
-
- /*
- * 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!
- */
-
- nsPtr->exportLookupEpoch++;
-
- if (flags & ENSEMBLE_COMPILE) {
- ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
- }
-
- if (nameObj != NULL) {
- TclDecrRefCount(nameObj);
- }
- return ensemblePtr->token;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleSubcommandList --
- *
- * Set the subcommand list for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the subcommand list - if non-NULL - is not a list).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleSubcommandList(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *subcmdList)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldList;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (subcmdList != NULL) {
- int length;
-
- if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
- return TCL_ERROR;
- }
- if (length < 1) {
- subcmdList = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldList = ensemblePtr->subcmdList;
- ensemblePtr->subcmdList = subcmdList;
- if (subcmdList != NULL) {
- Tcl_IncrRefCount(subcmdList);
- }
- if (oldList != NULL) {
- TclDecrRefCount(oldList);
- }
-
- /*
- * 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_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.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the mapping - if non-NULL - is not a dict).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleMappingDict(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *mapDict)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldDict;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (mapDict != NULL) {
- int size, done;
- Tcl_DictSearch search;
- Tcl_Obj *valuePtr;
-
- if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
- return TCL_ERROR;
- }
-
- for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
- !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
- Tcl_Obj *cmdPtr;
- const char *bytes;
-
- if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) {
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
- bytes = TclGetString(cmdPtr);
- if (bytes[0] != ':' || bytes[1] != ':') {
- Tcl_AppendResult(interp,
- "ensemble target is not a fully-qualified command",
- NULL);
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
- }
-
- if (size < 1) {
- mapDict = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldDict = ensemblePtr->subcommandDict;
- ensemblePtr->subcommandDict = mapDict;
- if (mapDict != NULL) {
- Tcl_IncrRefCount(mapDict);
- }
- if (oldDict != NULL) {
- TclDecrRefCount(oldDict);
- }
-
- /*
- * 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_SetEnsembleUnknownHandler --
- *
- * Set the unknown handler for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an ensemble
- * or the unknown handler - if non-NULL - is not a list).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleUnknownHandler(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj *unknownList)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- Tcl_Obj *oldList;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
- if (unknownList != NULL) {
- int length;
-
- if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
- return TCL_ERROR;
- }
- if (length < 1) {
- unknownList = NULL;
- }
- }
-
- ensemblePtr = cmdPtr->objClientData;
- oldList = ensemblePtr->unknownHandler;
- ensemblePtr->unknownHandler = unknownList;
- if (unknownList != NULL) {
- Tcl_IncrRefCount(unknownList);
- }
- if (oldList != NULL) {
- TclDecrRefCount(oldList);
- }
-
- /*
- * 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++;
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetEnsembleFlags --
- *
- * Set the flags for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble).
- *
- * Side effects:
- * The ensemble is updated and marked for recompilation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_SetEnsembleFlags(
- Tcl_Interp *interp,
- Tcl_Command token,
- int flags)
-{
- Command *cmdPtr = (Command *) token;
- EnsembleConfig *ensemblePtr;
- int wasCompiled;
-
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
- Tcl_AppendResult(interp, "command is not an ensemble", NULL);
- return TCL_ERROR;
- }
-
- ensemblePtr = cmdPtr->objClientData;
- wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
-
- /*
- * This API refuses to set the ENS_DEAD flag...
- */
-
- ensemblePtr->flags &= ENS_DEAD;
- ensemblePtr->flags |= flags & ~ENS_DEAD;
-
- /*
- * 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++;
-
- /*
- * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
- * compiler function and bump the interpreter's compilation epoch so that
- * bytecode gets regenerated.
- */
-
- if (flags & ENSEMBLE_COMPILE) {
- if (!wasCompiled) {
- ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
- ((Interp *) interp)->compileEpoch++;
- }
- } else {
- if (wasCompiled) {
- ((Command*) ensemblePtr->token)->compileProc = NULL;
- ((Interp *) interp)->compileEpoch++;
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleSubcommandList --
- *
- * Get the list of subcommands associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The list of subcommands is returned by updating the
- * variable pointed to by the last parameter (NULL if this is to be
- * derived from the mapping dictionary or the associated namespace's
- * exported commands).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleSubcommandList(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **subcmdListPtr)
-{
- 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;
- *subcmdListPtr = ensemblePtr->subcmdList;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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
- * ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The mapping dict is returned by updating the variable
- * pointed to by the last parameter (NULL if none is installed).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleMappingDict(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **mapDictPtr)
-{
- 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;
- *mapDictPtr = ensemblePtr->subcommandDict;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleUnknownHandler --
- *
- * Get the unknown handler associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The unknown handler is returned by updating the variable
- * pointed to by the last parameter (NULL if no handler is installed).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleUnknownHandler(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Obj **unknownListPtr)
-{
- 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;
- *unknownListPtr = ensemblePtr->unknownHandler;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleFlags --
- *
- * Get the flags for a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). The flags are returned by updating the variable pointed to
- * by the last parameter.
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleFlags(
- Tcl_Interp *interp,
- Tcl_Command token,
- int *flagsPtr)
-{
- 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;
- *flagsPtr = ensemblePtr->flags;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetEnsembleNamespace --
- *
- * Get the namespace associated with a particular ensemble.
- *
- * Results:
- * Tcl result code (error if command token does not indicate an
- * ensemble). Namespace is returned by updating the variable pointed to
- * by the last parameter.
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetEnsembleNamespace(
- Tcl_Interp *interp,
- Tcl_Command token,
- Tcl_Namespace **namespacePtrPtr)
-{
- 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;
- *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FindEnsemble --
- *
- * Given a command name, get the ensemble token for it, allowing for
- * [namespace import]s. [Bug 1017022]
- *
- * Results:
- * The token for the ensemble command with the given name, or NULL if the
- * command either does not exist or is not an ensemble (when an error
- * message will be written into the interp if thats non-NULL).
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-Tcl_FindEnsemble(
- 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);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
- TclGetString(cmdNameObj), NULL);
- }
- return NULL;
- }
- }
-
- return (Tcl_Command) cmdPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_IsEnsemble --
- *
- * Simple test for ensemble-hood that takes into account imported
- * ensemble commands as well.
- *
- * Results:
- * Boolean value
- *
- * Side effects:
- * None
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_IsEnsemble(
- Tcl_Command token)
-{
- Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
- return 1;
- }
- cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
- return 0;
- }
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclMakeEnsemble --
- *
- * Create an ensemble from a table of implementation commands. The
- * ensemble will be subject to (limited) compilation if any of the
- * implementation commands are compilable.
- *
- * The 'name' parameter may be a single command name or a list if
- * creating an ensemble subcommand (see the binary implementation).
- *
- * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
- * top-level ensemble commands.
- *
- * Results:
- * Handle for the new ensemble, or NULL on failure.
- *
- * Side effects:
- * May advance the bytecode compilation epoch.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-TclMakeEnsemble(
- Tcl_Interp *interp,
- const char *name, /* The ensemble name (as explained above) */
- const EnsembleImplMap map[]) /* The subcommands to create */
-{
- Tcl_Command ensemble;
- Tcl_Namespace *ns;
- Tcl_DString buf;
- const char **nameParts = NULL;
- const char *cmdName = NULL;
- int i, nameCount = 0, ensembleFlags = 0;
-
- /*
- * Construct the path for the ensemble namespace and create it.
- */
-
- Tcl_DStringInit(&buf);
- if (name[0] == ':' && name[1] == ':') {
- /*
- * An absolute name, so use it directly.
- */
-
- cmdName = name;
- Tcl_DStringAppend(&buf, name, -1);
- ensembleFlags = TCL_ENSEMBLE_PREFIX;
- } else {
- /*
- * Not an absolute name, so do munging of it. Note that this treats a
- * multi-word list differently to a single word.
- */
-
- Tcl_DStringAppend(&buf, "::tcl", -1);
-
- if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
- Tcl_Panic("invalid ensemble name '%s'", name);
- }
-
- for (i = 0; i < nameCount; ++i) {
- Tcl_DStringAppend(&buf, "::", 2);
- Tcl_DStringAppend(&buf, nameParts[i], -1);
- }
- }
-
- ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
- TCL_CREATE_NS_IF_UNKNOWN);
- if (!ns) {
- Tcl_Panic("unable to find or create %s namespace!",
- Tcl_DStringValue(&buf));
- }
-
- /*
- * Create the named ensemble in the correct namespace
- */
-
- if (cmdName == NULL) {
- if (nameCount == 1) {
- ensembleFlags = TCL_ENSEMBLE_PREFIX;
- cmdName = Tcl_DStringValue(&buf) + 5;
- } else {
- ns = ns->parentPtr;
- cmdName = nameParts[nameCount - 1];
- }
- }
- ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
-
- /*
- * Create the ensemble mapping dictionary and the ensemble command procs.
- */
-
- if (ensemble != NULL) {
- Tcl_Obj *mapDict;
-
- Tcl_DStringAppend(&buf, "::", 2);
- TclNewObj(mapDict);
- for (i=0 ; map[i].name != NULL ; i++) {
- Tcl_Obj *fromObj, *toObj;
- Command *cmdPtr;
-
- fromObj = Tcl_NewStringObj(map[i].name, -1);
- TclNewStringObj(toObj, Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf));
- Tcl_AppendToObj(toObj, map[i].name, -1);
- Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
- if (map[i].proc || map[i].nreProc) {
- cmdPtr = (Command *)
- Tcl_NRCreateCommand(interp, TclGetString(toObj),
- map[i].proc, map[i].nreProc, map[i].clientData, NULL);
- cmdPtr->compileProc = map[i].compileProc;
- if (map[i].compileProc != NULL) {
- ensembleFlags |= ENSEMBLE_COMPILE;
- }
- }
- }
- Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
- if (ensembleFlags & ENSEMBLE_COMPILE) {
- Tcl_SetEnsembleFlags(interp, ensemble, ensembleFlags);
- }
- }
-
- Tcl_DStringFree(&buf);
- if (nameParts != NULL) {
- Tcl_Free((char *) nameParts);
- }
- return ensemble;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NsEnsembleImplementationCmd --
- *
- * Implements an ensemble of commands (being those exported by a
- * namespace other than the global namespace) as a command with the same
- * (short) name as the namespace in the parent namespace.
- *
- * Results:
- * A standard Tcl result code. Will be TCL_ERROR if the command is not an
- * unambiguous prefix of any command exported by the ensemble's
- * namespace.
- *
- * Side effects:
- * Depends on the command within the namespace that gets executed. If the
- * ensemble itself returns TCL_ERROR, a descriptive error message will be
- * placed in the interpreter's result.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NsEnsembleImplementationCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
- clientData, objc, objv);
-}
-
-static int
-NsEnsembleImplementationCmdNR(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- EnsembleConfig *ensemblePtr = clientData;
- /* The ensemble itself. */
- Tcl_Obj *prefixObj; /* An object containing the prefix words of
- * the command that implements the
- * subcommand. */
- Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
- * specified but not yet cached command
- * names. */
- int reparseCount = 0; /* Number of reparses. */
-
- /*
- * 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;
- }
-
- if (ensemblePtr->nsPtr->flags & NS_DYING) {
- /*
- * Don't know how we got here, but make things give up quickly.
- */
-
- if (!Tcl_InterpDeleted(interp)) {
- Tcl_AppendResult(interp,
- "ensemble activated for deleted namespace", NULL);
- }
- return TCL_ERROR;
- }
-
- /*
- * Determine if the table of subcommands is right. If so, we can just look
- * up in there and go straight to dispatch.
- */
-
- if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
- /*
- * Table of subcommands is still valid; therefore there might be a
- * valid cache of discovered information which we can reuse. Do the
- * check here, and if we're still valid, we can jump straight to the
- * part where we do the invocation of the subcommand.
- */
-
- if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
- EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
- ->internalRep.otherValuePtr;
-
- if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
- ensembleCmd->epoch == ensemblePtr->epoch &&
- ensembleCmd->token == ensemblePtr->token) {
- prefixObj = ensembleCmd->realPrefixObj;
- Tcl_IncrRefCount(prefixObj);
- goto runResultingSubcommand;
- }
- }
- } else {
- BuildEnsembleConfig(ensemblePtr);
- ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
- }
-
- /*
- * Look in the hashtable for the subcommand name; this is the fastest way
- * of all if there is no cache in operation.
- */
-
- hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
- TclGetString(objv[1 + ensemblePtr->numParameters]));
- if (hPtr != NULL) {
- char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
-
- prefixObj = Tcl_GetHashValue(hPtr);
-
- /*
- * Cache for later in the subcommand object.
- */
-
- 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.
- */
-
- goto unknownOrAmbiguousSubcommand;
- } else {
- /*
- * If we've not already confirmed the command with the hash as part of
- * building our export table, we need to scan the sorted array for
- * matches.
- */
-
- const char *subcmdName; /* Name of the subcommand, or unique prefix of
- * it (will be an error for a non-unique
- * prefix). */
- char *fullName = NULL; /* Full name of the subcommand. */
- int stringLength, i;
- int tableLength = ensemblePtr->subcommandTable.numEntries;
-
- 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],
- (unsigned) stringLength);
-
- if (cmp == 0) {
- if (fullName != NULL) {
- /*
- * Since there's never the exact-match case to worry about
- * (hash search filters this), getting here indicates that
- * our subcommand is an ambiguous prefix of (at least) two
- * exported subcommands, which is an error case.
- */
-
- goto unknownOrAmbiguousSubcommand;
- }
- fullName = ensemblePtr->subcommandArrayPtr[i];
- } else if (cmp < 0) {
- /*
- * Because we are searching a sorted table, we can now stop
- * searching because we have gone past anything that could
- * possibly match.
- */
-
- break;
- }
- }
- if (fullName == NULL) {
- /*
- * The subcommand is not a prefix of anything, so bail out!
- */
-
- goto unknownOrAmbiguousSubcommand;
- }
- hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
- if (hPtr == NULL) {
- Tcl_Panic("full name %s not found in supposedly synchronized hash",
- fullName);
- }
- prefixObj = Tcl_GetHashValue(hPtr);
-
- /*
- * Cache for later in the subcommand object.
- */
-
- MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters],
- ensemblePtr, fullName, prefixObj);
- }
-
- Tcl_IncrRefCount(prefixObj);
- runResultingSubcommand:
-
- /*
- * Do the real work of execution of the subcommand by building an array of
- * objects (note that this is potentially not the same length as the
- * 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,
- *
- * ((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.)
- */
-
- {
- Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
- * target command prefix. */
- Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
- * Will be freed by the dispatch engine. */
- int prefixObjc, copyObjc;
- Interp *iPtr = (Interp *) interp;
-
- /*
- * Get the prefix that we're rewriting to. To do this we need to
- * ensure that the internal representation of the list does not change
- * so that we can safely keep the internal representations of the
- * elements in the list.
- *
- * TODO: Use conventional list operations to make this code sane!
- */
-
- TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
-
- copyObjc = objc - 2 + prefixObjc;
- copyPtr = Tcl_NewListObj(copyObjc, NULL);
- if (copyObjc > 0) {
- register Tcl_Obj **copyObjv;
- /* Space used to construct the list of
- * arguments to pass to the command that
- * implements the ensemble subcommand. */
- register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
- register int i;
-
- listRepPtr->elemCount = copyObjc;
- copyObjv = &listRepPtr->elements;
- memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
- 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]);
- }
- }
- TclDecrRefCount(prefixObj);
-
- /*
- * Record what arguments the script sent in so that things like
- * Tcl_WrongNumArgs can give the correct error message. Parameters
- * count both as inserted and removed arguments.
- */
-
-#if 0
- if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) {
- TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- }
-#else
- if (iPtr->ensembleRewrite.sourceObjs == NULL) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs =
- 2 + ensemblePtr->numParameters;
- iPtr->ensembleRewrite.numInsertedObjs =
- prefixObjc + ensemblePtr->numParameters;
- TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
- NULL);
- } else {
- 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;
- }
- }
-#endif
-
- /*
- * Hand off to the target command.
- */
-
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
- return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
- }
-
- unknownOrAmbiguousSubcommand:
- /*
- * Have not been able to match the subcommand asked for with a real
- * subcommand that we export. See whether a handler has been registered
- * for dealing with this situation. Will only call (at most) once for any
- * particular ensemble invocation.
- */
-
- if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
- switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv,
- &prefixObj)) {
- case TCL_OK:
- goto runResultingSubcommand;
- case TCL_ERROR:
- return TCL_ERROR;
- case TCL_CONTINUE:
- goto restartEnsembleParse;
- }
- }
-
- /*
- * We cannot determine what subcommand to hand off to, so generate a
- * (standard) failure message. Note the one odd case compared with
- * standard ensemble-like command, which is where a namespace has no
- * exported commands at all...
- */
-
- Tcl_ResetResult(interp);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
- if (ensemblePtr->subcommandTable.numEntries == 0) {
- 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+ensemblePtr->numParameters]), NULL);
- return TCL_ERROR;
- }
- Tcl_AppendResult(interp, "unknown ",
- (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
- "subcommand \"", TclGetString(objv[1+ensemblePtr->numParameters]),
- "\": must be ", NULL);
- if (ensemblePtr->subcommandTable.numEntries == 1) {
- Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
- } else {
- int i;
-
- for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
- Tcl_AppendResult(interp,
- ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
- }
- Tcl_AppendResult(interp, "or ",
- ensemblePtr->subcommandArrayPtr[i], NULL);
- }
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
- TclGetString(objv[1+ensemblePtr->numParameters]), NULL);
- return TCL_ERROR;
-}
-
-int
-TclClearRootEnsemble(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- TclResetRewriteEnsemble(interp, 1);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitRewriteEnsemble --
- *
- * Applies a rewrite of arguments so that an ensemble subcommand will
- * report error messages correctly for the overall command.
- *
- * Results:
- * Whether this is the first rewrite applied, a value which must be
- * passed to TclResetRewriteEnsemble when undoing this command's
- * behaviour.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclInitRewriteEnsemble(
- Tcl_Interp *interp,
- int numRemoved,
- int numInserted,
- Tcl_Obj *const *objv)
-{
- Interp *iPtr = (Interp *) interp;
-
- int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
-
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
- iPtr->ensembleRewrite.numInsertedObjs = numInserted;
- } else {
- int numIns = iPtr->ensembleRewrite.numInsertedObjs;
-
- if (numIns < numRemoved) {
- iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
- iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
- } else {
- iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
- }
- }
- return isRootEnsemble;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclResetRewriteEnsemble --
- *
- * Removes any rewrites applied to support proper reporting of error
- * messages used in ensembles. Should be paired with
- * TclInitRewriteEnsemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclResetRewriteEnsemble(
- Tcl_Interp *interp,
- int isRootEnsemble)
-{
- Interp *iPtr = (Interp *) interp;
-
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * EnsmebleUnknownCallback --
- *
- * Helper for the ensemble engine that handles the procesing of unknown
- * callbacks. See the user documentation of the ensemble unknown handler
- * for details; this function is only ever called when such a function is
- * defined, and is only ever called once per ensemble dispatch (i.e. if a
- * reparse still fails, this isn't called again).
- *
- * Results:
- * TCL_OK - *prefixObjPtr contains the command words to dispatch
- * to.
- * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
- * TCL_ERROR - Something went wrong! Error message in interpreter.
- *
- * Side effects:
- * Calls the Tcl interpreter, so arbitrary.
- *
- * ----------------------------------------------------------------------
- */
-
-static inline int
-EnsembleUnknownCallback(
- Tcl_Interp *interp,
- EnsembleConfig *ensemblePtr,
- int objc,
- Tcl_Obj *const objv[],
- Tcl_Obj **prefixObjPtr)
-{
- int paramc, i, result, prefixObjc;
- Tcl_Obj **paramv, *unknownCmd, *ensObj;
- char buf[TCL_INTEGER_SPACE];
-
- /*
- * Create the unknown command callback to determine what to do.
- */
-
- unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
- TclNewObj(ensObj);
- Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
- Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
- for (i=1 ; i<objc ; i++) {
- Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
- }
- TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
- Tcl_IncrRefCount(unknownCmd);
-
- /*
- * Now call the unknown handler. (We don't bother NRE-enabling this; deep
- * recursing through unknown handlers is horribly perverse.) Note that it
- * is always an error for an unknown handler to delete its ensemble; don't
- * do that!
- */
-
- Tcl_Preserve(ensemblePtr);
- ((Interp *)interp)->evalFlags |= TCL_EVAL_REDIRECT;
- result = Tcl_EvalObjv(interp, paramc, paramv, 0);
- if ((result == TCL_OK) && (ensemblePtr->flags & ENS_DEAD)) {
- Tcl_SetResult(interp,
- "unknown subcommand handler deleted its ensemble",
- TCL_STATIC);
- result = TCL_ERROR;
- }
- Tcl_Release(ensemblePtr);
-
- /*
- * If we succeeded, we should either have a list of words that form the
- * command to be executed, or an empty list. In the empty-list case, the
- * ensemble is believed to be updated so we should ask the ensemble engine
- * to reparse the original command.
- */
-
- if (result == TCL_OK) {
- *prefixObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(*prefixObjPtr);
- TclDecrRefCount(unknownCmd);
- Tcl_ResetResult(interp);
-
- /*
- * Namespace is still there. Check if the result is a valid list. If
- * it is, and it is non-empty, that list is what we are using as our
- * replacement.
- */
-
- if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
- TclDecrRefCount(*prefixObjPtr);
- Tcl_AddErrorInfo(interp, "\n while parsing result of "
- "ensemble unknown subcommand handler");
- return TCL_ERROR;
- }
- if (prefixObjc > 0) {
- return TCL_OK;
- }
-
- /*
- * Namespace alive & empty result => reparse.
- */
-
- TclDecrRefCount(*prefixObjPtr);
- return TCL_CONTINUE;
- }
-
- /*
- * Oh no! An exceptional result. Convert to an error.
- */
-
- if (!Tcl_InterpDeleted(interp)) {
- if (result != TCL_ERROR) {
- Tcl_ResetResult(interp);
- Tcl_SetResult(interp,
- "unknown subcommand handler returned bad code: ",
- TCL_STATIC);
- switch (result) {
- case TCL_RETURN:
- Tcl_AppendResult(interp, "return", NULL);
- break;
- case TCL_BREAK:
- Tcl_AppendResult(interp, "break", NULL);
- break;
- case TCL_CONTINUE:
- Tcl_AppendResult(interp, "continue", NULL);
- break;
- default:
- sprintf(buf, "%d", result);
- Tcl_AppendResult(interp, buf, NULL);
- }
- Tcl_AddErrorInfo(interp, "\n result of "
- "ensemble unknown subcommand handler: ");
- Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
- } else {
- Tcl_AddErrorInfo(interp,
- "\n (ensemble unknown subcommand handler)");
- }
- }
- TclDecrRefCount(unknownCmd);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MakeCachedEnsembleCommand --
- *
- * Cache what we've computed so far; it's not nice to repeatedly copy
- * strings about. Note that to do this, we start by deleting any old
- * representation that there was (though if it was an out of date
- * ensemble rep, we can skip some of the deallocation process.)
- *
- * Results:
- * None
- *
- * Side effects:
- * Alters the internal representation of the first object parameter.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MakeCachedEnsembleCommand(
- Tcl_Obj *objPtr,
- EnsembleConfig *ensemblePtr,
- const char *subcommandName,
- Tcl_Obj *prefixObjPtr)
-{
- register EnsembleCmdRep *ensembleCmd;
- int length;
-
- if (objPtr->typePtr == &tclEnsembleCmdType) {
- ensembleCmd = objPtr->internalRep.otherValuePtr;
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- ensembleCmd->nsPtr->refCount--;
- if ((ensembleCmd->nsPtr->refCount == 0)
- && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
- NamespaceFree(ensembleCmd->nsPtr);
- }
- ckfree(ensembleCmd->fullSubcmdName);
- } else {
- /*
- * Kill the old internal rep, and replace it with a brand new one of
- * our own.
- */
-
- TclFreeIntRep(objPtr);
- ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.otherValuePtr = ensembleCmd;
- objPtr->typePtr = &tclEnsembleCmdType;
- }
-
- /*
- * Populate the internal rep.
- */
-
- ensembleCmd->nsPtr = ensemblePtr->nsPtr;
- ensembleCmd->epoch = ensemblePtr->epoch;
- ensembleCmd->token = ensemblePtr->token;
- ensemblePtr->nsPtr->refCount++;
- ensembleCmd->realPrefixObj = prefixObjPtr;
- length = strlen(subcommandName)+1;
- ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
- memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
- Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DeleteEnsembleConfig --
- *
- * Destroys the data structure used to represent an ensemble. This is
- * called when the ensemble's command is deleted (which happens
- * automatically if the ensemble's namespace is deleted.) Maintainers
- * should note that ensembles should be deleted by deleting their
- * commands.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is (eventually) deallocated.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DeleteEnsembleConfig(
- ClientData clientData)
-{
- EnsembleConfig *ensemblePtr = clientData;
- Namespace *nsPtr = ensemblePtr->nsPtr;
- Tcl_HashSearch search;
- Tcl_HashEntry *hEnt;
-
- /*
- * Unlink from the ensemble chain if it has not been marked as having been
- * done already.
- */
-
- if (ensemblePtr->next != ensemblePtr) {
- EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
- if (ensPtr == ensemblePtr) {
- nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
- } else {
- while (ensPtr != NULL) {
- if (ensPtr->next == ensemblePtr) {
- ensPtr->next = ensemblePtr->next;
- break;
- }
- ensPtr = ensPtr->next;
- }
- }
- }
-
- /*
- * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
- * whether disaster happened anyway.
- */
-
- ensemblePtr->flags |= ENS_DEAD;
-
- /*
- * Kill the pointer-containing fields.
- */
-
- if (ensemblePtr->subcommandTable.numEntries != 0) {
- ckfree((char *) ensemblePtr->subcommandArrayPtr);
- }
- hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
- while (hEnt != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt);
-
- Tcl_DecrRefCount(prefixObj);
- hEnt = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
- if (ensemblePtr->subcmdList != NULL) {
- Tcl_DecrRefCount(ensemblePtr->subcmdList);
- }
- if (ensemblePtr->parameterList != NULL) {
- Tcl_DecrRefCount(ensemblePtr->parameterList);
- }
- if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DecrRefCount(ensemblePtr->subcommandDict);
- }
- if (ensemblePtr->unknownHandler != NULL) {
- Tcl_DecrRefCount(ensemblePtr->unknownHandler);
- }
-
- /*
- * Arrange for the structure to be reclaimed. Note that this is complex
- * because we have to make sure that we can react sensibly when an
- * ensemble is deleted during the process of initialising the ensemble
- * (especially the unknown callback.)
- */
-
- Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * BuildEnsembleConfig --
- *
- * Create the internal data structures that describe how an ensemble
- * looks, being a hash mapping from the full command name to the Tcl list
- * that describes the implementation prefix words, and a sorted array of
- * all the full command names to allow for reasonably efficient
- * unambiguous prefix handling.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Reallocates and rebuilds the hash table and array stored at the
- * ensemblePtr argument. For large ensembles or large namespaces, this is
- * a potentially expensive operation.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-BuildEnsembleConfig(
- EnsembleConfig *ensemblePtr)
-{
- Tcl_HashSearch search; /* Used for scanning the set of commands in
- * the namespace that backs up this
- * ensemble. */
- int i, j, isNew;
- Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
- Tcl_HashEntry *hPtr;
-
- if (hash->numEntries != 0) {
- /*
- * Remove pre-existing table.
- */
-
- Tcl_HashSearch search;
-
- ckfree((char *) ensemblePtr->subcommandArrayPtr);
- hPtr = Tcl_FirstHashEntry(hash, &search);
- while (hPtr != NULL) {
- Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(prefixObj);
- hPtr = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(hash);
- Tcl_InitHashTable(hash, TCL_STRING_KEYS);
- }
-
- /*
- * See if we've got an export list. If so, we will only export exactly
- * those commands, which may be either implemented by the prefix in the
- * subcommandDict or mapped directly onto the namespace's commands.
- */
-
- if (ensemblePtr->subcmdList != NULL) {
- Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
- int subcmdc;
-
- TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
- &subcmdv);
- for (i=0 ; i<subcmdc ; i++) {
- const char *name = TclGetString(subcmdv[i]);
-
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
-
- /*
- * Skip non-unique cases.
- */
-
- if (!isNew) {
- continue;
- }
-
- /*
- * Look in our dictionary (if present) for the command.
- */
-
- if (ensemblePtr->subcommandDict != NULL) {
- Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
- &target);
- if (target != NULL) {
- Tcl_SetHashValue(hPtr, target);
- Tcl_IncrRefCount(target);
- continue;
- }
- }
-
- /*
- * Not there, so map onto the namespace. Note in this case that we
- * do not guarantee that the command is actually there; that is
- * the programmer's responsibility (or [::unknown] of course).
- */
-
- cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
- if (ensemblePtr->nsPtr->parentPtr != NULL) {
- Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
- } else {
- Tcl_AppendStringsToObj(cmdObj, name, NULL);
- }
- cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
- Tcl_SetHashValue(hPtr, cmdPrefixObj);
- Tcl_IncrRefCount(cmdPrefixObj);
- }
- } else if (ensemblePtr->subcommandDict != NULL) {
- /*
- * No subcmd list, but we do have a mapping dictionary so we should
- * use the keys of that. Convert the dictionary's contents into the
- * form required for the ensemble's internal hashtable.
- */
-
- Tcl_DictSearch dictSearch;
- Tcl_Obj *keyObj, *valueObj;
- int done;
-
- Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
- &keyObj, &valueObj, &done);
- while (!done) {
- const char *name = TclGetString(keyObj);
-
- hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
- Tcl_SetHashValue(hPtr, valueObj);
- Tcl_IncrRefCount(valueObj);
- Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
- }
- } else {
- /*
- * Discover what commands are actually exported by the namespace.
- * What we have is an array of patterns and a hash table whose keys
- * are the command names exported by the namespace (the contents do
- * not matter here.) We must find out what commands are actually
- * exported by filtering each command in the namespace against each of
- * the patterns in the export list. Note that we use an intermediate
- * hash table to make memory management easier, and because that makes
- * exact matching far easier too.
- *
- * Suggestion for future enhancement: compute the unique prefixes and
- * place them in the hash too, which should make for even faster
- * matching.
- */
-
- hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
- for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
- char *nsCmdName = /* Name of command in namespace. */
- Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
-
- for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
- if (Tcl_StringMatch(nsCmdName,
- ensemblePtr->nsPtr->exportArrayPtr[i])) {
- hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
-
- /*
- * Remember, hash entries have a full reference to the
- * substituted part of the command (as a list) as their
- * content!
- */
-
- if (isNew) {
- Tcl_Obj *cmdObj, *cmdPrefixObj;
-
- TclNewObj(cmdObj);
- Tcl_AppendStringsToObj(cmdObj,
- ensemblePtr->nsPtr->fullName,
- (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
- nsCmdName, NULL);
- cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
- Tcl_SetHashValue(hPtr, cmdPrefixObj);
- Tcl_IncrRefCount(cmdPrefixObj);
- }
- break;
- }
- }
- }
- }
-
- if (hash->numEntries == 0) {
- ensemblePtr->subcommandArrayPtr = NULL;
- return;
- }
-
- /*
- * Create a sorted array of all subcommands in the ensemble; hash tables
- * are all very well for a quick look for an exact match, but they can't
- * determine things like whether a string is a prefix of another (not
- * without lots of preparation anyway) and they're no good for when we're
- * generating the error message either.
- *
- * We do this by filling an array with the names (we use the hash keys
- * directly to save a copy, since any time we change the array we change
- * the hash too, and vice versa) and running quicksort over the array.
- */
-
- ensemblePtr->subcommandArrayPtr = (char **)
- ckalloc(sizeof(char *) * hash->numEntries);
-
- /*
- * Fill array from both ends as this makes us less likely to end up with
- * performance problems in qsort(), which is good. Note that doing this
- * makes this code much more opaque, but the naive alternatve:
- *
- * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
- * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
- * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
- * }
- *
- * can produce long runs of precisely ordered table entries when the
- * commands in the namespace are declared in a sorted fashion (an ordering
- * some people like) and the hashing functions (or the command names
- * themselves) are fairly unfortunate. By filling from both ends, it
- * requires active malice (and probably a debugger) to get qsort() to have
- * awful runtime behaviour.
- */
-
- i = 0;
- j = hash->numEntries;
- hPtr = Tcl_FirstHashEntry(hash, &search);
- while (hPtr != NULL) {
- ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
- hPtr = Tcl_NextHashEntry(&search);
- if (hPtr == NULL) {
- break;
- }
- ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
- hPtr = Tcl_NextHashEntry(&search);
- }
- if (hash->numEntries > 1) {
- qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries,
- sizeof(char *), NsEnsembleStringOrder);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NsEnsembleStringOrder --
- *
- * Helper function to compare two pointers to two strings for use with
- * qsort().
- *
- * Results:
- * -1 if the first string is smaller, 1 if the second string is smaller,
- * and 0 if they are equal.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-NsEnsembleStringOrder(
- const void *strPtr1,
- const void *strPtr2)
-{
- return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeEnsembleCmdRep --
- *
- * Destroys the internal representation of a Tcl_Obj that has been
- * holding information about a command in an ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is deallocated. If this held the last reference to a
- * namespace's main structure, that main structure will also be
- * destroyed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeEnsembleCmdRep(
- Tcl_Obj *objPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
-
- Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
- ckfree(ensembleCmd->fullSubcmdName);
- ensembleCmd->nsPtr->refCount--;
- if ((ensembleCmd->nsPtr->refCount == 0)
- && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
- NamespaceFree(ensembleCmd->nsPtr);
- }
- ckfree((char *) ensembleCmd);
- objPtr->typePtr = NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupEnsembleCmdRep --
- *
- * Makes one Tcl_Obj into a copy of another that is a subcommand of an
- * ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is allocated, and the namespace that the ensemble is built on
- * top of gains another reference.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupEnsembleCmdRep(
- Tcl_Obj *objPtr,
- Tcl_Obj *copyPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
- EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
- ckalloc(sizeof(EnsembleCmdRep));
- int length = strlen(ensembleCmd->fullSubcmdName);
-
- copyPtr->typePtr = &tclEnsembleCmdType;
- copyPtr->internalRep.otherValuePtr = ensembleCopy;
- ensembleCopy->nsPtr = ensembleCmd->nsPtr;
- ensembleCopy->epoch = ensembleCmd->epoch;
- ensembleCopy->token = ensembleCmd->token;
- ensembleCopy->nsPtr->refCount++;
- ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
- Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
- ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
- memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
- (unsigned) length+1);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * StringOfEnsembleCmdRep --
- *
- * Creates a string representation of a Tcl_Obj that holds a subcommand
- * of an ensemble.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object gains a string (UTF-8) representation.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-StringOfEnsembleCmdRep(
- Tcl_Obj *objPtr)
-{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
- int length = strlen(ensembleCmd->fullSubcmdName);
-
- objPtr->length = length;
- objPtr->bytes = ckalloc((unsigned) length+1);
- memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_LogCommandInfo --
*
* This function is invoked after an error occurs in an interpreter. It