diff options
Diffstat (limited to 'itcl/itcl/generic/itcl_ensemble.c')
| -rw-r--r-- | itcl/itcl/generic/itcl_ensemble.c | 2248 |
1 files changed, 2248 insertions, 0 deletions
diff --git a/itcl/itcl/generic/itcl_ensemble.c b/itcl/itcl/generic/itcl_ensemble.c new file mode 100644 index 00000000000..60ba06ebab7 --- /dev/null +++ b/itcl/itcl/generic/itcl_ensemble.c @@ -0,0 +1,2248 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tcl] + * DESCRIPTION: Object-Oriented Extensions to Tcl + * + * [incr Tcl] provides object-oriented extensions to Tcl, much as + * C++ provides object-oriented extensions to C. It provides a means + * of encapsulating related procedures together with their shared data + * in a local namespace that is hidden from the outside world. It + * promotes code re-use through inheritance. More than anything else, + * it encourages better organization of Tcl applications through the + * object-oriented paradigm, leading to code that is easier to + * understand and maintain. + * + * This part handles ensembles, which support compound commands in Tcl. + * The usual "info" command is an ensemble with parts like "info body" + * and "info globals". Extension developers can extend commands like + * "info" by adding their own parts to the ensemble. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id$ + * ======================================================================== + * Copyright (c) 1993-1998 Lucent Technologies, Inc. + * ------------------------------------------------------------------------ + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ +#include "itclInt.h" + +/* + * Data used to represent an ensemble: + */ +struct Ensemble; +typedef struct EnsemblePart { + char *name; /* name of this part */ + int minChars; /* chars needed to uniquely identify part */ + Command *cmdPtr; /* command handling this part */ + char *usage; /* usage string describing syntax */ + struct Ensemble* ensemble; /* ensemble containing this part */ +} EnsemblePart; + +/* + * Data used to represent an ensemble: + */ +typedef struct Ensemble { + Tcl_Interp *interp; /* interpreter containing this ensemble */ + EnsemblePart **parts; /* list of parts in this ensemble */ + int numParts; /* number of parts in part list */ + int maxParts; /* current size of parts list */ + Tcl_Command cmd; /* command representing this ensemble */ + EnsemblePart* parent; /* parent part for sub-ensembles + * NULL => toplevel ensemble */ +} Ensemble; + +/* + * Data shared by ensemble access commands and ensemble parser: + */ +typedef struct EnsembleParser { + Tcl_Interp* master; /* master interp containing ensembles */ + Tcl_Interp* parser; /* slave interp for parsing */ + Ensemble* ensData; /* add parts to this ensemble */ +} EnsembleParser; + +/* + * Declarations for local procedures to this file: + */ +static void FreeEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void UpdateStringOfEnsInvoc _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetEnsInvocFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +/* + * This structure defines a Tcl object type that takes the + * place of a part name during ensemble invocations. When an + * error occurs and the caller tries to print objv[0], it will + * get a string that contains a complete path to the ensemble + * part. + */ +Tcl_ObjType itclEnsInvocType = { + "ensembleInvoc", /* name */ + FreeEnsInvocInternalRep, /* freeIntRepProc */ + DupEnsInvocInternalRep, /* dupIntRepProc */ + UpdateStringOfEnsInvoc, /* updateStringProc */ + SetEnsInvocFromAny /* setFromAnyProc */ +}; + +/* + * Boolean flag indicating whether or not the "ensemble" object + * type has been registered with the Tcl compiler. + */ +static int ensInitialized = 0; + +/* + * Forward declarations for the procedures used in this file. + */ +static void GetEnsembleUsage _ANSI_ARGS_((Ensemble *ensData, + Tcl_Obj *objPtr)); + +static void GetEnsemblePartUsage _ANSI_ARGS_((EnsemblePart *ensPart, + Tcl_Obj *objPtr)); + +static int CreateEnsemble _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *parentEnsData, char *ensName)); + +static int AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble* ensData, char* partName, char* usageInfo, + Tcl_ObjCmdProc *objProc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc, EnsemblePart **rVal)); + +static void DeleteEnsemble _ANSI_ARGS_((ClientData clientData)); + +static int FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp, char **nameArgv, + int nameArgc, Ensemble** ensDataPtr)); + +static int CreateEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *ensData, char* partName, EnsemblePart **ensPartPtr)); + +static void DeleteEnsemblePart _ANSI_ARGS_((EnsemblePart *ensPart)); + +static int FindEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, + Ensemble *ensData, char* partName, EnsemblePart **rensPart)); + +static int FindEnsemblePartIndex _ANSI_ARGS_((Ensemble *ensData, + char *partName, int *posPtr)); + +static void ComputeMinChars _ANSI_ARGS_((Ensemble *ensData, int pos)); + +static int HandleEnsemble _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static EnsembleParser* GetEnsembleParser _ANSI_ARGS_((Tcl_Interp *interp)); + +static void DeleteEnsParser _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp)); + + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleInit -- + * + * Called when any interpreter is created to make sure that + * things are properly set up for ensembles. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * On the first call, the "ensemble" object type is registered + * with the Tcl compiler. If an error is encountered, an error + * is left as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleInit(interp) + Tcl_Interp *interp; /* interpreter being initialized */ +{ + if (!ensInitialized) { + Tcl_RegisterObjType(&itclEnsInvocType); + ensInitialized = 1; + } + + Tcl_CreateObjCommand(interp, "::itcl::ensemble", + Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. The ensemble name is a space- + * separated list. The first word in the list is the command + * name for the top-level ensemble. Other names do not have + * commands associated with them; they are merely sub-ensembles + * within the ensemble. So a name like "a::b::foo bar baz" + * represents an ensemble command called "foo" in the namespace + * "a::b" that has a sub-ensemble "bar", that has a sub-ensemble + * "baz". + * + * If the name is a single word, then this procedure creates + * a top-level ensemble and installs an access command for it. + * If a command already exists with that name, it is deleted. + * + * If the name has more than one word, then the leading words + * are treated as a path name for an existing ensemble. The + * last word is treated as the name for a new sub-ensemble. + * If an part already exists with that name, it is an error. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_CreateEnsemble(interp, ensName) + Tcl_Interp *interp; /* interpreter to be updated */ + char* ensName; /* name of the new ensemble */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *parentEnsData; + Tcl_DString buffer; + + /* + * Split the ensemble name into its path components. + */ + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensCreateFail; + } + if (nameArgc < 1) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", ensName, "\"", + (char*)NULL); + goto ensCreateFail; + } + + /* + * If there is more than one path component, then follow + * the path down to the last component, to find the containing + * ensemble. + */ + parentEnsData = NULL; + if (nameArgc > 1) { + if (FindEnsemble(interp, nameArgv, nameArgc-1, &parentEnsData) + != TCL_OK) { + goto ensCreateFail; + } + + if (parentEnsData == NULL) { + char *pname = Tcl_Merge(nameArgc-1, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensCreateFail; + } + } + + /* + * Create the ensemble. + */ + if (CreateEnsemble(interp, parentEnsData, nameArgv[nameArgc-1]) + != TCL_OK) { + goto ensCreateFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensCreateFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "\n (while creating ensemble \"", -1); + Tcl_DStringAppend(&buffer, ensName, -1); + Tcl_DStringAppend(&buffer, "\")", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); + Tcl_DStringFree(&buffer); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_AddEnsemblePart -- + * + * Adds a part to an ensemble which has been created by + * Itcl_CreateEnsemble. Ensembles are addressed by name, as + * described in Itcl_CreateEnsemble. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_AddEnsemblePart(interp, ensName, partName, usageInfo, + objProc, clientData, deleteProc) + + Tcl_Interp *interp; /* interpreter to be updated */ + char* ensName; /* ensemble containing this part */ + char* partName; /* name of the new part */ + char* usageInfo; /* usage info for argument list */ + Tcl_ObjCmdProc *objProc; /* handling procedure for part */ + ClientData clientData; /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + Tcl_DString buffer; + + /* + * Parse the ensemble name and look for a containing ensemble. + */ + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensPartFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensPartFail; + } + + if (ensData == NULL) { + char *pname = Tcl_Merge(nameArgc, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + goto ensPartFail; + } + + /* + * Install the new part into the part list. + */ + if (AddEnsemblePart(interp, ensData, partName, usageInfo, + objProc, clientData, deleteProc, &ensPart) != TCL_OK) { + goto ensPartFail; + } + + ckfree((char*)nameArgv); + return TCL_OK; + +ensPartFail: + if (nameArgv) { + ckfree((char*)nameArgv); + } + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, "\n (while adding to ensemble \"", -1); + Tcl_DStringAppend(&buffer, ensName, -1); + Tcl_DStringAppend(&buffer, "\")", -1); + Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); + Tcl_DStringFree(&buffer); + + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsemblePart -- + * + * Looks for a part within an ensemble, and returns information + * about it. + * + * Results: + * If the ensemble and its part are found, this procedure + * loads information about the part into the "infoPtr" structure + * and returns 1. Otherwise, it returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsemblePart(interp, ensName, partName, infoPtr) + Tcl_Interp *interp; /* interpreter to be updated */ + char *ensName; /* ensemble containing the part */ + char *partName; /* name of the desired part */ + Tcl_CmdInfo *infoPtr; /* returns: info associated with part */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + EnsemblePart *ensPart; + Command *cmdPtr; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for a containing ensemble. + * Save the interpreter state before we do this. If we get any + * errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensGetFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensGetFail; + } + if (ensData == NULL) { + goto ensGetFail; + } + + /* + * Look for a part with the desired name. If found, load + * its data into the "infoPtr" structure. + */ + if (FindEnsemblePart(interp, ensData, partName, &ensPart) + != TCL_OK || ensPart == NULL) { + goto ensGetFail; + } + + cmdPtr = ensPart->cmdPtr; + infoPtr->isNativeObjectProc = (cmdPtr->objProc != TclInvokeStringCommand); + infoPtr->objProc = cmdPtr->objProc; + infoPtr->objClientData = cmdPtr->objClientData; + infoPtr->proc = cmdPtr->proc; + infoPtr->clientData = cmdPtr->clientData; + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->namespacePtr = (Tcl_Namespace*)cmdPtr->nsPtr; + + Itcl_DiscardInterpState(state); + return 1; + +ensGetFail: + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_IsEnsemble -- + * + * Determines whether or not an existing command is an ensemble. + * + * Results: + * Returns non-zero if the command is an ensemble, and zero + * otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Itcl_IsEnsemble(infoPtr) + Tcl_CmdInfo* infoPtr; /* command info from Tcl_GetCommandInfo() */ +{ + if (infoPtr) { + return (infoPtr->deleteProc == DeleteEnsemble); + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsage -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. Having this summary is sometimes useful + * when building error messages for the "@error" handler in + * an ensemble. + * + * Ensembles are accessed by name, as described in + * Itcl_CreateEnsemble. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsage(interp, ensName, objPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + char *ensName; /* name of the ensemble */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + char **nameArgv = NULL; + int nameArgc; + Ensemble *ensData; + Itcl_InterpState state; + + /* + * Parse the ensemble name and look for the ensemble. + * Save the interpreter state before we do this. If we get + * any errors, we don't want them to affect the interpreter. + */ + state = Itcl_SaveInterpState(interp, TCL_OK); + + if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { + goto ensUsageFail; + } + if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { + goto ensUsageFail; + } + if (ensData == NULL) { + goto ensUsageFail; + } + + /* + * Add a summary of usage information to the return buffer. + */ + GetEnsembleUsage(ensData, objPtr); + + Itcl_DiscardInterpState(state); + return 1; + +ensUsageFail: + Itcl_RestoreInterpState(interp, state); + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_GetEnsembleUsageForObj -- + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. This procedure is just + * like Itcl_GetEnsembleUsage, but it determines the desired + * ensemble from a command line argument. The argument should + * be the first argument on the command line--the ensemble + * command or one of its parts. + * + * Results: + * If the ensemble is found, its usage information is appended + * onto the object "objPtr", and this procedure returns + * non-zero. It is the responsibility of the caller to + * initialize and free the object. If anything goes wrong, + * this procedure returns 0. + * + * Side effects: + * Object passed in is modified. + * + *---------------------------------------------------------------------- + */ +int +Itcl_GetEnsembleUsageForObj(interp, ensObjPtr, objPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Tcl_Obj *ensObjPtr; /* argument representing ensemble */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + Ensemble *ensData; + Tcl_Obj *chainObj; + Tcl_Command cmd; + Command *cmdPtr; + + /* + * If the argument is an ensemble part, then follow the chain + * back to the command word for the entire ensemble. + */ + chainObj = ensObjPtr; + while (chainObj && chainObj->typePtr == &itclEnsInvocType) { + chainObj = (Tcl_Obj*)chainObj->internalRep.twoPtrValue.ptr2; + } + + if (chainObj) { + cmd = Tcl_GetCommandFromObj(interp, chainObj); + cmdPtr = (Command*)cmd; + if (cmdPtr->deleteProc == DeleteEnsemble) { + ensData = (Ensemble*)cmdPtr->objClientData; + GetEnsembleUsage(ensData, objPtr); + return 1; + } + } + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleUsage -- + * + * + * Returns a summary of all of the parts of an ensemble and + * the meaning of their arguments. Each part is listed on + * a separate line. This procedure is used internally to + * generate usage information for error messages. + * + * Results: + * Appends usage information onto the object in "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsembleUsage(ensData, objPtr) + Ensemble *ensData; /* ensemble data */ + Tcl_Obj *objPtr; /* returns: summary of usage info */ +{ + char *spaces = " "; + int isOpenEnded = 0; + + int i; + EnsemblePart *ensPart; + + for (i=0; i < ensData->numParts; i++) { + ensPart = ensData->parts[i]; + + if (*ensPart->name == '@' && strcmp(ensPart->name,"@error") == 0) { + isOpenEnded = 1; + } + else { + Tcl_AppendToObj(objPtr, spaces, -1); + GetEnsemblePartUsage(ensPart, objPtr); + spaces = "\n "; + } + } + if (isOpenEnded) { + Tcl_AppendToObj(objPtr, + "\n...and others described on the man page", -1); + } +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsemblePartUsage -- + * + * Determines the usage for a single part within an ensemble, + * and appends a summary onto a dynamic string. The usage + * is a combination of the part name and the argument summary. + * It is the caller's responsibility to initialize and free + * the dynamic string. + * + * Results: + * Returns usage information in the object "objPtr". + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +GetEnsemblePartUsage(ensPart, objPtr) + EnsemblePart *ensPart; /* ensemble part for usage info */ + Tcl_Obj *objPtr; /* returns: usage information */ +{ + EnsemblePart *part; + Command *cmdPtr; + char *name; + Itcl_List trail; + Itcl_ListElem *elem; + Tcl_DString buffer; + + /* + * Build the trail of ensemble names leading to this part. + */ + Tcl_DStringInit(&buffer); + Itcl_InitList(&trail); + for (part=ensPart; part; part=part->ensemble->parent) { + Itcl_InsertList(&trail, (ClientData)part); + } + + cmdPtr = (Command*)ensPart->ensemble->cmd; + name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + Tcl_DStringAppendElement(&buffer, name); + + for (elem=Itcl_FirstListElem(&trail); elem; elem=Itcl_NextListElem(elem)) { + part = (EnsemblePart*)Itcl_GetListValue(elem); + Tcl_DStringAppendElement(&buffer, part->name); + } + Itcl_DeleteList(&trail); + + /* + * If the part has usage info, use it directly. + */ + if (ensPart->usage && *ensPart->usage != '\0') { + Tcl_DStringAppend(&buffer, " ", 1); + Tcl_DStringAppend(&buffer, ensPart->usage, -1); + } + + /* + * If the part is itself an ensemble, summarize its usage. + */ + else if (ensPart->cmdPtr && + ensPart->cmdPtr->deleteProc == DeleteEnsemble) { + Tcl_DStringAppend(&buffer, " option ?arg arg ...?", 21); + } + + Tcl_AppendToObj(objPtr, Tcl_DStringValue(&buffer), + Tcl_DStringLength(&buffer)); + + Tcl_DStringFree(&buffer); +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemble -- + * + * Creates an ensemble command, or adds a sub-ensemble to an + * existing ensemble command. Works like Itcl_CreateEnsemble, + * except that the ensemble name is a single name, not a path. + * If a parent ensemble is specified, then a new ensemble is + * added to that parent. If a part already exists with the + * same name, it is an error. If a parent ensemble is not + * specified, then a top-level ensemble is created. If a + * command already exists with the same name, it is deleted. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemble(interp, parentEnsData, ensName) + Tcl_Interp *interp; /* interpreter to be updated */ + Ensemble *parentEnsData; /* parent ensemble or NULL */ + char *ensName; /* name of the new ensemble */ +{ + Ensemble *ensData; + EnsemblePart *ensPart; + Command *cmdPtr; + Tcl_CmdInfo cmdInfo; + + /* + * Create the data associated with the ensemble. + */ + ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); + ensData->interp = interp; + ensData->numParts = 0; + ensData->maxParts = 10; + ensData->parts = (EnsemblePart**)ckalloc( + (unsigned)(ensData->maxParts*sizeof(EnsemblePart*)) + ); + ensData->cmd = NULL; + ensData->parent = NULL; + + /* + * If there is no parent data, then this is a top-level + * ensemble. Create the ensemble by installing its access + * command. + * + * BE CAREFUL: Set the string-based proc to the wrapper + * procedure TclInvokeObjectCommand. Otherwise, the + * ensemble command may fail. For example, it will fail + * when invoked as a hidden command. + */ + if (parentEnsData == NULL) { + ensData->cmd = Tcl_CreateObjCommand(interp, ensName, + HandleEnsemble, (ClientData)ensData, DeleteEnsemble); + + if (Tcl_GetCommandInfo(interp, ensName, &cmdInfo)) { + cmdInfo.proc = TclInvokeObjectCommand; + Tcl_SetCommandInfo(interp, ensName, &cmdInfo); + } + return TCL_OK; + } + + /* + * Otherwise, this ensemble is contained within another parent. + * Install the new ensemble as a part within its parent. + */ + if (CreateEnsemblePart(interp, parentEnsData, ensName, &ensPart) + != TCL_OK) { + DeleteEnsemble((ClientData)ensData); + return TCL_ERROR; + } + + ensData->cmd = parentEnsData->cmd; + ensData->parent = ensPart; + + cmdPtr = (Command*)ckalloc(sizeof(Command)); + cmdPtr->hPtr = NULL; + cmdPtr->nsPtr = ((Command*)ensData->cmd)->nsPtr; + cmdPtr->refCount = 0; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = HandleEnsemble; + cmdPtr->objClientData = (ClientData)ensData; + cmdPtr->proc = NULL; + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = DeleteEnsemble; + cmdPtr->deleteData = cmdPtr->objClientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + ensPart->cmdPtr = cmdPtr; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * AddEnsemblePart -- + * + * Adds a part to an existing ensemble. Works like + * Itcl_AddEnsemblePart, but the part name is a single word, + * not a path. + * + * If the ensemble already has a part with the specified name, + * this procedure returns an error. Otherwise, it adds a new + * part to the ensemble. + * + * Any client data specified is automatically passed to the + * handling procedure whenever the part is invoked. It is + * automatically destroyed by the deleteProc when the part is + * deleted. + * + * Results: + * Returns TCL_OK if successful, along with a pointer to the + * new part. Returns TCL_ERROR if anything goes wrong. + * + * Side effects: + * If an error is encountered, an error is left as the result + * in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +AddEnsemblePart(interp, ensData, partName, usageInfo, + objProc, clientData, deleteProc, rVal) + + Tcl_Interp *interp; /* interpreter to be updated */ + Ensemble* ensData; /* ensemble that will contain this part */ + char* partName; /* name of the new part */ + char* usageInfo; /* usage info for argument list */ + Tcl_ObjCmdProc *objProc; /* handling procedure for part */ + ClientData clientData; /* client data associated with part */ + Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ + EnsemblePart **rVal; /* returns: new ensemble part */ +{ + EnsemblePart *ensPart; + Command *cmdPtr; + + /* + * Install the new part into the part list. + */ + if (CreateEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { + return TCL_ERROR; + } + + if (usageInfo) { + ensPart->usage = ckalloc((unsigned)(strlen(usageInfo)+1)); + strcpy(ensPart->usage, usageInfo); + } + + cmdPtr = (Command*)ckalloc(sizeof(Command)); + cmdPtr->hPtr = NULL; + cmdPtr->nsPtr = ((Command*)ensData->cmd)->nsPtr; + cmdPtr->refCount = 0; + cmdPtr->cmdEpoch = 0; + cmdPtr->compileProc = NULL; + cmdPtr->objProc = objProc; + cmdPtr->objClientData = (ClientData)clientData; + cmdPtr->proc = NULL; + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = deleteProc; + cmdPtr->deleteData = (ClientData)clientData; + cmdPtr->deleted = 0; + cmdPtr->importRefPtr = NULL; + + ensPart->cmdPtr = cmdPtr; + *rVal = ensPart; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemble -- + * + * Invoked when the command associated with an ensemble is + * destroyed, to delete the ensemble. Destroys all parts + * included in the ensemble, and frees all memory associated + * with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemble(clientData) + ClientData clientData; /* ensemble data */ +{ + Ensemble* ensData = (Ensemble*)clientData; + + /* + * BE CAREFUL: Each ensemble part removes itself from the list. + * So keep deleting the first part until all parts are gone. + */ + while (ensData->numParts > 0) { + DeleteEnsemblePart(ensData->parts[0]); + } + ckfree((char*)ensData->parts); + ckfree((char*)ensData); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemble -- + * + * Searches for an ensemble command and follows a path to + * sub-ensembles. + * + * Results: + * Returns TCL_OK if the ensemble was found, along with a + * pointer to the ensemble data in "ensDataPtr". Returns + * TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemble(interp, nameArgv, nameArgc, ensDataPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + char **nameArgv; /* path of names leading to ensemble */ + int nameArgc; /* number of strings in nameArgv */ + Ensemble** ensDataPtr; /* returns: ensemble data */ +{ + int i; + Command* cmdPtr; + Ensemble *ensData; + EnsemblePart *ensPart; + + *ensDataPtr = NULL; /* assume that no data will be found */ + + /* + * If there are no names in the path, then return an error. + */ + if (nameArgc < 1) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"\"", -1); + return TCL_ERROR; + } + + /* + * Use the first name to find the command for the top-level + * ensemble. + */ + cmdPtr = (Command*) Tcl_FindCommand(interp, nameArgv[0], + (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); + + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", nameArgv[0], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + + /* + * Follow the trail of sub-ensemble names. + */ + for (i=1; i < nameArgc; i++) { + if (FindEnsemblePart(interp, ensData, nameArgv[i], &ensPart) + != TCL_OK) { + return TCL_ERROR; + } + if (ensPart == NULL) { + char *pname = Tcl_Merge(i, nameArgv); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid ensemble name \"", pname, "\"", + (char*)NULL); + ckfree(pname); + return TCL_ERROR; + } + + cmdPtr = ensPart->cmdPtr; + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", nameArgv[i], "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + *ensDataPtr = ensData; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * CreateEnsemblePart -- + * + * Creates a new part within an ensemble. + * + * Results: + * If successful, this procedure returns TCL_OK, along with a + * pointer to the new part in "ensPartPtr". If a part with the + * same name already exists, this procedure returns TCL_ERROR. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +CreateEnsemblePart(interp, ensData, partName, ensPartPtr) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Ensemble *ensData; /* ensemble being modified */ + char* partName; /* name of the new part */ + EnsemblePart **ensPartPtr; /* returns: new ensemble part */ +{ + int i, pos, size; + EnsemblePart** partList; + EnsemblePart* part; + + /* + * If a matching entry was found, then return an error. + */ + if (FindEnsemblePartIndex(ensData, partName, &pos)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", partName, "\" already exists in ensemble", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Otherwise, make room for a new entry. Keep the parts in + * lexicographical order, so we can search them quickly + * later. + */ + if (ensData->numParts >= ensData->maxParts) { + size = ensData->maxParts*sizeof(EnsemblePart*); + partList = (EnsemblePart**)ckalloc((unsigned)2*size); + memcpy((VOID*)partList, (VOID*)ensData->parts, (size_t)size); + ckfree((char*)ensData->parts); + + ensData->parts = partList; + ensData->maxParts *= 2; + } + + for (i=ensData->numParts; i > pos; i--) { + ensData->parts[i] = ensData->parts[i-1]; + } + ensData->numParts++; + + part = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); + part->name = (char*)ckalloc((unsigned)(strlen(partName)+1)); + strcpy(part->name, partName); + part->cmdPtr = NULL; + part->usage = NULL; + part->ensemble = ensData; + + ensData->parts[pos] = part; + + /* + * Compare the new part against the one on either side of + * it. Determine how many letters are needed in each part + * to guarantee that an abbreviated form is unique. Update + * the parts on either side as well, since they are influenced + * by the new part. + */ + ComputeMinChars(ensData, pos); + ComputeMinChars(ensData, pos-1); + ComputeMinChars(ensData, pos+1); + + *ensPartPtr = part; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsemblePart -- + * + * Deletes a single part from an ensemble. The part must have + * been created previously by CreateEnsemblePart. + * + * If the part has a delete proc, then it is called to free the + * associated client data. + * + * Results: + * None. + * + * Side effects: + * Delete proc is called. + * + *---------------------------------------------------------------------- + */ +static void +DeleteEnsemblePart(ensPart) + EnsemblePart *ensPart; /* part being destroyed */ +{ + int i, pos; + Command *cmdPtr; + Ensemble *ensData; + cmdPtr = ensPart->cmdPtr; + + /* + * If this part has a delete proc, then call it to free + * up the client data. + */ + if (cmdPtr->deleteData && cmdPtr->deleteProc) { + (*cmdPtr->deleteProc)(cmdPtr->deleteData); + } + ckfree((char*)cmdPtr); + + /* + * Find this part within its ensemble, and remove it from + * the list of parts. + */ + if (FindEnsemblePartIndex(ensPart->ensemble, ensPart->name, &pos)) { + ensData = ensPart->ensemble; + for (i=pos; i < ensData->numParts-1; i++) { + ensData->parts[i] = ensData->parts[i+1]; + } + ensData->numParts--; + } + + /* + * Free the memory associated with the part. + */ + if (ensPart->usage) { + ckfree(ensPart->usage); + } + ckfree(ensPart->name); + ckfree((char*)ensPart); +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePart -- + * + * Searches for a part name within an ensemble. Recognizes + * unique abbreviations for part names. + * + * Results: + * If the part name is not a unique abbreviation, this procedure + * returns TCL_ERROR. Otherwise, it returns TCL_OK. If the + * part can be found, "rensPart" returns a pointer to the part. + * Otherwise, it returns NULL. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePart(interp, ensData, partName, rensPart) + Tcl_Interp *interp; /* interpreter containing the ensemble */ + Ensemble *ensData; /* ensemble being searched */ + char* partName; /* name of the desired part */ + EnsemblePart **rensPart; /* returns: pointer to the desired part */ +{ + int pos = 0; + int first, last, nlen; + int i, cmp; + + *rensPart = NULL; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. Match only + * as many characters as are included in the specified + * part name. + */ + first = 0; + last = ensData->numParts-1; + nlen = strlen(partName); + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strncmp(partName, ensData->parts[pos]->name, nlen); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + /* + * If a matching entry could not be found, then quit. + */ + if (last < first) { + return TCL_OK; + } + + /* + * If a matching entry was found, there may be some ambiguity + * if the user did not specify enough characters. Find the + * top-most match in the list, and see if the part name has + * enough characters. If there are two parts like "foo" + * and "food", this allows us to match "foo" exactly. + */ + if (nlen < ensData->parts[pos]->minChars) { + while (pos > 0) { + pos--; + if (strncmp(partName, ensData->parts[pos]->name, nlen) != 0) { + pos++; + break; + } + } + } + if (nlen < ensData->parts[pos]->minChars) { + Tcl_Obj *resultPtr = Tcl_NewStringObj((char*)NULL, 0); + + Tcl_AppendStringsToObj(resultPtr, + "ambiguous option \"", partName, "\": should be one of...", + (char*)NULL); + + for (i=pos; i < ensData->numParts; i++) { + if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { + break; + } + Tcl_AppendToObj(resultPtr, "\n ", 3); + GetEnsemblePartUsage(ensData->parts[i], resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Found a match. Return the desired part. + */ + *rensPart = ensData->parts[pos]; + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * FindEnsemblePartIndex -- + * + * Searches for a part name within an ensemble. The part name + * must be an exact match for an existing part name in the + * ensemble. This procedure is useful for managing (i.e., + * creating and deleting) parts in an ensemble. + * + * Results: + * If an exact match is found, this procedure returns + * non-zero, along with the index of the part in posPtr. + * Otherwise, it returns zero, along with an index in posPtr + * indicating where the part should be. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +FindEnsemblePartIndex(ensData, partName, posPtr) + Ensemble *ensData; /* ensemble being searched */ + char *partName; /* name of desired part */ + int *posPtr; /* returns: index for part */ +{ + int pos = 0; + int first, last; + int cmp; + + /* + * Search for the desired part name. + * All parts are in lexicographical order, so use a + * binary search to find the part quickly. + */ + first = 0; + last = ensData->numParts-1; + + while (last >= first) { + pos = (first+last)/2; + if (*partName == *ensData->parts[pos]->name) { + cmp = strcmp(partName, ensData->parts[pos]->name); + if (cmp == 0) { + break; /* found it! */ + } + } + else if (*partName < *ensData->parts[pos]->name) { + cmp = -1; + } + else { + cmp = 1; + } + + if (cmp > 0) { + first = pos+1; + } else { + last = pos-1; + } + } + + if (last >= first) { + *posPtr = pos; + return 1; + } + *posPtr = first; + return 0; +} + + +/* + *---------------------------------------------------------------------- + * + * ComputeMinChars -- + * + * Compares part names on an ensemble's part list and + * determines the minimum number of characters needed for a + * unique abbreviation. The parts on either side of a + * particular part index are compared. As long as there is + * a part on one side or the other, this procedure updates + * the parts to have the proper minimum abbreviations. + * + * Results: + * None. + * + * Side effects: + * Updates three parts within the ensemble to remember + * the minimum abbreviations. + * + *---------------------------------------------------------------------- + */ +static void +ComputeMinChars(ensData, pos) + Ensemble *ensData; /* ensemble being modified */ + int pos; /* index of part being updated */ +{ + int min, max; + char *p, *q; + + /* + * If the position is invalid, do nothing. + */ + if (pos < 0 || pos >= ensData->numParts) { + return; + } + + /* + * Start by assuming that only the first letter is required + * to uniquely identify this part. Then compare the name + * against each neighboring part to determine the real minimum. + */ + ensData->parts[pos]->minChars = 1; + + if (pos-1 >= 0) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos-1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + if (pos+1 < ensData->numParts) { + p = ensData->parts[pos]->name; + q = ensData->parts[pos+1]->name; + for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { + p++; + q++; + } + if (min > ensData->parts[pos]->minChars) { + ensData->parts[pos]->minChars = min; + } + } + + max = strlen(ensData->parts[pos]->name); + if (ensData->parts[pos]->minChars > max) { + ensData->parts[pos]->minChars = max; + } +} + + +/* + *---------------------------------------------------------------------- + * + * HandleEnsemble -- + * + * Invoked by Tcl whenever the user issues an ensemble-style + * command. Handles commands of the form: + * + * <ensembleName> <partName> ?<arg> <arg>...? + * + * Looks for the <partName> within the ensemble, and if it + * exists, the procedure transfers control to it. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +static int +HandleEnsemble(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Ensemble *ensData = (Ensemble*)clientData; + + int i, result; + Command *cmdPtr; + EnsemblePart *ensPart; + char *partName; + int partNameLen; + Tcl_Obj *cmdlinePtr, *chainObj; + int cmdlinec; + Tcl_Obj **cmdlinev; + + /* + * If a part name is not specified, return an error that + * summarizes the usage for this ensemble. + */ + if (objc < 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj( + "wrong # args: should be one of...\n", -1); + + GetEnsembleUsage(ensData, resultPtr); + Tcl_SetObjResult(interp, resultPtr); + return TCL_ERROR; + } + + /* + * Lookup the desired part. If an ambiguous abbrevition is + * found, return an error immediately. + */ + partName = Tcl_GetStringFromObj(objv[1], &partNameLen); + if (FindEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the part was not found, then look for an "@error" part + * to handle the error. + */ + if (ensPart == NULL) { + if (FindEnsemblePart(interp, ensData, "@error", &ensPart) != TCL_OK) { + return TCL_ERROR; + } + if (ensPart != NULL) { + cmdPtr = (Command*)ensPart->cmdPtr; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, + interp, objc, objv); + return result; + } + } + if (ensPart == NULL) { + return Itcl_EnsembleErrorCmd((ClientData)ensData, + interp, objc-1, objv+1); + } + + /* + * Pass control to the part, and return the result. + */ + chainObj = Tcl_NewObj(); + chainObj->bytes = NULL; + chainObj->typePtr = &itclEnsInvocType; + chainObj->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; + Tcl_IncrRefCount(objv[1]); + chainObj->internalRep.twoPtrValue.ptr2 = (VOID *) objv[0]; + Tcl_IncrRefCount(objv[0]); + + cmdlinePtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, chainObj); + for (i=2; i < objc; i++) { + Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, objv[i]); + } + Tcl_IncrRefCount(cmdlinePtr); + + result = Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, + &cmdlinec, &cmdlinev); + + if (result == TCL_OK) { + cmdPtr = (Command*)ensPart->cmdPtr; + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, + cmdlinec, cmdlinev); + } + Tcl_DecrRefCount(cmdlinePtr); + + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleCmd -- + * + * Invoked by Tcl whenever the user issues the "ensemble" + * command to manipulate an ensemble. Handles the following + * syntax: + * + * ensemble <ensName> ?<command> <arg> <arg>...? + * ensemble <ensName> { + * part <partName> <args> <body> + * ensemble <ensName> { + * ... + * } + * } + * + * Finds or creates the ensemble <ensName>, and then executes + * the commands to add parts. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsembleCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + int status; + char *ensName; + EnsembleParser *ensInfo; + Ensemble *ensData, *savedEnsData; + EnsemblePart *ensPart; + Tcl_Command cmd; + Command *cmdPtr; + Tcl_Obj *objPtr; + + /* + * Make sure that an ensemble name was specified. + */ + if (objc < 2) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name ?command arg arg...?\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * If this is the "ensemble" command in the main interpreter, + * then the client data will be null. Otherwise, it is + * the "ensemble" command in the ensemble body parser, and + * the client data indicates which ensemble we are modifying. + */ + if (clientData) { + ensInfo = (EnsembleParser*)clientData; + } else { + ensInfo = GetEnsembleParser(interp); + } + ensData = ensInfo->ensData; + + /* + * Find or create the desired ensemble. If an ensemble is + * being built, then this "ensemble" command is enclosed in + * another "ensemble" command. Use the current ensemble as + * the parent, and find or create an ensemble part within it. + */ + ensName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + + if (ensData) { + if (FindEnsemblePart(interp, ensData, ensName, &ensPart) != TCL_OK) { + ensPart = NULL; + } + if (ensPart == NULL) { + if (CreateEnsemble(interp, ensData, ensName) != TCL_OK) { + return TCL_ERROR; + } + if (FindEnsemblePart(interp, ensData, ensName, &ensPart) + != TCL_OK) { + panic("Itcl_EnsembleCmd: can't create ensemble"); + } + } + + cmdPtr = (Command*)ensPart->cmdPtr; + if (cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "part \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + + /* + * Otherwise, the desired ensemble is a top-level ensemble. + * Find or create the access command for the ensemble, and + * then get its data. + */ + else { + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + if (cmd == NULL) { + if (CreateEnsemble(interp, (Ensemble*)NULL, ensName) + != TCL_OK) { + return TCL_ERROR; + } + cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); + } + cmdPtr = (Command*)cmd; + + if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), + "\" is not an ensemble", + (char*)NULL); + return TCL_ERROR; + } + ensData = (Ensemble*)cmdPtr->objClientData; + } + + /* + * At this point, we have the data for the ensemble that is + * being manipulated. Plug this into the parser, and then + * interpret the rest of the arguments in the ensemble parser. + */ + status = TCL_OK; + savedEnsData = ensInfo->ensData; + ensInfo->ensData = ensData; + + if (objc == 3) { + /* CYGNUS LOCAL - fix for Tcl8.1 */ +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + status = Tcl_EvalObj(ensInfo->parser, objv[2]); +#else + status = Tcl_EvalObj(ensInfo->parser, objv[2], 0); +#endif + } + else if (objc > 3) { + objPtr = Tcl_NewListObj(objc-2, objv+2); +#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 + status = Tcl_EvalObj(ensInfo->parser, objPtr); +#else + Tcl_IncrRefCount(objPtr); + status = Tcl_EvalObj(ensInfo->parser, objPtr, 0); +#endif + /* END CYGNUS LOCAL */ + Tcl_DecrRefCount(objPtr); /* we're done with the object */ + } + + /* + * Copy the result from the parser interpreter to the + * master interpreter. If an error was encountered, + * copy the error info first, and then set the result. + * Otherwise, the offending command is reported twice. + */ + if (status == TCL_ERROR) { + char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", + (char*)NULL, TCL_GLOBAL_ONLY); + + if (errInfo) { + Tcl_AddObjErrorInfo(interp, errInfo, -1); + } + + if (objc == 3) { + char msg[128]; + sprintf(msg, "\n (\"ensemble\" body line %d)", + ensInfo->parser->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser)); + + ensInfo->ensData = savedEnsData; + return status; +} + + +/* + *---------------------------------------------------------------------- + * + * GetEnsembleParser -- + * + * Returns the slave interpreter that acts as a parser for + * the body of an "ensemble" definition. The first time that + * this is called for an interpreter, the parser is created + * and registered as associated data. After that, it is + * simply returned. + * + * Results: + * Returns a pointer to the ensemble parser data structure. + * + * Side effects: + * On the first call, the ensemble parser is created and + * registered as "itcl_ensembleParser" with the interpreter. + * + *---------------------------------------------------------------------- + */ +static EnsembleParser* +GetEnsembleParser(interp) + Tcl_Interp *interp; /* interpreter handling the ensemble */ +{ + Namespace *nsPtr; + Tcl_Namespace *childNs; + EnsembleParser *ensInfo; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Command cmd; + + /* + * Look for an existing ensemble parser. If it is found, + * return it immediately. + */ + ensInfo = (EnsembleParser*) Tcl_GetAssocData(interp, + "itcl_ensembleParser", NULL); + + if (ensInfo) { + return ensInfo; + } + + /* + * Create a slave interpreter that can be used to parse + * the body of an ensemble definition. + */ + ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser)); + ensInfo->master = interp; + ensInfo->parser = Tcl_CreateInterp(); + ensInfo->ensData = NULL; + + /* + * Remove all namespaces and all normal commands from the + * parser interpreter. + */ + nsPtr = (Namespace*)Tcl_GetGlobalNamespace(ensInfo->parser); + + for (hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { + + childNs = (Tcl_Namespace*)Tcl_GetHashValue(hPtr); + Tcl_DeleteNamespace(childNs); + } + + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { + + cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(ensInfo->parser, cmd); + } + + /* + * Add the allowed commands to the parser interpreter: + * part, delete, ensemble + */ + Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, + (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); + + /* + * Install the parser data, so we'll have it the next time + * we call this procedure. + */ + (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", + DeleteEnsParser, (ClientData)ensInfo); + + return ensInfo; +} + + +/* + *---------------------------------------------------------------------- + * + * DeleteEnsParser -- + * + * Called when an interpreter is destroyed to clean up the + * ensemble parser within it. Destroys the slave interpreter + * and frees up the data associated with it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +DeleteEnsParser(clientData, interp) + ClientData clientData; /* client data for ensemble-related commands */ + Tcl_Interp *interp; /* interpreter containing the data */ +{ + EnsembleParser* ensInfo = (EnsembleParser*)clientData; + Tcl_DeleteInterp(ensInfo->parser); + ckfree((char*)ensInfo); +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsPartCmd -- + * + * Invoked by Tcl whenever the user issues the "part" command + * to manipulate an ensemble. This command can only be used + * inside the "ensemble" command, which handles ensembles. + * Handles the following syntax: + * + * ensemble <ensName> { + * part <partName> <args> <body> + * } + * + * Adds a new part called <partName> to the ensemble. If a + * part already exists with that name, it is an error. The + * new part is handled just like an ordinary Tcl proc, with + * a list of <args> and a <body> of code to execute. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything + * goes wrong. + * + * Side effects: + * If anything goes wrong, this procedure returns an error + * message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ +int +Itcl_EnsPartCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble data */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + EnsembleParser *ensInfo = (EnsembleParser*)clientData; + Ensemble *ensData = (Ensemble*)ensInfo->ensData; + + int status, varArgs, space; + char *partName, *usage; + Proc *procPtr; + Command *cmdPtr; + CompiledLocal *localPtr; + EnsemblePart *ensPart; + Tcl_DString buffer; + + if (objc != 4) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"", + Tcl_GetStringFromObj(objv[0], (int*)NULL), + " name args body\"", + (char*)NULL); + return TCL_ERROR; + } + + /* + * Create a Tcl-style proc definition using the specified args + * and body. This is not a proc in the usual sense. It belongs + * to the namespace that contains the ensemble, but it is + * accessed through the ensemble, not through a Tcl command. + */ + partName = Tcl_GetStringFromObj(objv[1], (int*)NULL); + cmdPtr = (Command*)ensData->cmd; + + if (TclCreateProc(interp, cmdPtr->nsPtr, partName, objv[2], objv[3], + &procPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Deduce the usage information from the argument list. + * We'll register this when we create the part, in a moment. + */ + Tcl_DStringInit(&buffer); + varArgs = 0; + space = 0; + + for (localPtr=procPtr->firstLocalPtr; + localPtr != NULL; + localPtr=localPtr->nextPtr) { + + if (TclIsVarArgument(localPtr)) { + varArgs = 0; + if (strcmp(localPtr->name, "args") == 0) { + varArgs = 1; + } + else if (localPtr->defValuePtr) { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, "?", 1); + Tcl_DStringAppend(&buffer, localPtr->name, -1); + Tcl_DStringAppend(&buffer, "?", 1); + space = 1; + } + else { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, localPtr->name, -1); + space = 1; + } + } + } + if (varArgs) { + if (space) { + Tcl_DStringAppend(&buffer, " ", 1); + } + Tcl_DStringAppend(&buffer, "?arg arg ...?", 13); + } + + usage = Tcl_DStringValue(&buffer); + + /* + * Create a new part within the ensemble. If successful, + * plug the command token into the proc; we'll need it later + * if we try to compile the Tcl code for the part. If + * anything goes wrong, clean up before bailing out. + */ + status = AddEnsemblePart(interp, ensData, partName, usage, + TclObjInterpProc, (ClientData)procPtr, TclProcDeleteProc, + &ensPart); + + if (status == TCL_OK) { + procPtr->cmdPtr = ensPart->cmdPtr; + } else { + TclProcDeleteProc((ClientData)procPtr); + } + Tcl_DStringFree(&buffer); + + return status; +} + + +/* + *---------------------------------------------------------------------- + * + * Itcl_EnsembleErrorCmd -- + * + * Invoked when the user tries to access an unknown part for + * an ensemble. Acts as the default handler for the "@error" + * part. Generates an error message like: + * + * bad option "foo": should be one of... + * info args procname + * info body procname + * info cmdcount + * ... + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Returns the error message as the result in the interpreter. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +int +Itcl_EnsembleErrorCmd(clientData, interp, objc, objv) + ClientData clientData; /* ensemble info */ + Tcl_Interp *interp; /* current interpreter */ + int objc; /* number of arguments */ + Tcl_Obj *CONST objv[]; /* argument objects */ +{ + Ensemble *ensData = (Ensemble*)clientData; + + char *cmdName; + Tcl_Obj *objPtr; + + cmdName = Tcl_GetStringFromObj(objv[0], (int*)NULL); + + objPtr = Tcl_NewStringObj((char*)NULL, 0); + Tcl_AppendStringsToObj(objPtr, + "bad option \"", cmdName, "\": should be one of...\n", + (char*)NULL); + GetEnsembleUsage(ensData, objPtr); + + Tcl_SetObjResult(interp, objPtr); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * FreeEnsInvocInternalRep -- + * + * Frees the resources associated with an ensembleInvoc object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of the two objects referenced by + * this object. If there are no more uses, this will free + * the other objects. + * + *---------------------------------------------------------------------- + */ +static void +FreeEnsInvocInternalRep(objPtr) + register Tcl_Obj *objPtr; /* namespName object with internal + * representation to free */ +{ + Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; + + if (prevArgObj) { + Tcl_DecrRefCount(prevArgObj); + } +} + + +/* + *---------------------------------------------------------------------- + * + * DupEnsInvocInternalRep -- + * + * Initializes the internal representation of an ensembleInvoc + * object to a copy of the internal representation of + * another ensembleInvoc object. + * + * This shouldn't be called. Normally, a temporary ensembleInvoc + * object is created while an ensemble call is in progress. + * This object may be converted to string form if an error occurs. + * It does not stay around long, and there is no reason for it + * to be duplicated. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to duplicates of the objects + * pointed to by srcPtr's internal rep. + * + *---------------------------------------------------------------------- + */ +static void +DupEnsInvocInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + EnsemblePart *ensPart = (EnsemblePart*)srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *prevArgObj = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr2; + Tcl_Obj *objPtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; + + if (prevArgObj) { + objPtr = Tcl_DuplicateObj(prevArgObj); + copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) objPtr; + } +} + + +/* + *---------------------------------------------------------------------- + * + * SetEnsInvocFromAny -- + * + * Generates the internal representation for an ensembleInvoc + * object. This conversion really shouldn't take place. + * Normally, a temporary ensembleInvoc object is created while + * an ensemble call is in progress. This object may be converted + * to string form if an error occurs. But there is no reason + * for any other object to be converted to ensembleInvoc form. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * The string representation is saved as if it were the + * command line argument for the ensemble invocation. The + * reference to the ensemble part is set to NULL. + * + *---------------------------------------------------------------------- + */ +static int +SetEnsInvocFromAny(interp, objPtr) + Tcl_Interp *interp; /* Determines the context for + name resolution */ + register Tcl_Obj *objPtr; /* The object to convert */ +{ + int length; + char *name; + Tcl_Obj *argObj; + + /* + * Get objPtr's string representation. + * Make it up-to-date if necessary. + * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. + */ + name = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Make an argument object to contain the string, and + * set the ensemble part definition to NULL. At this point, + * we don't know anything about an ensemble, so we'll just + * keep the string around as if it were the command line + * invocation. + */ + argObj = Tcl_NewStringObj(name, -1); + + /* + * Free the old representation and install a new one. + */ + if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) argObj; + objPtr->typePtr = &itclEnsInvocType; + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfEnsInvoc -- + * + * Updates the string representation for an ensembleInvoc object. + * This is called when an error occurs in an ensemble part, when + * the code tries to print objv[0] as the command name. This + * code automatically chains together all of the names leading + * to the ensemble part, so the error message references the + * entire command, not just the part name. + * + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to the full command name for + * the ensemble part. + * + *---------------------------------------------------------------------- + */ +static void +UpdateStringOfEnsInvoc(objPtr) + register Tcl_Obj *objPtr; /* NamespName obj to update string rep. */ +{ + EnsemblePart *ensPart = (EnsemblePart*)objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; + + Tcl_DString buffer; + int length; + char *name; + + Tcl_DStringInit(&buffer); + + /* + * Get the string representation for the previous argument. + * This will force each ensembleInvoc argument up the line + * to get its string representation. So we will get the + * original command name, followed by the sub-ensemble, and + * the next sub-ensemble, and so on. Then add the part + * name from the ensPart argument. + */ + if (prevArgObj) { + name = Tcl_GetStringFromObj(prevArgObj, &length); + Tcl_DStringAppend(&buffer, name, length); + } + + if (ensPart) { + Tcl_DStringAppendElement(&buffer, ensPart->name); + } + + /* + * The following allocates an empty string on the heap if name is "" + * (e.g., if the internal rep is NULL). + */ + name = Tcl_DStringValue(&buffer); + length = strlen(name); + objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); + memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); + objPtr->bytes[length] = '\0'; + objPtr->length = length; +} |