/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tk] * DESCRIPTION: Building mega-widgets with [incr Tcl] * * [incr Tk] provides a framework for building composite "mega-widgets" * using [incr Tcl] classes. It defines a set of base classes that are * specialized to create all other widgets. * * This part adds C implementations for some of the methods in the * base class itk::Archetype. * * Itk_ArchComponentCmd <=> itk_component * Itk_ArchOptionCmd <=> itk_option * Itk_ArchInitCmd <=> itk_initialize * Itk_ArchCompAccessCmd <=> component * Itk_ArchConfigureCmd <=> configure * Itk_ArchCgetCmd <=> cget * * Itk_ArchInitOptsCmd <=> _initOptionInfo (used to set things up) * Itk_ArchDeleteOptsCmd <=> _deleteOptionInfo (used to clean things up) * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * RCS: $Id: itk_archetype.c,v 1.12 2007/05/24 22:12:55 hobbs Exp $ * ======================================================================== * 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 #include "itk.h" /* * Info associated with each Archetype mega-widget: */ typedef struct ArchInfo { ItclObject *itclObj; /* object containing this info */ Tk_Window tkwin; /* window representing this mega-widget */ Tcl_HashTable components; /* list of all mega-widget components */ Tcl_HashTable options; /* list of all mega-widget options */ ItkOptList order; /* gives ordering of options */ } ArchInfo; /* * Each component widget in an Archetype mega-widget: */ typedef struct ArchComponent { ItclMember *member; /* contains protection level for this comp */ Tcl_Command accessCmd; /* access command for component widget */ Tk_Window tkwin; /* Tk window for this component widget */ char *pathName; /* Tk path name for this component widget. We can't use the tkwin pointer after the window has been destroyed so we need to save a copy for use in Itk_ArchCompDeleteCmd() */ } ArchComponent; /* * Each option in an Archetype mega-widget: */ typedef struct ArchOption { char *switchName; /* command-line switch for this option */ char *resName; /* resource name in X11 database */ char *resClass; /* resource class name in X11 database */ char *init; /* initial value for option */ int flags; /* flags representing option state */ Itcl_List parts; /* parts relating to this option */ } ArchOption; /* * Flag bits for ArchOption state: */ #define ITK_ARCHOPT_INIT 0x01 /* option has been initialized */ /* * Various parts of a composite option in an Archetype mega-widget: */ typedef int (Itk_ConfigOptionPartProc) _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char* newVal)); typedef struct ArchOptionPart { ClientData clientData; /* data associated with this part */ Itk_ConfigOptionPartProc *configProc; /* update when new vals arrive */ Tcl_CmdDeleteProc *deleteProc; /* clean up after clientData */ ClientData from; /* token that indicates who * contributed this option part */ } ArchOptionPart; /* * Info kept by the itk::option-parser namespace and shared by * all option processing commands: */ typedef struct ArchMergeInfo { Tcl_HashTable usualCode; /* usual option handling code for the * various widget classes */ ArchInfo *archInfo; /* internal option info for mega-widget */ ArchComponent *archComp; /* component being merged into mega-widget */ Tcl_HashTable *optionTable; /* table of valid configuration options * for component being merged */ } ArchMergeInfo; /* * Used to capture component widget configuration options when a * new component is being merged into a mega-widget: */ typedef struct GenericConfigOpt { char *switchName; /* command-line switch for this option */ char *resName; /* resource name in X11 database */ char *resClass; /* resource class name in X11 database */ char *init; /* initial value for this option */ char *value; /* current value for this option */ char **storage; /* storage for above strings */ ArchOption *integrated; /* integrated into this mega-widget option */ ArchOptionPart *optPart; /* integrated as this option part */ } GenericConfigOpt; /* * Options that are propagated by a "configure" method: */ typedef struct ConfigCmdline { Tcl_Obj *objv[4]; /* objects representing "configure" command */ } ConfigCmdline; /* * FORWARD DECLARATIONS */ static void Itk_DelMergeInfo _ANSI_ARGS_((char* cdata)); static int Itk_ArchInitOptsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void Itk_DelArchInfo _ANSI_ARGS_((ClientData cdata)); static int Itk_ArchDeleteOptsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchComponentCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompAddCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompDeleteCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptKeepCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptIgnoreCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptRenameCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptUsualCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchInitCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionAddCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionRemoveCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompAccessCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchConfigureCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCgetCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_PropagateOption _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char *newval)); static int Itk_PropagatePublicVar _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char *newval)); static int Itk_ArchSetOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, CONST char *name, CONST char *value)); static int Itk_ArchConfigOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *name, char *value)); static void Itk_ArchOptConfigError _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt)); static void Itk_ArchOptAccessError _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt)); static int Itk_GetArchInfo _ANSI_ARGS_((Tcl_Interp *interp, ItclObject* contextObj, ArchInfo **infoPtr)); static ArchComponent* Itk_CreateArchComponent _ANSI_ARGS_(( Tcl_Interp *interp, ArchInfo *info, char *name, ItclClass *cdefn, Tcl_Command accessCmd)); static void Itk_DelArchComponent _ANSI_ARGS_((ArchComponent *archComp)); static int Itk_GetArchOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *switchName, char *resName, char *resClass, CONST char *defVal, char *currVal, ArchOption **aoPtr)); static void Itk_InitArchOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt, CONST char *defVal, char *currVal)); static void Itk_DelArchOption _ANSI_ARGS_((ArchOption *archOpt)); static ArchOptionPart* Itk_CreateOptionPart _ANSI_ARGS_(( Tcl_Interp *interp, ClientData cdata, Itk_ConfigOptionPartProc* cproc, Tcl_CmdDeleteProc *dproc, ClientData from)); static int Itk_AddOptionPart _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *switchName, char *resName, char *resClass, CONST char *defVal, char *currVal, ArchOptionPart *optPart, ArchOption **raOpt)); static ArchOptionPart* Itk_FindArchOptionPart _ANSI_ARGS_(( ArchInfo *info, char *switchName, ClientData from)); static int Itk_RemoveArchOptionPart _ANSI_ARGS_((ArchInfo *info, char *switchName, ClientData from)); static int Itk_IgnoreArchOptionPart _ANSI_ARGS_((ArchInfo *info, GenericConfigOpt *opt)); static void Itk_DelOptionPart _ANSI_ARGS_((ArchOptionPart *optPart)); static ConfigCmdline* Itk_CreateConfigCmdline _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Command accessCmd, char *switchName)); static void Itk_DeleteConfigCmdline _ANSI_ARGS_((ClientData cdata)); static Tcl_HashTable* Itk_CreateGenericOptTable _ANSI_ARGS_((Tcl_Interp *interp, char *options)); static void Itk_DelGenericOptTable _ANSI_ARGS_((Tcl_HashTable *tPtr)); static GenericConfigOpt* Itk_CreateGenericOpt _ANSI_ARGS_((Tcl_Interp *interp, char *switchName, Tcl_Command accessCmd)); static void Itk_DelGenericOpt _ANSI_ARGS_((GenericConfigOpt* opt)); static Tcl_HashTable* ItkGetObjsWithArchInfo _ANSI_ARGS_((Tcl_Interp *interp)); static void ItkFreeObjsWithArchInfo _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp)); /* * ------------------------------------------------------------------------ * Itk_ArchetypeInit() * * Invoked by Itk_Init() whenever a new interpreter is created to * declare the procedures used in the itk::Archetype base class. * ------------------------------------------------------------------------ */ int Itk_ArchetypeInit(interp) Tcl_Interp *interp; /* interpreter to be updated */ { ArchMergeInfo *mergeInfo; Tcl_Namespace *parserNs; /* * Declare all of the C routines that are integrated into * the Archetype base class. */ if (Itcl_RegisterObjC(interp, "Archetype-init", Itk_ArchInitOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-delete", Itk_ArchDeleteOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_component", Itk_ArchComponentCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_option", Itk_ArchOptionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_initialize", Itk_ArchInitCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-component", Itk_ArchCompAccessCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-configure",Itk_ArchConfigureCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-cget",Itk_ArchCgetCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { return TCL_ERROR; } /* * Create the namespace containing the option parser commands. */ mergeInfo = (ArchMergeInfo*)ckalloc(sizeof(ArchMergeInfo)); Tcl_InitHashTable(&mergeInfo->usualCode, TCL_STRING_KEYS); mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; mergeInfo->optionTable = NULL; parserNs = Tcl_CreateNamespace(interp, "::itk::option-parser", (ClientData)mergeInfo, Itcl_ReleaseData); if (!parserNs) { Itk_DelMergeInfo((char*)mergeInfo); Tcl_AddErrorInfo(interp, "\n (while initializing itk)"); return TCL_ERROR; } Itcl_PreserveData((ClientData)mergeInfo); Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo); Tcl_CreateObjCommand(interp, "::itk::option-parser::keep", Itk_ArchOptKeepCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore", Itk_ArchOptIgnoreCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::rename", Itk_ArchOptRenameCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::usual", Itk_ArchOptUsualCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); /* * Add the "itk::usual" command to register option handling code. */ Tcl_CreateObjCommand(interp, "::itk::usual", Itk_UsualCmd, (ClientData)mergeInfo, Itcl_ReleaseData); Itcl_PreserveData((ClientData)mergeInfo); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_DelMergeInfo() * * Destroys the "merge" info record shared by commands in the * itk::option-parser namespace. Invoked automatically when the * namespace containing the parsing commands is destroyed and there * are no more uses of the data. * ------------------------------------------------------------------------ */ static void Itk_DelMergeInfo(cdata) char* cdata; /* data to be destroyed */ { ArchMergeInfo *mergeInfo = (ArchMergeInfo*)cdata; Tcl_HashEntry *entry; Tcl_HashSearch place; Tcl_Obj *codePtr; assert(mergeInfo->optionTable == NULL); entry = Tcl_FirstHashEntry(&mergeInfo->usualCode, &place); while (entry) { codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry); Tcl_DecrRefCount(codePtr); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&mergeInfo->usualCode); ckfree((char*)mergeInfo); } /* * ------------------------------------------------------------------------ * Itk_ArchInitOptsCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::_initOptionInfo * method. This method should be called out in the constructor for * each object, to initialize the object so that it can be used with * the other access methods in this file. Allocates some extra * data associated with the object at the C-language level. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchInitOptsCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int newEntry, result; ArchInfo *info; ItclClass *contextClass; ItclObject *contextObj; Tcl_HashTable *objsWithArchInfo; Tcl_HashEntry *entry; Command *cmdPtr; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot use \"", token, "\" without an object context", (char*)NULL); return TCL_ERROR; } /* * Create some archetype info for the current object and * register it on the list of all known objects. */ objsWithArchInfo = ItkGetObjsWithArchInfo(interp); info = (ArchInfo*)ckalloc(sizeof(ArchInfo)); info->itclObj = contextObj; info->tkwin = NULL; /* not known yet */ Tcl_InitHashTable(&info->components, TCL_STRING_KEYS); Tcl_InitHashTable(&info->options, TCL_STRING_KEYS); Itk_OptListInit(&info->order, &info->options); entry = Tcl_CreateHashEntry(objsWithArchInfo, (char*)contextObj, &newEntry); if (!newEntry) { Itk_DelArchInfo( Tcl_GetHashValue(entry) ); } Tcl_SetHashValue(entry, (ClientData)info); /* * Make sure that the access command for this object * resides in the global namespace. If need be, move * the command. */ result = TCL_OK; cmdPtr = (Command*)contextObj->accessCmd; if (cmdPtr->nsPtr != (Namespace*)Tcl_GetGlobalNamespace(interp)) { Tcl_Obj *oldNamePtr, *newNamePtr; oldNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, contextObj->accessCmd, oldNamePtr); Tcl_IncrRefCount(oldNamePtr); newNamePtr = Tcl_NewStringObj("::", -1); Tcl_AppendToObj(newNamePtr, Tcl_GetCommandName(interp, contextObj->accessCmd), -1); Tcl_IncrRefCount(newNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(oldNamePtr, (int*)NULL), Tcl_GetStringFromObj(newNamePtr, (int*)NULL)); Tcl_DecrRefCount(oldNamePtr); Tcl_DecrRefCount(newNamePtr); } return result; } /* * ------------------------------------------------------------------------ * Itk_DelArchInfo() * * Invoked when the option info associated with an itk::Archetype * widget is no longer needed. This usually happens when a widget * is destroyed. Frees the given bundle of data and removes it * from the global list of Archetype objects. * ------------------------------------------------------------------------ */ static void Itk_DelArchInfo(cdata) ClientData cdata; /* client data for Archetype objects */ { ArchInfo *info = (ArchInfo*)cdata; Tcl_HashEntry *entry; Tcl_HashSearch place; ArchOption *archOpt; ArchComponent *archComp; /* * Destroy all component widgets. */ entry = Tcl_FirstHashEntry(&info->components, &place); while (entry) { archComp = (ArchComponent*)Tcl_GetHashValue(entry); Itk_DelArchComponent(archComp); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&info->components); /* * Destroy all information associated with configuration options. */ entry = Tcl_FirstHashEntry(&info->options, &place); while (entry) { archOpt = (ArchOption*)Tcl_GetHashValue(entry); Itk_DelArchOption(archOpt); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&info->options); Itk_OptListFree(&info->order); ckfree((char*)info); } /* * ------------------------------------------------------------------------ * Itk_ArchDeleteOptsCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::_deleteOptionInfo * method. This method should be called out in the destructor for each * object, to clean up data allocated by Itk_ArchInitOptsCmd(). * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchDeleteOptsCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclClass *contextClass; ItclObject *contextObj; Tcl_HashTable *objsWithArchInfo; Tcl_HashEntry *entry; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot use \"", token, "\" without an object context", (char*)NULL); return TCL_ERROR; } /* * Find the info associated with this object. * Destroy the data and remove it from the global list. */ objsWithArchInfo = ItkGetObjsWithArchInfo(interp); entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj); if (entry) { Itk_DelArchInfo( Tcl_GetHashValue(entry) ); Tcl_DeleteHashEntry(entry); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_ArchComponentCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Handles the following options: * * itk_component add ?-protected? ?-private? ?--? \ * ?? * * itk_component delete ?...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchComponentCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { char *cmd, *token, c; int length; /* * Check arguments and handle the various options... */ if (objc < 2) { cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "wrong # args: should be one of...\n", " ", cmd, " add ?-protected? ?-private? ?--? name createCmds ?optionCmds?\n", " ", cmd, " delete name ?name name...?", (char*)NULL); return TCL_ERROR; } token = Tcl_GetStringFromObj(objv[1], (int*)NULL); c = *token; length = strlen(token); /* * Handle: itk_component add... */ if (c == 'a' && strncmp(token, "add", length) == 0) { if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?"); return TCL_ERROR; } return Itk_ArchCompAddCmd(dummy, interp, objc-1, objv+1); } /* * Handle: itk_component delete... */ else if (c == 'd' && strncmp(token, "delete", length) == 0) { if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "delete name ?name name...?"); return TCL_ERROR; } return Itk_ArchCompDeleteCmd(dummy, interp, objc-1, objv+1); } /* * Flag any errors. */ cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "bad option \"", token, "\": should be one of...\n", " ", cmd, " add name createCmds ?optionCmds?\n", " ", cmd, " delete name ?name name...?", (char*)NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itk_ArchCompAddCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Adds a new component widget into the mega-widget, * integrating its configuration options into the master list. * * itk_component add ?-protected? ?-private? ?--? \ * * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchCompAddCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { Tcl_HashEntry *entry = NULL; char *path = NULL; ArchComponent *archComp = NULL; ArchMergeInfo *mergeInfo = NULL; Tcl_Obj *objNamePtr = NULL; Tcl_Obj *tmpNamePtr = NULL; Tcl_Obj *winNamePtr = NULL; Tcl_Obj *hullNamePtr = NULL; int pLevel = ITCL_PUBLIC; int newEntry, result; CONST char *cmd, *token, *resultStr; char *name; Tcl_Namespace *parserNs; ItclClass *contextClass, *ownerClass; ItclObject *contextObj; ArchInfo *info; Itcl_CallFrame frame, *uplevelFramePtr, *oldFramePtr; Tcl_Command accessCmd; Tcl_Obj *objPtr; Tcl_DString buffer; /* * Get the Archetype info associated with this widget. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access components without an object context", (char*)NULL); return TCL_ERROR; } if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) { return TCL_ERROR; } /* * Look for options like "-protected" or "-private". */ cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); while (objc > 1) { token = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (*token != '-') { break; } else if (strcmp(token,"-protected") == 0) { pLevel = ITCL_PROTECTED; } else if (strcmp(token,"-private") == 0) { pLevel = ITCL_PRIVATE; } else if (strcmp(token,"--") == 0) { objc--; objv++; break; } else { Tcl_AppendResult(interp, "bad option \"", token, "\": should be -private, -protected or --", (char*)NULL); return TCL_ERROR; } objc--; objv++; } if (objc < 3 || objc > 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", cmd, " ?-protected? ?-private? ?--? name createCmds ?optionCmds?", (char*)NULL); return TCL_ERROR; } /* * See if a component already exists with the symbolic name. */ name = Tcl_GetStringFromObj(objv[1], (int*)NULL); entry = Tcl_CreateHashEntry(&info->components, name, &newEntry); if (!newEntry) { Tcl_AppendResult(interp, "component \"", name, "\" already defined", (char*)NULL); return TCL_ERROR; } /* * If this component is the "hull" for the mega-widget, then * move the object access command out of the way before * creating the component, so it is not accidentally deleted. */ Tcl_DStringInit(&buffer); objNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objNamePtr); Tcl_IncrRefCount(objNamePtr); if (strcmp(name, "hull") == 0) { tmpNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, tmpNamePtr); Tcl_AppendToObj(tmpNamePtr, "-widget-", -1); Tcl_IncrRefCount(tmpNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(objNamePtr, (int*)NULL), Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } } /* * Execute the to create the component widget. * Do this one level up, in the scope of the calling routine. */ uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr); if (Tcl_EvalObj(interp, objv[2]) != TCL_OK) { goto compFail; } /* * Take the result from the widget creation commands as the * path name for the new component. Make a local copy of * this, since the interpreter will get used in the mean time. */ resultStr = Tcl_GetStringResult(interp); path = (char*)ckalloc((unsigned)(strlen(resultStr)+1)); strcpy(path, resultStr); /* * Look for the access command token in the context of the * calling namespace. By-pass any protection at this point. */ accessCmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL, /* flags */ 0); if (!accessCmd) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot find component access command \"", path, "\" for component \"", name, "\"", (char*)NULL); goto compFail; } winNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, accessCmd, winNamePtr); Tcl_IncrRefCount(winNamePtr); (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); /* * Create the component record. Set the protection level * according to the "-protected" or "-private" option. */ ownerClass = contextClass; uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); if (uplevelFramePtr && Itcl_IsClassNamespace(uplevelFramePtr->nsPtr)) { ownerClass = (ItclClass*)uplevelFramePtr->nsPtr->clientData; } archComp = Itk_CreateArchComponent(interp, info, name, ownerClass, accessCmd); if (!archComp) { goto compFail; } Tcl_SetHashValue(entry, (ClientData)archComp); archComp->member->protection = pLevel; /* * If this component is the "hull" for the mega-widget, then * move the hull widget access command to a different name, * and move the object access command back into place. This * way, when the widget name is used as a command, the object * access command will handle all requests. */ if (strcmp(name, "hull") == 0) { hullNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, accessCmd, hullNamePtr); Tcl_AppendToObj(hullNamePtr, "-itk_hull", -1); Tcl_IncrRefCount(hullNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(winNamePtr, (int*)NULL), Tcl_GetStringFromObj(hullNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } Tcl_DecrRefCount(winNamePtr); /* winNamePtr keeps current name */ winNamePtr = hullNamePtr; hullNamePtr = NULL; result = TclRenameCommand(interp, Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL), Tcl_GetStringFromObj(objNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } } /* * Add a binding onto the new component, so that when its * window is destroyed, it will automatically remove itself * from its parent's component list. Avoid doing these things * for the "hull" component, since it is a special case and * these things are not really necessary. */ else { Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, "bindtags ", -1); Tcl_DStringAppend(&buffer, path, -1); if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) { goto compFail; } Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, "bind itk-destroy-", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " [itcl::code ", -1); Tcl_DStringAppend(&buffer, Tcl_GetStringFromObj(objNamePtr,(int*)NULL), -1); Tcl_DStringAppend(&buffer, " itk_component delete ", -1); Tcl_DStringAppend(&buffer, name, -1); Tcl_DStringAppend(&buffer, "]\n", -1); Tcl_DStringAppend(&buffer, "bindtags ", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " {itk-destroy-", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " ", -1); Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1); Tcl_DStringAppend(&buffer, "}", -1); if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) { goto compFail; } } /* * Query the list of configuration options for this widget, * so we will know which ones are valid. Build an option * table to represent these, so they can be found quickly * by the option parsing commands in "itk::option-parser". */ Tcl_DStringTrunc(&buffer, 0); Tcl_DStringAppendElement(&buffer, Tcl_GetStringFromObj(winNamePtr, (int*)NULL)); Tcl_DStringAppendElement(&buffer, "configure"); result = Tcl_Eval(interp, Tcl_DStringValue(&buffer)); if (result != TCL_OK) { goto compFail; } Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1); /* * Find the "itk::option-parser" namespace and get the data * record shared by all of the parsing commands. */ parserNs = Tcl_FindNamespace(interp, "::itk::option-parser", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (!parserNs) { goto compFail; } mergeInfo = (ArchMergeInfo*)parserNs->clientData; assert(mergeInfo); /* * Initialize the data record used by the option parsing commands. * Store a table of valid configuration options, along with the * info for the mega-widget that is being updated. */ mergeInfo->optionTable = Itk_CreateGenericOptTable(interp, Tcl_DStringValue(&buffer)); if (!mergeInfo->optionTable) { goto compFail; } mergeInfo->archInfo = info; mergeInfo->archComp = archComp; /* * Execute the option-handling commands in the "itk::option-parser" * namespace. If there are no option-handling commands, invoke * the "usual" command instead. */ if (objc != 4) { objPtr = Tcl_NewStringObj("usual", -1); Tcl_IncrRefCount(objPtr); } else { objPtr = objv[3]; } result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, parserNs, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = Tcl_EvalObj(interp, objPtr); Tcl_PopCallFrame(interp); } if (objPtr != objv[3]) { Tcl_DecrRefCount(objPtr); } if (result != TCL_OK) { goto compFail; } Itk_DelGenericOptTable(mergeInfo->optionTable); mergeInfo->optionTable = NULL; mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; ckfree(path); Tcl_DStringFree(&buffer); if (objNamePtr) { Tcl_DecrRefCount(objNamePtr); } if (tmpNamePtr) { Tcl_DecrRefCount(tmpNamePtr); } if (winNamePtr) { Tcl_DecrRefCount(winNamePtr); } if (hullNamePtr) { Tcl_DecrRefCount(hullNamePtr); } Tcl_SetResult(interp, name, TCL_VOLATILE); return TCL_OK; /* * If any errors were encountered, clean up and return. */ compFail: if (archComp) { Itk_DelArchComponent(archComp); } if (entry) { Tcl_DeleteHashEntry(entry); } if (path) { ckfree(path); } if (mergeInfo && mergeInfo->optionTable) { Itk_DelGenericOptTable(mergeInfo->optionTable); mergeInfo->optionTable = NULL; mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; } Tcl_DStringFree(&buffer); if (objNamePtr) { Tcl_DecrRefCount(objNamePtr); } if (tmpNamePtr) { Tcl_DecrRefCount(tmpNamePtr); } if (winNamePtr) { Tcl_DecrRefCount(winNamePtr); } if (hullNamePtr) { Tcl_DecrRefCount(hullNamePtr); } /* * Add error info and return. */ objPtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_AppendToObj(objPtr, "\n (while creating component \"", -1); Tcl_AppendToObj(objPtr, name, -1); Tcl_AppendToObj(objPtr, "\" for widget \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\")", -1); Tcl_IncrRefCount(objPtr); Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itk_ArchCompDeleteCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Removes an existing component widget from a mega-widget, * and removes any configuration options associated with it. * * itk_component delete ? ...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchCompDeleteCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int i; char *token; ItclClass *contextClass; ItclObject *contextObj; ArchInfo *info; Tcl_HashEntry *entry; Tcl_HashSearch place; Itcl_ListElem *elem; ArchComponent *archComp; ArchOption *archOpt; ArchOptionPart *optPart; Itcl_List delOptList; Tcl_DString buffer; /* * Get the Archetype info associated with this widget. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access components without an object context", (char*)NULL); return TCL_ERROR; } if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) { return TCL_ERROR; } /* * Scan through the list of component names and delete each * one. Make sure that each component exists. */ for (i=1; i < objc; i++) { token = Tcl_GetStringFromObj(objv[i], (int*)NULL); entry = Tcl_FindHashEntry(&info->components, token); if (!entry) { Tcl_AppendResult(interp, "name \"", token, "\" is not a component", (char*)NULL); return TCL_ERROR; } archComp = (ArchComponent*)Tcl_GetHashValue(entry); /* * Clean up the binding tag that causes the widget to * call this method automatically when destroyed. * Ignore errors if anything goes wrong. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "itk::remove_destroy_hook ", -1); Tcl_DStringAppend(&buffer, archComp->pathName, -1); (void) Tcl_Eval(interp, Tcl_DStringValue(&buffer)); Tcl_ResetResult(interp); Tcl_DStringFree(&buffer); Tcl_UnsetVar2(interp, "itk_component", token, 0); Tcl_DeleteHashEntry(entry); /* * Clean up the options that belong to the component. Do this * by scanning through all available options and looking for * those that belong to the component. If we remove them as * we go, we'll mess up Tcl_NextHashEntry. So instead, we * build up a list of options to remove, and then remove the * options below. */ Itcl_InitList(&delOptList); entry = Tcl_FirstHashEntry(&info->options, &place); while (entry) { archOpt = (ArchOption*)Tcl_GetHashValue(entry); elem = Itcl_FirstListElem(&archOpt->parts); while (elem) { optPart = (ArchOptionPart*)Itcl_GetListValue(elem); if (optPart->from == (ClientData)archComp) { Itcl_AppendList(&delOptList, (ClientData)entry); } elem = Itcl_NextListElem(elem); } entry = Tcl_NextHashEntry(&place); } /* * Now that we've figured out which options to delete, * go through the list and remove them. */ elem = Itcl_FirstListElem(&delOptList); while (elem) { entry = (Tcl_HashEntry*)Itcl_GetListValue(elem); token = Tcl_GetHashKey(&info->options, entry); Itk_RemoveArchOptionPart(info, token, (ClientData)archComp); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&delOptList); Itk_DelArchComponent(archComp); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_ArchOptKeepCmd() * * Invoked by [incr Tcl] to handle the "keep" command in the itk * option parser. Integrates a list of component configuration options * into a mega-widget, so that whenever the mega-widget is updated, * the component will be updated as well. * * Handles the following syntax: * * keep