/* * ------------------------------------------------------------------------ * 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 * * overhauled version author: Arnulf Wiedemann * ======================================================================== * 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" #define ITCL_ENSEMBLE_CUSTOM 0x01 #define ITCL_ENSEMBLE_ENSEMBLE 0x02 /* * Data used to represent an ensemble: */ struct Ensemble; typedef struct EnsemblePart { char *name; /* name of this part */ Tcl_Obj *namePtr; Tcl_Command cmdPtr; /* command handling this part */ char *usage; /* usage string describing syntax */ struct Ensemble* ensemble; /* ensemble containing this part */ ItclArgList *arglistPtr; /* the parsed argument list */ Tcl_ObjCmdProc *objProc; /* handling procedure for part */ void *clientData; /* the procPtr for the part */ Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ int minChars; /* chars needed to uniquely identify part */ int flags; Tcl_Interp *interp; Tcl_Obj *mapNamePtr; Tcl_Obj *subEnsemblePtr; Tcl_Obj *newMapDict; } EnsemblePart; #define ENSEMBLE_DELETE_STARTED 0x1 #define ENSEMBLE_PART_DELETE_STARTED 0x2 /* * 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_Size ensembleId; /* this ensembles id */ Tcl_Command cmdPtr; /* command representing this ensemble */ EnsemblePart* parent; /* parent part for sub-ensembles * NULL => toplevel ensemble */ Tcl_Namespace *nsPtr; /* namespace for ensemble part commands */ int flags; Tcl_Obj *namePtr; } Ensemble; /* * Data shared by ensemble access commands and ensemble parser: */ typedef struct EnsembleParser { Tcl_Interp* interp; /* interpreter containing ensembles */ Tcl_Interp* parser; /* child interp for parsing */ Ensemble* ensData; /* add parts to this ensemble */ } EnsembleParser; static Tcl_ObjCmdProc EnsembleSubCmd; static Tcl_ObjCmdProc EnsembleUnknownCmd; /* * Forward declarations for the procedures used in this file. */ static void GetEnsembleUsage (Tcl_Interp *interp, Ensemble *ensData, Tcl_Obj *objPtr); static void GetEnsemblePartUsage (Tcl_Interp *interp, Ensemble *ensData, EnsemblePart *ensPart, Tcl_Obj *objPtr); static int CreateEnsemble (Tcl_Interp *interp, Ensemble *parentEnsData, const char *ensName); static int AddEnsemblePart (Tcl_Interp *interp, Ensemble* ensData, const char* partName, const char* usageInfo, Tcl_ObjCmdProc *objProc, void *clientData, Tcl_CmdDeleteProc *deleteProc, int flags, EnsemblePart **rVal); static int FindEnsemble (Tcl_Interp *interp, const char **nameArgv, Tcl_Size nameArgc, Ensemble** ensDataPtr); static int CreateEnsemblePart (Tcl_Interp *interp, Ensemble *ensData, const char* partName, EnsemblePart **ensPartPtr); static void DeleteEnsemblePart (void *clientData); static int FindEnsemblePart (Tcl_Interp *interp, Ensemble *ensData, const char* partName, EnsemblePart **rensPart); static void DeleteEnsemble(void *clientData); static int FindEnsemblePartIndex (Ensemble *ensData, const char *partName, int *posPtr); static void ComputeMinChars (Ensemble *ensData, int pos); static EnsembleParser* GetEnsembleParser (Tcl_Interp *interp); static void DeleteEnsParser (void *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. * *---------------------------------------------------------------------- */ int Itcl_EnsembleInit( Tcl_Interp *interp) /* interpreter being initialized */ { Tcl_DString buffer; ItclObjectInfo *infoPtr; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); Tcl_CreateObjCommand(interp, "::itcl::ensemble", Itcl_EnsembleCmd, NULL, NULL); Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_COMMANDS_NAMESPACE, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, "::ensembles", TCL_INDEX_NONE); infoPtr->ensembleInfo->ensembleNsPtr = Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer), NULL, NULL); Tcl_DStringFree(&buffer); if (infoPtr->ensembleInfo->ensembleNsPtr == NULL) { Tcl_AppendResult(interp, "error in creating namespace: ", Tcl_DStringValue(&buffer), NULL); return TCL_ERROR; } Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::ensembles::unknown", EnsembleUnknownCmd, NULL, 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( Tcl_Interp *interp, /* interpreter to be updated */ const char* ensName) /* name of the new ensemble */ { const char **nameArgv = NULL; Tcl_Size nameArgc; Ensemble *parentEnsData; /* * Split the ensemble name into its path components. */ if (Tcl_SplitList(interp, (const char *)ensName, &nameArgc, &nameArgv) != TCL_OK) { goto ensCreateFail; } if (nameArgc < 1) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"", ensName, "\"", 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, "\"", 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_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while creating ensemble \"%s\")", ensName)); 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( Tcl_Interp *interp, /* interpreter to be updated */ const char* ensName, /* ensemble containing this part */ const char* partName, /* name of the new part */ const char* usageInfo, /* usage info for argument list */ Tcl_ObjCmdProc *objProc, /* handling procedure for part */ void *clientData, /* client data associated with part */ Tcl_CmdDeleteProc *deleteProc) /* procedure used to destroy client data */ { const char **nameArgv = NULL; Tcl_Size nameArgc; Ensemble *ensData; EnsemblePart *ensPart; /* * Parse the ensemble name and look for a containing ensemble. */ if (Tcl_SplitList(interp, (const char *)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, "\"", NULL); ckfree(pname); goto ensPartFail; } /* * Install the new part into the part list. */ if (AddEnsemblePart(interp, ensData, partName, usageInfo, objProc, clientData, deleteProc, ITCL_ENSEMBLE_CUSTOM, &ensPart) != TCL_OK) { goto ensPartFail; } ckfree((char*)nameArgv); return TCL_OK; ensPartFail: if (nameArgv) { ckfree((char*)nameArgv); } Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while adding to ensemble \"%s\")", ensName)); return TCL_ERROR; } #if TCL_MAJOR_VERSION > 8 typedef struct { Tcl_ObjCmdProc2 *objProc; void *clientData; Tcl_CmdDeleteProc *deleteProc; } ensInfo; static int ensCmdProc( void *clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const *objv) { ensInfo *info = (ensInfo *)clientData; return info->objProc(info->clientData, interp, argc, objv); } static void ens2DeleteProc( void *clientData) { ensInfo *info = (ensInfo *)clientData; if (info->deleteProc != NULL) { info->deleteProc(info->clientData); } ckfree(info); } int Itcl_AddEnsemblePart2( Tcl_Interp *interp, /* interpreter to be updated */ const char *ensName, /* ensemble containing this part */ const char *partName, /* name of the new part */ const char *usageInfo, /* usage info for argument list */ Tcl_ObjCmdProc2 *objProc, /* handling procedure for part */ void *clientData, /* client data associated with part */ Tcl_CmdDeleteProc *deleteProc) /* procedure used to destroy client data */ { ensInfo *info = (ensInfo *)ckalloc(sizeof(ensInfo)); info->objProc = objProc; info->clientData = clientData; info->deleteProc = deleteProc; return Itcl_AddEnsemblePart(interp, ensName, partName, usageInfo, ensCmdProc, info, ens2DeleteProc); } #endif /* TCL_MAJOR_VERSION */ /* *---------------------------------------------------------------------- * * 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( Tcl_Interp *interp, /* interpreter to be updated */ const char *ensName, /* ensemble containing the part */ const char *partName, /* name of the desired part */ Tcl_CmdInfo *infoPtr) /* returns: info associated with part */ { const char **nameArgv = NULL; Tcl_Size nameArgc; Ensemble *ensData; EnsemblePart *ensPart; 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, (const char *)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; } if (Tcl_GetCommandInfoFromToken(ensPart->cmdPtr, infoPtr) != 1) { goto ensGetFail; } Itcl_DiscardInterpState(state); ckfree((char *)nameArgv); return 1; ensGetFail: if (nameArgv) { ckfree((char *)nameArgv); } 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( Tcl_CmdInfo* infoPtr) /* command info from Tcl_GetCommandInfo() */ { if (infoPtr) { /* FIXME use CMD and Tcl_IsEnsemble!! */ 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( Tcl_Interp *interp, /* interpreter containing the ensemble */ const char *ensName, /* name of the ensemble */ Tcl_Obj *objPtr) /* returns: summary of usage info */ { const char **nameArgv = NULL; Tcl_Size 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, (const char *)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(interp, ensData, objPtr); Itcl_DiscardInterpState(state); ckfree((char *)nameArgv); return 1; ensUsageFail: if (nameArgv) { ckfree((char *)nameArgv); } 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( 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; Tcl_CmdInfo infoPtr; /* * If the argument is an ensemble part, then follow the chain * back to the command word for the entire ensemble. */ chainObj = ensObjPtr; if (chainObj) { cmd = Tcl_GetCommandFromObj(interp, chainObj); if (Tcl_GetCommandInfoFromToken(cmd, &infoPtr) != 1) { return 0; } if (infoPtr.deleteProc == DeleteEnsemble) { ensData = (Ensemble*)infoPtr.objClientData; GetEnsembleUsage(interp, 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( Tcl_Interp *interp, Ensemble *ensData, /* ensemble data */ Tcl_Obj *objPtr) /* returns: summary of usage info */ { const 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 { if ((*ensPart->name == '@') && (strcmp(ensPart->name,"@itcl-builtin_info") == 0)) { /* the builtin info command is not reported in [incr tcl] */ continue; } Tcl_AppendToObj(objPtr, spaces, TCL_INDEX_NONE); GetEnsemblePartUsage(interp, ensData, ensPart, objPtr); spaces = "\n "; } } if (isOpenEnded) { Tcl_AppendToObj(objPtr, "\n...and others described on the man page", TCL_INDEX_NONE); } } /* *---------------------------------------------------------------------- * * 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( Tcl_Interp *interp, Ensemble *ensData, EnsemblePart *ensPart, /* ensemble part for usage info */ Tcl_Obj *objPtr) /* returns: usage information */ { EnsemblePart *part; Tcl_Command cmdPtr; const 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, part); } while (ensData->parent != NULL) { ensData = ensData->parent->ensemble; } cmdPtr = ensData->cmdPtr; name = Tcl_GetCommandName(interp, cmdPtr); 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, TCL_INDEX_NONE); } else { /* * If the part is itself an ensemble, summarize its usage. */ if (ensPart->cmdPtr != NULL) { if (Tcl_IsEnsemble(ensPart->cmdPtr)) { 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( Tcl_Interp *interp, /* interpreter to be updated */ Ensemble *parentEnsData, /* parent ensemble or NULL */ const char *ensName) /* name of the new ensemble */ { Tcl_Obj *objPtr; Tcl_DString buffer; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict; Tcl_Obj *toObjPtr; ItclObjectInfo *infoPtr; Ensemble *ensData; EnsemblePart *ensPart; int result; int isNew; char buf[20]; Tcl_Obj *unkObjPtr; /* * Create the data associated with the ensemble. */ infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); infoPtr->ensembleInfo->numEnsembles++; ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); memset(ensData, 0, sizeof(Ensemble)); ensData->namePtr = Tcl_NewStringObj(ensName, TCL_INDEX_NONE); Tcl_IncrRefCount(ensData->namePtr); ensData->interp = interp; ensData->numParts = 0; ensData->maxParts = 10; ensData->ensembleId = infoPtr->ensembleInfo->numEnsembles; ensData->parts = (EnsemblePart**)ckalloc( (unsigned)(ensData->maxParts*sizeof(EnsemblePart*)) ); memset(ensData->parts, 0, ensData->maxParts*sizeof(EnsemblePart*)); Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_COMMANDS_NAMESPACE "::ensembles::", TCL_INDEX_NONE); sprintf(buf, "%" TCL_SIZE_MODIFIER "u", ensData->ensembleId); Tcl_DStringAppend(&buffer, buf, TCL_INDEX_NONE); ensData->nsPtr = Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer), ensData, DeleteEnsemble); if (ensData->nsPtr == NULL) { Tcl_AppendResult(interp, "error in creating namespace: ", Tcl_DStringValue(&buffer), NULL); result = TCL_ERROR; goto finish; } /* * If there is no parent data, then this is a top-level * ensemble. Create the ensemble by installing its access * command. */ if (parentEnsData == NULL) { ensData->cmdPtr = Tcl_CreateEnsemble(interp, ensName, Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensData->cmdPtr, &isNew); if (!isNew) { result = TCL_ERROR; goto finish; } Tcl_SetHashValue(hPtr, ensData); unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, TCL_INDEX_NONE); Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", TCL_INDEX_NONE); if (Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, unkObjPtr) != TCL_OK) { Tcl_DecrRefCount(unkObjPtr); result = TCL_ERROR; goto finish; } Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&buffer), TCL_INDEX_NONE)); result = TCL_OK; goto finish; } /* * 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(ensData); result = TCL_ERROR; goto finish; } Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, infoPtr->ensembleInfo->ensembleNsPtr->fullName, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, "::subensembles::", TCL_INDEX_NONE); sprintf(buf, "%" TCL_SIZE_MODIFIER "u", parentEnsData->ensembleId); Tcl_DStringAppend(&buffer, buf, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, ensName, TCL_INDEX_NONE); objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), TCL_INDEX_NONE); hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->subEnsembles, (char *)objPtr, &isNew); if (isNew) { Tcl_SetHashValue(hPtr, ensData); } ensPart->subEnsemblePtr = objPtr; Tcl_IncrRefCount(ensPart->subEnsemblePtr); ensPart->cmdPtr = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buffer), Tcl_GetCurrentNamespace(interp), TCL_ENSEMBLE_PREFIX); hPtr = Tcl_CreateHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensPart->cmdPtr, &isNew); if (!isNew) { result = TCL_ERROR; goto finish; } Tcl_SetHashValue(hPtr, ensData); unkObjPtr = Tcl_NewStringObj(ITCL_COMMANDS_NAMESPACE, TCL_INDEX_NONE); Tcl_AppendToObj(unkObjPtr, "::ensembles::unknown", TCL_INDEX_NONE); if (Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr, unkObjPtr) != TCL_OK) { result = TCL_ERROR; goto finish; } Tcl_GetEnsembleMappingDict(NULL, parentEnsData->cmdPtr, &mapDict); if (mapDict == NULL) { mapDict = Tcl_NewObj(); } toObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), TCL_INDEX_NONE); Tcl_DictObjPut(NULL, mapDict, ensData->namePtr, toObjPtr); Tcl_SetEnsembleMappingDict(NULL, parentEnsData->cmdPtr, mapDict); ensData->cmdPtr = ensPart->cmdPtr; ensData->parent = ensPart; result = TCL_OK; finish: Tcl_DStringFree(&buffer); return result; } /* *---------------------------------------------------------------------- * * 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( Tcl_Interp *interp, /* interpreter to be updated */ Ensemble* ensData, /* ensemble that will contain this part */ const char* partName, /* name of the new part */ const char* usageInfo, /* usage info for argument list */ Tcl_ObjCmdProc *objProc, /* handling procedure for part */ void *clientData, /* client data associated with part */ Tcl_CmdDeleteProc *deleteProc, /* procedure used to destroy client data */ int flags, EnsemblePart **rVal) /* returns: new ensemble part */ { Tcl_Obj *mapDict; Tcl_Command cmd; EnsemblePart *ensPart; /* * Install the new part into the part list. */ if (CreateEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { return TCL_ERROR; } if (usageInfo) { ensPart->usage = (char *)ckalloc(strlen(usageInfo)+1); strcpy(ensPart->usage, usageInfo); } ensPart->objProc = objProc; ensPart->clientData = clientData; ensPart->deleteProc = deleteProc; ensPart->flags = flags; mapDict = NULL; Tcl_GetEnsembleMappingDict(NULL, ensData->cmdPtr, &mapDict); if (mapDict == NULL) { mapDict = Tcl_NewObj(); ensPart->newMapDict = mapDict; } ensPart->mapNamePtr = Tcl_NewStringObj(ensData->nsPtr->fullName, TCL_INDEX_NONE); Tcl_AppendToObj(ensPart->mapNamePtr, "::", 2); Tcl_AppendToObj(ensPart->mapNamePtr, partName, TCL_INDEX_NONE); Tcl_IncrRefCount(ensPart->namePtr); Tcl_IncrRefCount(ensPart->mapNamePtr); Tcl_DictObjPut(NULL, mapDict, ensPart->namePtr, ensPart->mapNamePtr); cmd = Tcl_CreateObjCommand(interp, Tcl_GetString(ensPart->mapNamePtr), EnsembleSubCmd, ensPart, DeleteEnsemblePart); if (cmd == NULL) { Tcl_DictObjRemove(NULL, mapDict, ensPart->namePtr); Tcl_DecrRefCount(ensPart->namePtr); Tcl_DecrRefCount(ensPart->mapNamePtr); return TCL_ERROR; } Tcl_SetEnsembleMappingDict(interp, ensData->cmdPtr, mapDict); *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( void *clientData) /* ensemble data */ { FOREACH_HASH_DECLS; ItclObjectInfo *infoPtr; Ensemble* ensData; Ensemble* ensData2; ensData = (Ensemble*)clientData; /* remove the unknown handler if set to release the Tcl_Obj of the name */ if (Tcl_FindCommand(ensData->interp, Tcl_GetString(ensData->namePtr), NULL, 0) != NULL) { Tcl_SetEnsembleUnknownHandler(NULL, ensData->cmdPtr, NULL); } /* * 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]); } Tcl_DecrRefCount(ensData->namePtr); ckfree((char*)ensData->parts); ensData->parts = NULL; ensData->numParts = 0; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(ensData2, &infoPtr->ensembleInfo->ensembles) { if (ensData2 == ensData) { Tcl_DeleteHashEntry(hPtr); } } 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( Tcl_Interp *interp, /* interpreter containing the ensemble */ const char **nameArgv, /* path of names leading to ensemble */ Tcl_Size nameArgc, /* number of strings in nameArgv */ Ensemble** ensDataPtr) /* returns: ensemble data */ { Tcl_Size i; Tcl_Command cmdPtr; Ensemble *ensData; EnsemblePart *ensPart; Tcl_Obj *objPtr; Tcl_CmdInfo cmdInfo; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; *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 \"\"", TCL_INDEX_NONE); return TCL_ERROR; } /* * Use the first name to find the command for the top-level * ensemble. */ objPtr = Tcl_NewStringObj(nameArgv[0], TCL_INDEX_NONE); cmdPtr = Tcl_FindEnsemble(interp, objPtr, 0); Tcl_DecrRefCount(objPtr); if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", nameArgv[0], "\" is not an ensemble", NULL); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmdPtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", nameArgv[0], "\" is not an ensemble", NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); /* * 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, "\"", NULL); ckfree(pname); return TCL_ERROR; } cmdPtr = ensPart->cmdPtr; if (cmdPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", nameArgv[i], "\" is not an ensemble", NULL); return TCL_ERROR; } if (!Tcl_IsEnsemble(cmdPtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", nameArgv[i], "\" is not an ensemble", NULL); return TCL_ERROR; } if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) != 1) { return TCL_ERROR; } ensData = (Ensemble*)cmdInfo.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( Tcl_Interp *interp, /* interpreter containing the ensemble */ Ensemble *ensData, /* ensemble being modified */ const char* partName, /* name of the new part */ EnsemblePart **ensPartPtr) /* returns: new ensemble part */ { int i; int pos; int size; EnsemblePart** partList; EnsemblePart* ensPart; /* * 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", 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(partList, 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++; ensPart = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); memset(ensPart, 0, sizeof(EnsemblePart)); ensPart->name = (char*)ckalloc(strlen(partName)+1); strcpy(ensPart->name, partName); ensPart->namePtr = Tcl_NewStringObj(ensPart->name, TCL_INDEX_NONE); ensPart->ensemble = ensData; ensPart->interp = interp; ensData->parts[pos] = ensPart; /* * 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 = ensPart; 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( void *clientData) /* part being destroyed */ { Tcl_Obj *mapDict; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; Ensemble *ensData; Ensemble *ensData2; EnsemblePart *ensPart; int i; int pos; mapDict = NULL; ensPart = (EnsemblePart *)clientData; if (ensPart == NULL) { return; } ensData = ensPart->ensemble; /* * If this part has a delete proc, then call it to free * up the client data. */ if ((ensPart->deleteProc != NULL) && (ensPart->clientData != NULL)) { (*ensPart->deleteProc)(ensPart->clientData); } /* if it is a subensemble remove the command to free the data */ if (ensPart->subEnsemblePtr != NULL) { infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensData->interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->subEnsembles, (char *)ensPart->subEnsemblePtr); if (hPtr != NULL) { ensData2 = (Ensemble *)Tcl_GetHashValue(hPtr); Tcl_DeleteNamespace(ensData2->nsPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_SetEnsembleUnknownHandler(NULL, ensPart->cmdPtr, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensPart->ensemble->cmdPtr); if (hPtr != NULL) { ensData2 = (Ensemble *)Tcl_GetHashValue(hPtr); Tcl_GetEnsembleMappingDict(NULL, ensData2->cmdPtr, &mapDict); if (mapDict != NULL) { Tcl_DictObjRemove(ensPart->interp, mapDict, ensPart->namePtr); Tcl_SetEnsembleMappingDict(NULL, ensData2->cmdPtr, mapDict); } } Tcl_DecrRefCount(ensPart->subEnsemblePtr); if (ensPart->newMapDict != NULL) { Tcl_DecrRefCount(ensPart->newMapDict); } } /* * 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. */ mapDict = NULL; if (Tcl_FindCommand(ensData->interp, Tcl_GetString(ensData->namePtr), NULL, 0) != NULL) { Tcl_GetEnsembleMappingDict(ensData->interp, ensData->cmdPtr, &mapDict); if (mapDict != NULL) { if (!Tcl_IsShared(mapDict)) { Tcl_DictObjRemove(ensPart->interp, mapDict, ensPart->namePtr); Tcl_SetEnsembleMappingDict(ensPart->interp, ensData->cmdPtr, mapDict); } } } /* this is the map !!! */ if (ensPart->mapNamePtr != NULL) { Tcl_DecrRefCount(ensPart->mapNamePtr); } Tcl_DecrRefCount(ensPart->namePtr); if (ensPart->usage != NULL) { 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( Tcl_Interp *interp, /* interpreter containing the ensemble */ Ensemble *ensData, /* ensemble being searched */ const 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(NULL, 0); Tcl_AppendStringsToObj(resultPtr, "ambiguous option \"", partName, "\": should be one of...", NULL); for (i=pos; i < ensData->numParts; i++) { if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { break; } Tcl_AppendToObj(resultPtr, "\n ", 3); GetEnsemblePartUsage(interp, ensData, 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( Ensemble *ensData, /* ensemble being searched */ const 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( 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; } } /* *---------------------------------------------------------------------- * * Itcl_EnsembleCmd -- * * Invoked by Tcl whenever the user issues the "ensemble" * command to manipulate an ensemble. Handles the following * syntax: * * ensemble ? ...? * ensemble { * part * ensemble { * ... * } * } * * Finds or creates the ensemble , 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( void *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; Ensemble *savedEnsData; EnsemblePart *ensPart; Tcl_Command cmd; Tcl_Obj *objPtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclShowArgs(1, "Itcl_EnsembleCmd", objc, objv); /* * Make sure that an ensemble name was specified. */ if (objc < 2) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", Tcl_GetString(objv[0]), " name ?command arg arg...?\"", 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_GetString(objv[1]); if (ensData) { if (FindEnsemblePart(ensInfo->interp, ensData, ensName, &ensPart) != TCL_OK) { ensPart = NULL; } if (ensPart == NULL) { if (CreateEnsemble(ensInfo->interp, ensData, ensName) != TCL_OK) { Tcl_TransferResult(ensInfo->interp, TCL_ERROR, interp); return TCL_ERROR; } if (FindEnsemblePart(ensInfo->interp, ensData, ensName, &ensPart) != TCL_OK) { Tcl_Panic("Itcl_EnsembleCmd: can't create ensemble"); } } cmd = ensPart->cmdPtr; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(ensInfo->interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)ensPart->cmdPtr); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "part \"", Tcl_GetString(objv[1]), "\" is not an ensemble", NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); } else { /* * Otherwise, the desired ensemble is a top-level ensemble. * Find or create the access command for the ensemble, and * then get its data. */ cmd = Tcl_FindCommand(interp, ensName, NULL, 0); if (cmd == NULL) { if (CreateEnsemble(interp, NULL, ensName) != TCL_OK) { return TCL_ERROR; } cmd = Tcl_FindCommand(interp, ensName, NULL, 0); } if (cmd == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", Tcl_GetString(objv[1]), "\" is not an ensemble", (char *)NULL); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", Tcl_GetString(objv[1]), "\" is not an ensemble", (char *)NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); } /* * 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) { status = Tcl_EvalObjEx(ensInfo->parser, objv[2], 0); } else { if (objc > 3) { objPtr = Tcl_NewListObj(objc-2, objv+2); Tcl_IncrRefCount(objPtr); /* stop Eval trashing it */ status = Tcl_EvalObjEx(ensInfo->parser, objPtr, 0); Tcl_DecrRefCount(objPtr); /* we're done with the object */ } } /* * Copy the result from the parser interpreter to the * parent 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) { /* no longer needed, no extra interpreter !! */ const char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", NULL, TCL_GLOBAL_ONLY); if (errInfo) { Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(errInfo, TCL_INDEX_NONE)); } if (objc == 3) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"ensemble\" body line %d)", Tcl_GetErrorLine(ensInfo->parser))); } } Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser)); ensInfo->ensData = savedEnsData; return status; } /* *---------------------------------------------------------------------- * * GetEnsembleParser -- * * Returns the child 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( Tcl_Interp *interp) /* interpreter handling the ensemble */ { EnsembleParser *ensInfo; /* * 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 child interpreter that can be used to parse * the body of an ensemble definition. */ ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser)); ensInfo->interp = interp; ensInfo->parser = Tcl_CreateInterp(); ensInfo->ensData = NULL; Tcl_DeleteNamespace(Tcl_GetGlobalNamespace(ensInfo->parser)); /* * Add the allowed commands to the parser interpreter: * part, delete, ensemble */ Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, ensInfo, NULL); Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, ensInfo, NULL); Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, ensInfo, NULL); /* * Install the parser data, so we'll have it the next time * we call this procedure. */ (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", DeleteEnsParser, ensInfo); return ensInfo; } /* *---------------------------------------------------------------------- * * DeleteEnsParser -- * * Called when an interpreter is destroyed to clean up the * ensemble parser within it. Destroys the child interpreter * and frees up the data associated with it. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void DeleteEnsParser( void *clientData, /* client data for ensemble-related commands */ TCL_UNUSED(Tcl_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 { * part * } * * Adds a new part called 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 and a 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( void *clientData, /* ensemble data */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *usagePtr; Tcl_Proc procPtr; EnsembleParser *ensInfo = (EnsembleParser*)clientData; Ensemble *ensData = (Ensemble*)ensInfo->ensData; EnsemblePart *ensPart; ItclArgList *arglistPtr; char *partName; char *usage; int result; Tcl_Size argc; Tcl_Size maxArgc; Tcl_CmdInfo cmdInfo; ItclShowArgs(1, "Itcl_EnsPartCmd", objc, objv); if (objc != 4) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", Tcl_GetString(objv[0]), " name args body\"", 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_GetString(objv[1]); if (ItclCreateArgList(interp, Tcl_GetString(objv[2]), &argc, &maxArgc, &usagePtr, &arglistPtr, NULL, partName) != TCL_OK) { result = TCL_ERROR; goto errorOut; } if (Tcl_GetCommandInfoFromToken(ensData->cmdPtr, &cmdInfo) != 1) { result = TCL_ERROR; goto errorOut; } if (Tcl_CreateProc(ensInfo->interp, cmdInfo.namespacePtr, partName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_TransferResult(ensInfo->interp, TCL_ERROR, interp); result = TCL_ERROR; goto errorOut; } usage = Tcl_GetString(usagePtr); /* * 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. */ result = AddEnsemblePart(ensInfo->interp, ensData, partName, usage, Tcl_GetObjInterpProc(), procPtr, _Tcl_ProcDeleteProc, ITCL_ENSEMBLE_ENSEMBLE, &ensPart); if (result == TCL_ERROR) { _Tcl_ProcDeleteProc(procPtr); } Tcl_TransferResult(ensInfo->interp, result, interp); errorOut: Tcl_DecrRefCount(usagePtr); ItclDeleteArgList(arglistPtr); return result; } /* *---------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ int Itcl_EnsembleErrorCmd( void *clientData, /* ensemble info */ Tcl_Interp *interp, /* current interpreter */ TCL_UNUSED(Tcl_Size), /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Ensemble *ensData = (Ensemble*)clientData; char *cmdName; Tcl_Obj *objPtr; cmdName = Tcl_GetString(objv[0]); objPtr = Tcl_NewStringObj(NULL, 0); Tcl_AppendStringsToObj(objPtr, "bad option \"", cmdName, "\": should be one of...\n", NULL); GetEnsembleUsage(interp, ensData, objPtr); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * EnsembleSubCmd -- * *---------------------------------------------------------------------- */ static int CallInvokeEnsembleMethod( void *data[], Tcl_Interp *interp, int result) { Tcl_Namespace *nsPtr = (Tcl_Namespace *)data[0]; EnsemblePart *ensPart = (EnsemblePart *)data[1]; size_t objc = PTR2INT(data[2]); Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3]; result = Itcl_InvokeEnsembleMethod(interp, nsPtr, ensPart->namePtr, (Tcl_Proc *)ensPart->clientData, objc, objv); return result; } static int CallInvokeEnsembleMethod2( void *data[], Tcl_Interp *interp, int result) { EnsemblePart *ensPart = (EnsemblePart *)data[0]; Tcl_Size objc = PTR2INT(data[1]); Tcl_Obj *const *objv = (Tcl_Obj *const*)data[2]; result = (*ensPart->objProc)(ensPart->clientData, interp, objc, objv); return result; } static int EnsembleSubCmd( void *clientData, /* ensPart struct pointer */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int result; Tcl_Namespace *nsPtr; EnsemblePart *ensPart; void *callbackPtr; ItclShowArgs(1, "EnsembleSubCmd", objc, objv); result = TCL_OK; ensPart = (EnsemblePart *)clientData; nsPtr = Tcl_GetCurrentNamespace(interp); callbackPtr = Itcl_GetCurrentCallbackPtr(interp); if (ensPart->flags & ITCL_ENSEMBLE_ENSEMBLE) { /* FIXME !!! */ if (ensPart->clientData == NULL) { return TCL_ERROR; } Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod, nsPtr, ensPart, INT2PTR(objc), (void *)objv); } else { Tcl_NRAddCallback(interp, CallInvokeEnsembleMethod2, ensPart, INT2PTR(objc), (void *)objv, NULL); } result = Itcl_NRRunCallbacks(interp, callbackPtr); return result; } /* * ------------------------------------------------------------------------ * EnsembleUnknownCmd() * * the unknown handler for the ensemble commands * ------------------------------------------------------------------------ */ static int EnsembleUnknownCmd( TCL_UNUSED(void *), /* not used */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Command cmd; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; EnsemblePart *ensPart; Ensemble *ensData; ItclShowArgs(2, "EnsembleUnknownCmd", objc, objv); cmd = Tcl_GetCommandFromObj(interp, objv[1]); if (cmd == NULL) { Tcl_AppendResult(interp, "EnsembleUnknownCmd, ensemble not found!", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmd); if (hPtr == NULL) { Tcl_AppendResult(interp, "EnsembleUnknownCmd, ensemble struct not ", "found!", Tcl_GetString(objv[1]), NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); if (objc < 3) { /* produce usage message */ Tcl_Obj *objPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", TCL_INDEX_NONE); GetEnsembleUsage(interp, ensData, objPtr); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } if (FindEnsemblePart(interp, ensData, "@error", &ensPart) != TCL_OK) { Tcl_AppendResult(interp, "FindEnsemblePart error", NULL); return TCL_ERROR; } if (ensPart != NULL) { Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, listPtr, objv[1]); Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj("@error", TCL_INDEX_NONE)); Tcl_ListObjAppendElement(NULL, listPtr, objv[2]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } return Itcl_EnsembleErrorCmd(ensData, interp, objc-2, objv+2); } /* *---------------------------------------------------------------------- * * Itcl_EnsembleDeleteCmd -- * * Invoked when the user tries to delet an ensemble *---------------------------------------------------------------------- */ int Itcl_EnsembleDeleteCmd( void *clientData, /* infoPtr */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_Command cmdPtr; Ensemble *ensData; ItclObjectInfo *infoPtr; int i; infoPtr = (ItclObjectInfo *)clientData; ItclShowArgs(1, "Itcl_EnsembleDeleteCmd", objc, objv); for (i = 1; i < objc; i++) { cmdPtr = Tcl_FindCommand(interp, Tcl_GetString(objv[i]), NULL, 0); if (cmdPtr == NULL) { Tcl_AppendResult(interp, "no such ensemble \"", Tcl_GetString(objv[i]), "\"", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&infoPtr->ensembleInfo->ensembles, (char *)cmdPtr); if (hPtr == NULL) { Tcl_AppendResult(interp, "no such ensemble \"", Tcl_GetString(objv[i]), "\"", NULL); return TCL_ERROR; } ensData = (Ensemble *)Tcl_GetHashValue(hPtr); Itcl_RenameCommand(ensData->interp, Tcl_GetString(ensData->namePtr), ""); if (Tcl_FindNamespace(interp, ensData->nsPtr->fullName, NULL, 0) != NULL) { Tcl_DeleteNamespace(ensData->nsPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Itcl_FinishEnsemble -- * * Invoked when itcl package is finished or ItclFinishCmd is called *---------------------------------------------------------------------- */ void ItclFinishEnsemble( ItclObjectInfo *infoPtr) { Tcl_DeleteAssocData(infoPtr->interp, "itcl_ensembleParser"); }