1/*
2 * ------------------------------------------------------------------------
3 *      PACKAGE:  [incr Tk]
4 *  DESCRIPTION:  Building mega-widgets with [incr Tcl]
5 *
6 *  [incr Tk] provides a framework for building composite "mega-widgets"
7 *  using [incr Tcl] classes.  It defines a set of base classes that are
8 *  specialized to create all other widgets.
9 *
10 *  This part adds C implementations for some of the methods in the
11 *  base class itk::Archetype.
12 *
13 *    Itk_ArchComponentCmd   <=> itk_component
14 *    Itk_ArchOptionCmd      <=> itk_option
15 *    Itk_ArchInitCmd        <=> itk_initialize
16 *    Itk_ArchCompAccessCmd  <=> component
17 *    Itk_ArchConfigureCmd   <=> configure
18 *    Itk_ArchCgetCmd        <=> cget
19 *
20 *    Itk_ArchInitOptsCmd    <=> _initOptionInfo (used to set things up)
21 *    Itk_ArchDeleteOptsCmd  <=> _deleteOptionInfo (used to clean things up)
22 *
23 * ========================================================================
24 *  AUTHOR:  Michael J. McLennan
25 *           Bell Labs Innovations for Lucent Technologies
26 *           mmclennan@lucent.com
27 *           http://www.tcltk.com/itcl
28 *
29 *     RCS:  $Id: itk_archetype.c,v 1.12 2007/05/24 22:12:55 hobbs Exp $
30 * ========================================================================
31 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
32 * ------------------------------------------------------------------------
33 * See the file "license.terms" for information on usage and redistribution
34 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
35 */
36#include <assert.h>
37#include "itk.h"
38
39/*
40 *  Info associated with each Archetype mega-widget:
41 */
42typedef struct ArchInfo {
43    ItclObject *itclObj;        /* object containing this info */
44    Tk_Window tkwin;            /* window representing this mega-widget */
45    Tcl_HashTable components;   /* list of all mega-widget components */
46    Tcl_HashTable options;      /* list of all mega-widget options */
47    ItkOptList order;           /* gives ordering of options */
48} ArchInfo;
49
50/*
51 *  Each component widget in an Archetype mega-widget:
52 */
53typedef struct ArchComponent {
54    ItclMember *member;         /* contains protection level for this comp */
55    Tcl_Command accessCmd;      /* access command for component widget */
56    Tk_Window tkwin;            /* Tk window for this component widget */
57    char *pathName;             /* Tk path name for this component widget.
58                                   We can't use the tkwin pointer after
59                                   the window has been destroyed so we
60                                   need to save a copy for use in
61                                   Itk_ArchCompDeleteCmd() */
62} ArchComponent;
63
64/*
65 *  Each option in an Archetype mega-widget:
66 */
67typedef struct ArchOption {
68    char *switchName;           /* command-line switch for this option */
69    char *resName;              /* resource name in X11 database */
70    char *resClass;             /* resource class name in X11 database */
71    char *init;                 /* initial value for option */
72    int flags;                  /* flags representing option state */
73    Itcl_List parts;            /* parts relating to this option */
74} ArchOption;
75
76/*
77 *  Flag bits for ArchOption state:
78 */
79#define ITK_ARCHOPT_INIT  0x01  /* option has been initialized */
80
81/*
82 *  Various parts of a composite option in an Archetype mega-widget:
83 */
84typedef int (Itk_ConfigOptionPartProc) _ANSI_ARGS_((Tcl_Interp *interp,
85    ItclObject *contextObj, ClientData cdata, CONST char* newVal));
86
87typedef struct ArchOptionPart {
88    ClientData clientData;                 /* data associated with this part */
89    Itk_ConfigOptionPartProc *configProc;  /* update when new vals arrive */
90    Tcl_CmdDeleteProc *deleteProc;         /* clean up after clientData */
91
92    ClientData from;                       /* token that indicates who
93                                            * contributed this option part */
94} ArchOptionPart;
95
96
97/*
98 *  Info kept by the itk::option-parser namespace and shared by
99 *  all option processing commands:
100 */
101typedef struct ArchMergeInfo {
102    Tcl_HashTable usualCode;      /* usual option handling code for the
103                                   * various widget classes */
104
105    ArchInfo *archInfo;           /* internal option info for mega-widget */
106    ArchComponent *archComp;      /* component being merged into mega-widget */
107    Tcl_HashTable *optionTable;   /* table of valid configuration options
108                                   * for component being merged */
109} ArchMergeInfo;
110
111/*
112 *  Used to capture component widget configuration options when a
113 *  new component is being merged into a mega-widget:
114 */
115typedef struct GenericConfigOpt {
116    char *switchName;             /* command-line switch for this option */
117    char *resName;                /* resource name in X11 database */
118    char *resClass;               /* resource class name in X11 database */
119    char *init;                   /* initial value for this option */
120    char *value;                  /* current value for this option */
121    char **storage;               /* storage for above strings */
122
123    ArchOption *integrated;       /* integrated into this mega-widget option */
124    ArchOptionPart *optPart;      /* integrated as this option part */
125} GenericConfigOpt;
126
127/*
128 *  Options that are propagated by a "configure" method:
129 */
130typedef struct ConfigCmdline {
131    Tcl_Obj *objv[4];           /* objects representing "configure" command */
132} ConfigCmdline;
133
134
135/*
136 *  FORWARD DECLARATIONS
137 */
138static void Itk_DelMergeInfo _ANSI_ARGS_((char* cdata));
139
140static int Itk_ArchInitOptsCmd _ANSI_ARGS_((ClientData cdata,
141    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
142static void Itk_DelArchInfo _ANSI_ARGS_((ClientData cdata));
143static int Itk_ArchDeleteOptsCmd _ANSI_ARGS_((ClientData cdata,
144    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
145
146static int Itk_ArchComponentCmd _ANSI_ARGS_((ClientData cdata,
147    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
148static int Itk_ArchCompAddCmd _ANSI_ARGS_((ClientData cdata,
149    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
150static int Itk_ArchCompDeleteCmd _ANSI_ARGS_((ClientData cdata,
151    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
152static int Itk_ArchOptKeepCmd _ANSI_ARGS_((ClientData cdata,
153    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
154static int Itk_ArchOptIgnoreCmd _ANSI_ARGS_((ClientData cdata,
155    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
156static int Itk_ArchOptRenameCmd _ANSI_ARGS_((ClientData cdata,
157    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
158static int Itk_ArchOptUsualCmd _ANSI_ARGS_((ClientData cdata,
159    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
160
161static int Itk_ArchInitCmd _ANSI_ARGS_((ClientData cdata,
162    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
163static int Itk_ArchOptionCmd _ANSI_ARGS_((ClientData cdata,
164    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
165static int Itk_ArchOptionAddCmd _ANSI_ARGS_((ClientData cdata,
166    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
167static int Itk_ArchOptionRemoveCmd _ANSI_ARGS_((ClientData cdata,
168    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
169
170static int Itk_ArchCompAccessCmd _ANSI_ARGS_((ClientData cdata,
171    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
172static int Itk_ArchConfigureCmd _ANSI_ARGS_((ClientData cdata,
173    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
174static int Itk_ArchCgetCmd _ANSI_ARGS_((ClientData cdata,
175    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
176static int Itk_PropagateOption _ANSI_ARGS_((Tcl_Interp *interp,
177    ItclObject *contextObj, ClientData cdata, CONST char *newval));
178static int Itk_PropagatePublicVar _ANSI_ARGS_((Tcl_Interp *interp,
179    ItclObject *contextObj, ClientData cdata, CONST char *newval));
180
181static int Itk_ArchSetOption _ANSI_ARGS_((Tcl_Interp *interp,
182    ArchInfo *info, CONST char *name, CONST char *value));
183static int Itk_ArchConfigOption _ANSI_ARGS_((Tcl_Interp *interp,
184    ArchInfo *info, char *name, char *value));
185static void Itk_ArchOptConfigError _ANSI_ARGS_((Tcl_Interp *interp,
186    ArchInfo *info, ArchOption *archOpt));
187static void Itk_ArchOptAccessError _ANSI_ARGS_((Tcl_Interp *interp,
188    ArchInfo *info, ArchOption *archOpt));
189
190static int Itk_GetArchInfo _ANSI_ARGS_((Tcl_Interp *interp,
191    ItclObject* contextObj, ArchInfo **infoPtr));
192
193static ArchComponent* Itk_CreateArchComponent _ANSI_ARGS_((
194    Tcl_Interp *interp, ArchInfo *info, char *name,
195    ItclClass *cdefn, Tcl_Command accessCmd));
196static void Itk_DelArchComponent _ANSI_ARGS_((ArchComponent *archComp));
197
198static int Itk_GetArchOption _ANSI_ARGS_((Tcl_Interp *interp,
199    ArchInfo *info, char *switchName, char *resName, char *resClass,
200    CONST char *defVal, char *currVal, ArchOption **aoPtr));
201static void Itk_InitArchOption _ANSI_ARGS_((Tcl_Interp *interp,
202    ArchInfo *info, ArchOption *archOpt, CONST char *defVal,
203    char *currVal));
204static void Itk_DelArchOption _ANSI_ARGS_((ArchOption *archOpt));
205
206static ArchOptionPart* Itk_CreateOptionPart _ANSI_ARGS_((
207    Tcl_Interp *interp, ClientData cdata, Itk_ConfigOptionPartProc* cproc,
208    Tcl_CmdDeleteProc *dproc, ClientData from));
209static int Itk_AddOptionPart _ANSI_ARGS_((Tcl_Interp *interp,
210    ArchInfo *info, char *switchName, char *resName, char *resClass,
211    CONST char *defVal, char *currVal, ArchOptionPart *optPart,
212    ArchOption **raOpt));
213static ArchOptionPart* Itk_FindArchOptionPart _ANSI_ARGS_((
214    ArchInfo *info, char *switchName, ClientData from));
215static int Itk_RemoveArchOptionPart _ANSI_ARGS_((ArchInfo *info,
216    char *switchName, ClientData from));
217static int Itk_IgnoreArchOptionPart _ANSI_ARGS_((ArchInfo *info,
218    GenericConfigOpt *opt));
219static void Itk_DelOptionPart _ANSI_ARGS_((ArchOptionPart *optPart));
220
221static ConfigCmdline* Itk_CreateConfigCmdline _ANSI_ARGS_((
222    Tcl_Interp *interp, Tcl_Command accessCmd, char *switchName));
223static void Itk_DeleteConfigCmdline _ANSI_ARGS_((ClientData cdata));
224
225static Tcl_HashTable* Itk_CreateGenericOptTable _ANSI_ARGS_((Tcl_Interp *interp,
226    char *options));
227static void Itk_DelGenericOptTable _ANSI_ARGS_((Tcl_HashTable *tPtr));
228
229static GenericConfigOpt* Itk_CreateGenericOpt _ANSI_ARGS_((Tcl_Interp *interp,
230    char *switchName, Tcl_Command accessCmd));
231static void Itk_DelGenericOpt _ANSI_ARGS_((GenericConfigOpt* opt));
232
233static Tcl_HashTable* ItkGetObjsWithArchInfo _ANSI_ARGS_((Tcl_Interp *interp));
234static void ItkFreeObjsWithArchInfo _ANSI_ARGS_((ClientData cdata,
235    Tcl_Interp *interp));
236
237
238/*
239 * ------------------------------------------------------------------------
240 *  Itk_ArchetypeInit()
241 *
242 *  Invoked by Itk_Init() whenever a new interpreter is created to
243 *  declare the procedures used in the itk::Archetype base class.
244 * ------------------------------------------------------------------------
245 */
246int
247Itk_ArchetypeInit(interp)
248    Tcl_Interp *interp;  /* interpreter to be updated */
249{
250    ArchMergeInfo *mergeInfo;
251    Tcl_Namespace *parserNs;
252
253    /*
254     *  Declare all of the C routines that are integrated into
255     *  the Archetype base class.
256     */
257    if (Itcl_RegisterObjC(interp,
258            "Archetype-init", Itk_ArchInitOptsCmd,
259            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
260
261        Itcl_RegisterObjC(interp,
262            "Archetype-delete", Itk_ArchDeleteOptsCmd,
263            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
264
265        Itcl_RegisterObjC(interp,
266            "Archetype-itk_component", Itk_ArchComponentCmd,
267            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
268
269        Itcl_RegisterObjC(interp,
270            "Archetype-itk_option", Itk_ArchOptionCmd,
271            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
272
273        Itcl_RegisterObjC(interp,
274            "Archetype-itk_initialize", Itk_ArchInitCmd,
275            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
276
277        Itcl_RegisterObjC(interp,
278            "Archetype-component", Itk_ArchCompAccessCmd,
279            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
280
281        Itcl_RegisterObjC(interp,
282            "Archetype-configure",Itk_ArchConfigureCmd,
283            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||
284
285        Itcl_RegisterObjC(interp,
286            "Archetype-cget",Itk_ArchCgetCmd,
287            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
288
289        return TCL_ERROR;
290    }
291
292    /*
293     *  Create the namespace containing the option parser commands.
294     */
295    mergeInfo = (ArchMergeInfo*)ckalloc(sizeof(ArchMergeInfo));
296    Tcl_InitHashTable(&mergeInfo->usualCode, TCL_STRING_KEYS);
297    mergeInfo->archInfo    = NULL;
298    mergeInfo->archComp    = NULL;
299    mergeInfo->optionTable = NULL;
300
301    parserNs = Tcl_CreateNamespace(interp, "::itk::option-parser",
302        (ClientData)mergeInfo, Itcl_ReleaseData);
303
304    if (!parserNs) {
305        Itk_DelMergeInfo((char*)mergeInfo);
306        Tcl_AddErrorInfo(interp, "\n    (while initializing itk)");
307        return TCL_ERROR;
308    }
309    Itcl_PreserveData((ClientData)mergeInfo);
310    Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo);
311
312    Tcl_CreateObjCommand(interp, "::itk::option-parser::keep",
313        Itk_ArchOptKeepCmd,
314        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);
315
316    Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore",
317        Itk_ArchOptIgnoreCmd,
318        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);
319
320    Tcl_CreateObjCommand(interp, "::itk::option-parser::rename",
321        Itk_ArchOptRenameCmd,
322        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);
323
324    Tcl_CreateObjCommand(interp, "::itk::option-parser::usual",
325        Itk_ArchOptUsualCmd,
326        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);
327
328    /*
329     *  Add the "itk::usual" command to register option handling code.
330     */
331    Tcl_CreateObjCommand(interp, "::itk::usual", Itk_UsualCmd,
332        (ClientData)mergeInfo, Itcl_ReleaseData);
333    Itcl_PreserveData((ClientData)mergeInfo);
334
335    return TCL_OK;
336}
337
338
339/*
340 * ------------------------------------------------------------------------
341 *  Itk_DelMergeInfo()
342 *
343 *  Destroys the "merge" info record shared by commands in the
344 *  itk::option-parser namespace.  Invoked automatically when the
345 *  namespace containing the parsing commands is destroyed and there
346 *  are no more uses of the data.
347 * ------------------------------------------------------------------------
348 */
349static void
350Itk_DelMergeInfo(cdata)
351    char* cdata;  /* data to be destroyed */
352{
353    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)cdata;
354
355    Tcl_HashEntry *entry;
356    Tcl_HashSearch place;
357    Tcl_Obj *codePtr;
358
359    assert(mergeInfo->optionTable == NULL);
360
361    entry = Tcl_FirstHashEntry(&mergeInfo->usualCode, &place);
362    while (entry) {
363        codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
364        Tcl_DecrRefCount(codePtr);
365        entry = Tcl_NextHashEntry(&place);
366    }
367    Tcl_DeleteHashTable(&mergeInfo->usualCode);
368
369    ckfree((char*)mergeInfo);
370}
371
372
373/*
374 * ------------------------------------------------------------------------
375 *  Itk_ArchInitOptsCmd()
376 *
377 *  Invoked by [incr Tcl] to handle the itk::Archetype::_initOptionInfo
378 *  method.  This method should be called out in the constructor for
379 *  each object, to initialize the object so that it can be used with
380 *  the other access methods in this file.  Allocates some extra
381 *  data associated with the object at the C-language level.
382 *
383 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
384 * ------------------------------------------------------------------------
385 */
386/* ARGSUSED */
387static int
388Itk_ArchInitOptsCmd(dummy, interp, objc, objv)
389    ClientData dummy;        /* unused */
390    Tcl_Interp *interp;      /* current interpreter */
391    int objc;                /* number of arguments */
392    Tcl_Obj *CONST objv[];   /* argument objects */
393{
394    int newEntry, result;
395    ArchInfo *info;
396    ItclClass *contextClass;
397    ItclObject *contextObj;
398    Tcl_HashTable *objsWithArchInfo;
399    Tcl_HashEntry *entry;
400    Command *cmdPtr;
401
402    if (objc != 1) {
403        Tcl_WrongNumArgs(interp, 1, objv, "");
404        return TCL_ERROR;
405    }
406
407    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
408        !contextObj) {
409
410        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
411        Tcl_ResetResult(interp);
412        Tcl_AppendResult(interp,
413            "cannot use \"", token, "\" without an object context",
414            (char*)NULL);
415        return TCL_ERROR;
416    }
417
418    /*
419     *  Create some archetype info for the current object and
420     *  register it on the list of all known objects.
421     */
422    objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
423
424    info = (ArchInfo*)ckalloc(sizeof(ArchInfo));
425    info->itclObj = contextObj;
426    info->tkwin = NULL;  /* not known yet */
427    Tcl_InitHashTable(&info->components, TCL_STRING_KEYS);
428    Tcl_InitHashTable(&info->options, TCL_STRING_KEYS);
429    Itk_OptListInit(&info->order, &info->options);
430
431    entry = Tcl_CreateHashEntry(objsWithArchInfo, (char*)contextObj, &newEntry);
432    if (!newEntry) {
433        Itk_DelArchInfo( Tcl_GetHashValue(entry) );
434    }
435    Tcl_SetHashValue(entry, (ClientData)info);
436
437    /*
438     *  Make sure that the access command for this object
439     *  resides in the global namespace.  If need be, move
440     *  the command.
441     */
442    result = TCL_OK;
443    cmdPtr = (Command*)contextObj->accessCmd;
444
445    if (cmdPtr->nsPtr != (Namespace*)Tcl_GetGlobalNamespace(interp)) {
446        Tcl_Obj *oldNamePtr, *newNamePtr;
447
448        oldNamePtr = Tcl_NewStringObj((char*)NULL, 0);
449        Tcl_GetCommandFullName(interp, contextObj->accessCmd, oldNamePtr);
450        Tcl_IncrRefCount(oldNamePtr);
451
452        newNamePtr = Tcl_NewStringObj("::", -1);
453        Tcl_AppendToObj(newNamePtr,
454            Tcl_GetCommandName(interp, contextObj->accessCmd), -1);
455        Tcl_IncrRefCount(newNamePtr);
456
457        result = TclRenameCommand(interp,
458            Tcl_GetStringFromObj(oldNamePtr, (int*)NULL),
459            Tcl_GetStringFromObj(newNamePtr, (int*)NULL));
460
461        Tcl_DecrRefCount(oldNamePtr);
462        Tcl_DecrRefCount(newNamePtr);
463    }
464
465    return result;
466}
467
468
469/*
470 * ------------------------------------------------------------------------
471 *  Itk_DelArchInfo()
472 *
473 *  Invoked when the option info associated with an itk::Archetype
474 *  widget is no longer needed.  This usually happens when a widget
475 *  is destroyed.  Frees the given bundle of data and removes it
476 *  from the global list of Archetype objects.
477 * ------------------------------------------------------------------------
478 */
479static void
480Itk_DelArchInfo(cdata)
481    ClientData cdata;    /* client data for Archetype objects */
482{
483    ArchInfo *info = (ArchInfo*)cdata;
484
485    Tcl_HashEntry *entry;
486    Tcl_HashSearch place;
487    ArchOption *archOpt;
488    ArchComponent *archComp;
489
490    /*
491     *  Destroy all component widgets.
492     */
493    entry = Tcl_FirstHashEntry(&info->components, &place);
494    while (entry) {
495        archComp = (ArchComponent*)Tcl_GetHashValue(entry);
496        Itk_DelArchComponent(archComp);
497        entry = Tcl_NextHashEntry(&place);
498    }
499    Tcl_DeleteHashTable(&info->components);
500
501    /*
502     *  Destroy all information associated with configuration options.
503     */
504    entry = Tcl_FirstHashEntry(&info->options, &place);
505    while (entry) {
506        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
507        Itk_DelArchOption(archOpt);
508        entry = Tcl_NextHashEntry(&place);
509    }
510    Tcl_DeleteHashTable(&info->options);
511    Itk_OptListFree(&info->order);
512
513    ckfree((char*)info);
514}
515
516
517/*
518 * ------------------------------------------------------------------------
519 *  Itk_ArchDeleteOptsCmd()
520 *
521 *  Invoked by [incr Tcl] to handle the itk::Archetype::_deleteOptionInfo
522 *  method.  This method should be called out in the destructor for each
523 *  object, to clean up data allocated by Itk_ArchInitOptsCmd().
524 *
525 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
526 * ------------------------------------------------------------------------
527 */
528/* ARGSUSED */
529static int
530Itk_ArchDeleteOptsCmd(dummy, interp, objc, objv)
531    ClientData dummy;        /* unused */
532    Tcl_Interp *interp;      /* current interpreter */
533    int objc;                /* number of arguments */
534    Tcl_Obj *CONST objv[];   /* argument objects */
535{
536    ItclClass *contextClass;
537    ItclObject *contextObj;
538    Tcl_HashTable *objsWithArchInfo;
539    Tcl_HashEntry *entry;
540
541    if (objc != 1) {
542        Tcl_WrongNumArgs(interp, 1, objv, "");
543        return TCL_ERROR;
544    }
545    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
546        !contextObj) {
547
548        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
549        Tcl_ResetResult(interp);
550        Tcl_AppendResult(interp,
551            "cannot use \"", token, "\" without an object context",
552            (char*)NULL);
553        return TCL_ERROR;
554    }
555
556    /*
557     *  Find the info associated with this object.
558     *  Destroy the data and remove it from the global list.
559     */
560    objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
561    entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);
562
563    if (entry) {
564        Itk_DelArchInfo( Tcl_GetHashValue(entry) );
565        Tcl_DeleteHashEntry(entry);
566    }
567    return TCL_OK;
568}
569
570
571/*
572 * ------------------------------------------------------------------------
573 *  Itk_ArchComponentCmd()
574 *
575 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
576 *  method.  Handles the following options:
577 *
578 *      itk_component add ?-protected? ?-private? ?--? <name> \
579 *          <createCmds> ?<optionCmds>?
580 *
581 *      itk_component delete <name> ?<name>...?
582 *
583 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
584 * ------------------------------------------------------------------------
585 */
586/* ARGSUSED */
587static int
588Itk_ArchComponentCmd(dummy, interp, objc, objv)
589    ClientData dummy;        /* unused */
590    Tcl_Interp *interp;      /* current interpreter */
591    int objc;                /* number of arguments */
592    Tcl_Obj *CONST objv[];   /* argument objects */
593{
594    char *cmd, *token, c;
595    int length;
596
597    /*
598     *  Check arguments and handle the various options...
599     */
600    if (objc < 2) {
601        cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
602        Tcl_AppendResult(interp,
603            "wrong # args: should be one of...\n",
604            "  ", cmd, " add ?-protected? ?-private? ?--? name createCmds ?optionCmds?\n",
605            "  ", cmd, " delete name ?name name...?",
606            (char*)NULL);
607        return TCL_ERROR;
608    }
609
610    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
611    c = *token;
612    length = strlen(token);
613
614    /*
615     *  Handle:  itk_component add...
616     */
617    if (c == 'a' && strncmp(token, "add", length) == 0) {
618        if (objc < 4) {
619            Tcl_WrongNumArgs(interp, 1, objv,
620                "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?");
621            return TCL_ERROR;
622        }
623        return Itk_ArchCompAddCmd(dummy, interp, objc-1, objv+1);
624    }
625
626    /*
627     *  Handle:  itk_component delete...
628     */
629    else if (c == 'd' && strncmp(token, "delete", length) == 0) {
630        if (objc < 3) {
631            Tcl_WrongNumArgs(interp, 1, objv, "delete name ?name name...?");
632            return TCL_ERROR;
633        }
634        return Itk_ArchCompDeleteCmd(dummy, interp, objc-1, objv+1);
635    }
636
637    /*
638     *  Flag any errors.
639     */
640    cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
641    Tcl_AppendResult(interp,
642        "bad option \"", token,
643        "\": should be one of...\n",
644        "  ", cmd, " add name createCmds ?optionCmds?\n",
645        "  ", cmd, " delete name ?name name...?",
646        (char*)NULL);
647    return TCL_ERROR;
648}
649
650
651/*
652 * ------------------------------------------------------------------------
653 *  Itk_ArchCompAddCmd()
654 *
655 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
656 *  method.  Adds a new component widget into the mega-widget,
657 *  integrating its configuration options into the master list.
658 *
659 *      itk_component add ?-protected? ?-private? ?--? <name> \
660 *          <createCmds> <optionCmds>
661 *
662 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
663 * ------------------------------------------------------------------------
664 */
665/* ARGSUSED */
666static int
667Itk_ArchCompAddCmd(dummy, interp, objc, objv)
668    ClientData dummy;        /* unused */
669    Tcl_Interp *interp;      /* current interpreter */
670    int objc;                /* number of arguments */
671    Tcl_Obj *CONST objv[];   /* argument objects */
672{
673    Tcl_HashEntry *entry = NULL;
674    char *path = NULL;
675    ArchComponent *archComp = NULL;
676    ArchMergeInfo *mergeInfo = NULL;
677    Tcl_Obj *objNamePtr = NULL;
678    Tcl_Obj *tmpNamePtr = NULL;
679    Tcl_Obj *winNamePtr = NULL;
680    Tcl_Obj *hullNamePtr = NULL;
681    int pLevel = ITCL_PUBLIC;
682
683    int newEntry, result;
684    CONST char *cmd, *token, *resultStr;
685    char *name;
686    Tcl_Namespace *parserNs;
687    ItclClass *contextClass, *ownerClass;
688    ItclObject *contextObj;
689    ArchInfo *info;
690    Itcl_CallFrame frame, *uplevelFramePtr, *oldFramePtr;
691    Tcl_Command accessCmd;
692    Tcl_Obj *objPtr;
693    Tcl_DString buffer;
694
695    /*
696     *  Get the Archetype info associated with this widget.
697     */
698    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
699        !contextObj) {
700
701        Tcl_ResetResult(interp);
702        Tcl_AppendResult(interp,
703            "cannot access components without an object context",
704            (char*)NULL);
705        return TCL_ERROR;
706    }
707
708    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
709        return TCL_ERROR;
710    }
711
712    /*
713     *  Look for options like "-protected" or "-private".
714     */
715    cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
716
717    while (objc > 1) {
718        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
719        if (*token != '-') {
720            break;
721        }
722        else if (strcmp(token,"-protected") == 0) {
723            pLevel = ITCL_PROTECTED;
724        }
725        else if (strcmp(token,"-private") == 0) {
726            pLevel = ITCL_PRIVATE;
727        }
728        else if (strcmp(token,"--") == 0) {
729            objc--;
730            objv++;
731            break;
732        }
733        else {
734            Tcl_AppendResult(interp,
735                "bad option \"", token,
736                "\": should be -private, -protected or --",
737                (char*)NULL);
738            return TCL_ERROR;
739        }
740        objc--;
741        objv++;
742    }
743
744    if (objc < 3 || objc > 4) {
745        Tcl_AppendResult(interp,
746            "wrong # args: should be \"", cmd,
747            " ?-protected? ?-private? ?--? name createCmds ?optionCmds?",
748            (char*)NULL);
749        return TCL_ERROR;
750    }
751
752    /*
753     *  See if a component already exists with the symbolic name.
754     */
755    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
756    entry = Tcl_CreateHashEntry(&info->components, name, &newEntry);
757    if (!newEntry) {
758        Tcl_AppendResult(interp,
759            "component \"", name, "\" already defined",
760            (char*)NULL);
761        return TCL_ERROR;
762    }
763
764    /*
765     *  If this component is the "hull" for the mega-widget, then
766     *  move the object access command out of the way before
767     *  creating the component, so it is not accidentally deleted.
768     */
769    Tcl_DStringInit(&buffer);
770
771    objNamePtr = Tcl_NewStringObj((char*)NULL, 0);
772    Tcl_GetCommandFullName(contextObj->classDefn->interp,
773        contextObj->accessCmd, objNamePtr);
774    Tcl_IncrRefCount(objNamePtr);
775
776    if (strcmp(name, "hull") == 0) {
777        tmpNamePtr = Tcl_NewStringObj((char*)NULL, 0);
778        Tcl_GetCommandFullName(contextObj->classDefn->interp,
779            contextObj->accessCmd, tmpNamePtr);
780        Tcl_AppendToObj(tmpNamePtr, "-widget-", -1);
781        Tcl_IncrRefCount(tmpNamePtr);
782
783        result = TclRenameCommand(interp,
784            Tcl_GetStringFromObj(objNamePtr, (int*)NULL),
785            Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL));
786
787        if (result != TCL_OK) {
788            goto compFail;
789        }
790    }
791
792    /*
793     *  Execute the <createCmds> to create the component widget.
794     *  Do this one level up, in the scope of the calling routine.
795     */
796    uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
797    oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);
798
799    if (Tcl_EvalObj(interp, objv[2]) != TCL_OK) {
800        goto compFail;
801    }
802
803    /*
804     *  Take the result from the widget creation commands as the
805     *  path name for the new component.  Make a local copy of
806     *  this, since the interpreter will get used in the mean time.
807     */
808    resultStr = Tcl_GetStringResult(interp);
809    path = (char*)ckalloc((unsigned)(strlen(resultStr)+1));
810    strcpy(path, resultStr);
811
812    /*
813     *  Look for the access command token in the context of the
814     *  calling namespace.  By-pass any protection at this point.
815     */
816    accessCmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL,
817        /* flags */ 0);
818
819    if (!accessCmd) {
820        Tcl_ResetResult(interp);
821        Tcl_AppendResult(interp,
822           "cannot find component access command \"",
823            path, "\" for component \"", name, "\"",
824            (char*)NULL);
825        goto compFail;
826    }
827
828    winNamePtr = Tcl_NewStringObj((char*)NULL, 0);
829    Tcl_GetCommandFullName(interp, accessCmd, winNamePtr);
830    Tcl_IncrRefCount(winNamePtr);
831
832    (void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
833
834    /*
835     *  Create the component record.  Set the protection level
836     *  according to the "-protected" or "-private" option.
837     */
838    ownerClass = contextClass;
839    uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
840    if (uplevelFramePtr && Itcl_IsClassNamespace(uplevelFramePtr->nsPtr)) {
841        ownerClass = (ItclClass*)uplevelFramePtr->nsPtr->clientData;
842    }
843
844    archComp = Itk_CreateArchComponent(interp, info, name, ownerClass,
845        accessCmd);
846
847    if (!archComp) {
848        goto compFail;
849    }
850
851    Tcl_SetHashValue(entry, (ClientData)archComp);
852    archComp->member->protection = pLevel;
853
854    /*
855     *  If this component is the "hull" for the mega-widget, then
856     *  move the hull widget access command to a different name,
857     *  and move the object access command back into place.  This
858     *  way, when the widget name is used as a command, the object
859     *  access command will handle all requests.
860     */
861    if (strcmp(name, "hull") == 0) {
862        hullNamePtr = Tcl_NewStringObj((char*)NULL, 0);
863        Tcl_GetCommandFullName(interp, accessCmd, hullNamePtr);
864        Tcl_AppendToObj(hullNamePtr, "-itk_hull", -1);
865        Tcl_IncrRefCount(hullNamePtr);
866
867        result = TclRenameCommand(interp,
868            Tcl_GetStringFromObj(winNamePtr, (int*)NULL),
869            Tcl_GetStringFromObj(hullNamePtr, (int*)NULL));
870
871        if (result != TCL_OK) {
872            goto compFail;
873        }
874
875        Tcl_DecrRefCount(winNamePtr);  /* winNamePtr keeps current name */
876        winNamePtr = hullNamePtr;
877        hullNamePtr = NULL;
878
879        result = TclRenameCommand(interp,
880            Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL),
881            Tcl_GetStringFromObj(objNamePtr, (int*)NULL));
882
883        if (result != TCL_OK) {
884            goto compFail;
885        }
886    }
887
888    /*
889     *  Add a binding onto the new component, so that when its
890     *  window is destroyed, it will automatically remove itself
891     *  from its parent's component list.  Avoid doing these things
892     *  for the "hull" component, since it is a special case and
893     *  these things are not really necessary.
894     */
895    else {
896        Tcl_DStringSetLength(&buffer, 0);
897        Tcl_DStringAppend(&buffer, "bindtags ", -1);
898        Tcl_DStringAppend(&buffer, path, -1);
899        if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
900            goto compFail;
901        }
902
903        Tcl_DStringSetLength(&buffer, 0);
904        Tcl_DStringAppend(&buffer, "bind itk-destroy-", -1);
905        Tcl_DStringAppend(&buffer, path, -1);
906        Tcl_DStringAppend(&buffer, " <Destroy> [itcl::code ", -1);
907
908        Tcl_DStringAppend(&buffer,
909            Tcl_GetStringFromObj(objNamePtr,(int*)NULL), -1);
910
911        Tcl_DStringAppend(&buffer, " itk_component delete ", -1);
912        Tcl_DStringAppend(&buffer, name, -1);
913        Tcl_DStringAppend(&buffer, "]\n", -1);
914        Tcl_DStringAppend(&buffer, "bindtags ", -1);
915        Tcl_DStringAppend(&buffer, path, -1);
916        Tcl_DStringAppend(&buffer, " {itk-destroy-", -1);
917        Tcl_DStringAppend(&buffer, path, -1);
918        Tcl_DStringAppend(&buffer, " ", -1);
919        Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);
920        Tcl_DStringAppend(&buffer, "}", -1);
921        if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) {
922            goto compFail;
923        }
924    }
925
926    /*
927     *  Query the list of configuration options for this widget,
928     *  so we will know which ones are valid.  Build an option
929     *  table to represent these, so they can be found quickly
930     *  by the option parsing commands in "itk::option-parser".
931     */
932    Tcl_DStringTrunc(&buffer, 0);
933    Tcl_DStringAppendElement(&buffer,
934        Tcl_GetStringFromObj(winNamePtr, (int*)NULL));
935    Tcl_DStringAppendElement(&buffer, "configure");
936
937    result = Tcl_Eval(interp, Tcl_DStringValue(&buffer));
938
939    if (result != TCL_OK) {
940        goto compFail;
941    }
942    Tcl_DStringSetLength(&buffer, 0);
943    Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);
944
945    /*
946     *  Find the "itk::option-parser" namespace and get the data
947     *  record shared by all of the parsing commands.
948     */
949    parserNs = Tcl_FindNamespace(interp, "::itk::option-parser",
950        (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
951
952    if (!parserNs) {
953        goto compFail;
954    }
955    mergeInfo = (ArchMergeInfo*)parserNs->clientData;
956    assert(mergeInfo);
957
958    /*
959     *  Initialize the data record used by the option parsing commands.
960     *  Store a table of valid configuration options, along with the
961     *  info for the mega-widget that is being updated.
962     */
963    mergeInfo->optionTable = Itk_CreateGenericOptTable(interp,
964        Tcl_DStringValue(&buffer));
965
966    if (!mergeInfo->optionTable) {
967        goto compFail;
968    }
969    mergeInfo->archInfo = info;
970    mergeInfo->archComp = archComp;
971
972    /*
973     *  Execute the option-handling commands in the "itk::option-parser"
974     *  namespace.  If there are no option-handling commands, invoke
975     *  the "usual" command instead.
976     */
977    if (objc != 4) {
978        objPtr = Tcl_NewStringObj("usual", -1);
979        Tcl_IncrRefCount(objPtr);
980    } else {
981        objPtr = objv[3];
982    }
983
984    result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
985        parserNs, /* isProcCallFrame */ 0);
986
987    if (result == TCL_OK) {
988        result = Tcl_EvalObj(interp, objPtr);
989        Tcl_PopCallFrame(interp);
990    }
991
992    if (objPtr != objv[3]) {
993        Tcl_DecrRefCount(objPtr);
994    }
995    if (result != TCL_OK) {
996        goto compFail;
997    }
998
999    Itk_DelGenericOptTable(mergeInfo->optionTable);
1000    mergeInfo->optionTable = NULL;
1001    mergeInfo->archInfo    = NULL;
1002    mergeInfo->archComp    = NULL;
1003
1004    ckfree(path);
1005
1006    Tcl_DStringFree(&buffer);
1007    if (objNamePtr) {
1008        Tcl_DecrRefCount(objNamePtr);
1009    }
1010    if (tmpNamePtr) {
1011        Tcl_DecrRefCount(tmpNamePtr);
1012    }
1013    if (winNamePtr) {
1014        Tcl_DecrRefCount(winNamePtr);
1015    }
1016    if (hullNamePtr) {
1017        Tcl_DecrRefCount(hullNamePtr);
1018    }
1019
1020    Tcl_SetResult(interp, name, TCL_VOLATILE);
1021    return TCL_OK;
1022
1023    /*
1024     *  If any errors were encountered, clean up and return.
1025     */
1026compFail:
1027    if (archComp) {
1028        Itk_DelArchComponent(archComp);
1029    }
1030    if (entry) {
1031        Tcl_DeleteHashEntry(entry);
1032    }
1033    if (path) {
1034        ckfree(path);
1035    }
1036    if (mergeInfo && mergeInfo->optionTable) {
1037        Itk_DelGenericOptTable(mergeInfo->optionTable);
1038        mergeInfo->optionTable = NULL;
1039        mergeInfo->archInfo    = NULL;
1040        mergeInfo->archComp    = NULL;
1041    }
1042
1043    Tcl_DStringFree(&buffer);
1044    if (objNamePtr) {
1045        Tcl_DecrRefCount(objNamePtr);
1046    }
1047    if (tmpNamePtr) {
1048        Tcl_DecrRefCount(tmpNamePtr);
1049    }
1050    if (winNamePtr) {
1051        Tcl_DecrRefCount(winNamePtr);
1052    }
1053    if (hullNamePtr) {
1054        Tcl_DecrRefCount(hullNamePtr);
1055    }
1056
1057    /*
1058     *  Add error info and return.
1059     */
1060    objPtr = Tcl_NewStringObj((char*)NULL, 0);
1061    Tcl_AppendToObj(objPtr, "\n    (while creating component \"", -1);
1062    Tcl_AppendToObj(objPtr, name, -1);
1063    Tcl_AppendToObj(objPtr, "\" for widget \"", -1);
1064    Tcl_GetCommandFullName(contextObj->classDefn->interp,
1065        contextObj->accessCmd, objPtr);
1066    Tcl_AppendToObj(objPtr, "\")", -1);
1067    Tcl_IncrRefCount(objPtr);
1068
1069    Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
1070    Tcl_DecrRefCount(objPtr);
1071
1072
1073    return TCL_ERROR;
1074}
1075
1076
1077/*
1078 * ------------------------------------------------------------------------
1079 *  Itk_ArchCompDeleteCmd()
1080 *
1081 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_component
1082 *  method.  Removes an existing component widget from a mega-widget,
1083 *  and removes any configuration options associated with it.
1084 *
1085 *      itk_component delete <name> ?<name> <name>...?
1086 *
1087 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1088 * ------------------------------------------------------------------------
1089 */
1090/* ARGSUSED */
1091static int
1092Itk_ArchCompDeleteCmd(dummy, interp, objc, objv)
1093    ClientData dummy;        /* unused */
1094    Tcl_Interp *interp;      /* current interpreter */
1095    int objc;                /* number of arguments */
1096    Tcl_Obj *CONST objv[];   /* argument objects */
1097{
1098    int i;
1099    char *token;
1100    ItclClass *contextClass;
1101    ItclObject *contextObj;
1102    ArchInfo *info;
1103    Tcl_HashEntry *entry;
1104    Tcl_HashSearch place;
1105    Itcl_ListElem *elem;
1106    ArchComponent *archComp;
1107    ArchOption *archOpt;
1108    ArchOptionPart *optPart;
1109    Itcl_List delOptList;
1110    Tcl_DString buffer;
1111
1112    /*
1113     *  Get the Archetype info associated with this widget.
1114     */
1115    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
1116        !contextObj) {
1117
1118        Tcl_ResetResult(interp);
1119        Tcl_AppendResult(interp,
1120            "cannot access components without an object context",
1121            (char*)NULL);
1122        return TCL_ERROR;
1123    }
1124    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
1125        return TCL_ERROR;
1126    }
1127
1128    /*
1129     *  Scan through the list of component names and delete each
1130     *  one.  Make sure that each component exists.
1131     */
1132    for (i=1; i < objc; i++) {
1133        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
1134        entry = Tcl_FindHashEntry(&info->components, token);
1135        if (!entry) {
1136            Tcl_AppendResult(interp,
1137                "name \"", token, "\" is not a component",
1138                (char*)NULL);
1139            return TCL_ERROR;
1140        }
1141        archComp = (ArchComponent*)Tcl_GetHashValue(entry);
1142
1143       /*
1144        *  Clean up the binding tag that causes the widget to
1145        *  call this method automatically when destroyed.
1146        *  Ignore errors if anything goes wrong.
1147        */
1148        Tcl_DStringInit(&buffer);
1149        Tcl_DStringAppend(&buffer, "itk::remove_destroy_hook ", -1);
1150        Tcl_DStringAppend(&buffer, archComp->pathName, -1);
1151        (void) Tcl_Eval(interp, Tcl_DStringValue(&buffer));
1152        Tcl_ResetResult(interp);
1153        Tcl_DStringFree(&buffer);
1154
1155        Tcl_UnsetVar2(interp, "itk_component", token, 0);
1156        Tcl_DeleteHashEntry(entry);
1157
1158        /*
1159         *  Clean up the options that belong to the component.  Do this
1160         *  by scanning through all available options and looking for
1161         *  those that belong to the component.  If we remove them as
1162         *  we go, we'll mess up Tcl_NextHashEntry.  So instead, we
1163         *  build up a list of options to remove, and then remove the
1164         *  options below.
1165         */
1166        Itcl_InitList(&delOptList);
1167        entry = Tcl_FirstHashEntry(&info->options, &place);
1168        while (entry) {
1169            archOpt = (ArchOption*)Tcl_GetHashValue(entry);
1170            elem = Itcl_FirstListElem(&archOpt->parts);
1171            while (elem) {
1172                optPart = (ArchOptionPart*)Itcl_GetListValue(elem);
1173                if (optPart->from == (ClientData)archComp) {
1174                    Itcl_AppendList(&delOptList, (ClientData)entry);
1175                }
1176                elem = Itcl_NextListElem(elem);
1177            }
1178            entry = Tcl_NextHashEntry(&place);
1179        }
1180
1181        /*
1182         *  Now that we've figured out which options to delete,
1183         *  go through the list and remove them.
1184         */
1185        elem = Itcl_FirstListElem(&delOptList);
1186        while (elem) {
1187            entry = (Tcl_HashEntry*)Itcl_GetListValue(elem);
1188            token = Tcl_GetHashKey(&info->options, entry);
1189
1190            Itk_RemoveArchOptionPart(info, token, (ClientData)archComp);
1191
1192            elem = Itcl_NextListElem(elem);
1193        }
1194        Itcl_DeleteList(&delOptList);
1195
1196        Itk_DelArchComponent(archComp);
1197    }
1198    return TCL_OK;
1199}
1200
1201
1202/*
1203 * ------------------------------------------------------------------------
1204 *  Itk_ArchOptKeepCmd()
1205 *
1206 *  Invoked by [incr Tcl] to handle the "keep" command in the itk
1207 *  option parser.  Integrates a list of component configuration options
1208 *  into a mega-widget, so that whenever the mega-widget is updated,
1209 *  the component will be updated as well.
1210 *
1211 *  Handles the following syntax:
1212 *
1213 *      keep <option> ?<option>...?
1214 *
1215 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1216 * ------------------------------------------------------------------------
1217 */
1218/* ARGSUSED */
1219static int
1220Itk_ArchOptKeepCmd(clientData, interp, objc, objv)
1221    ClientData clientData;   /* option merging info record */
1222    Tcl_Interp *interp;      /* current interpreter */
1223    int objc;                /* number of arguments */
1224    Tcl_Obj *CONST objv[];   /* argument objects */
1225{
1226    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;
1227    int result = TCL_OK;
1228
1229    int i;
1230    char *token;
1231    Tcl_HashEntry *entry;
1232    GenericConfigOpt *opt;
1233    ArchOption *archOpt;
1234    ArchOptionPart *optPart;
1235    ConfigCmdline *cmdlinePtr;
1236
1237    if (objc < 2) {
1238        Tcl_WrongNumArgs(interp, 1, objv, "option ?option...?");
1239        return TCL_ERROR;
1240    }
1241
1242    /*
1243     *  Make sure that this command is being accessed in the
1244     *  proper context.  The merge info record should be set up
1245     *  properly.
1246     */
1247    if (!mergeInfo->archInfo || !mergeInfo->optionTable) {
1248        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1249        Tcl_AppendResult(interp,
1250            "improper usage: \"", token,
1251            "\" should only be accessed via itk_component",
1252            (char*)NULL);
1253        return TCL_ERROR;
1254    }
1255
1256    /*
1257     *  Scan through all of the options on the list, and make
1258     *  sure that they are valid options for this component.
1259     *  Integrate them into the option info for the mega-widget.
1260     */
1261    for (i=1; i < objc; i++) {
1262        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
1263        entry = Tcl_FindHashEntry(mergeInfo->optionTable, token);
1264        if (!entry) {
1265            Tcl_AppendResult(interp,
1266                "option not recognized: ", token,
1267                (char*)NULL);
1268            result = TCL_ERROR;
1269            break;
1270        }
1271        opt = (GenericConfigOpt*)Tcl_GetHashValue(entry);
1272
1273        /*
1274         *  If this option has already been integrated, then
1275         *  remove it and start again.
1276         */
1277        Itk_IgnoreArchOptionPart(mergeInfo->archInfo, opt);
1278
1279        /*
1280         *  Build a command prefix that can be used to apply changes
1281         *  to this option for this component.
1282         */
1283        cmdlinePtr = Itk_CreateConfigCmdline(interp,
1284            mergeInfo->archComp->accessCmd, token);
1285
1286        optPart = Itk_CreateOptionPart(interp, (ClientData)cmdlinePtr,
1287            Itk_PropagateOption, Itk_DeleteConfigCmdline,
1288            (ClientData)mergeInfo->archComp);
1289
1290        result = Itk_AddOptionPart(interp, mergeInfo->archInfo,
1291            opt->switchName, opt->resName, opt->resClass,
1292            opt->init, opt->value, optPart, &archOpt);
1293
1294        if (result == TCL_OK) {
1295            opt->integrated = archOpt;
1296            opt->optPart    = optPart;
1297        } else {
1298            Itk_DelOptionPart(optPart);
1299            result = TCL_ERROR;
1300            break;
1301        }
1302    }
1303    return result;
1304}
1305
1306
1307/*
1308 * ------------------------------------------------------------------------
1309 *  Itk_ArchOptIgnoreCmd()
1310 *
1311 *  Invoked by [incr Tcl] to handle the "ignore" command in the itk
1312 *  option parser.  Removes a list of component configuration options
1313 *  from a mega-widget.  This negates the action of previous "keep"
1314 *  and "rename" commands.
1315 *
1316 *  Handles the following syntax:
1317 *
1318 *      ignore <option> ?<option>...?
1319 *
1320 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1321 * ------------------------------------------------------------------------
1322 */
1323/* ARGSUSED */
1324static int
1325Itk_ArchOptIgnoreCmd(clientData, interp, objc, objv)
1326    ClientData clientData;   /* option merging info record */
1327    Tcl_Interp *interp;      /* current interpreter */
1328    int objc;                /* number of arguments */
1329    Tcl_Obj *CONST objv[];   /* argument objects */
1330{
1331    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;
1332
1333    int i;
1334    char *token;
1335    Tcl_HashEntry *entry;
1336    GenericConfigOpt *opt;
1337
1338    if (objc < 2) {
1339        Tcl_WrongNumArgs(interp, 1, objv, "option ?option...?");
1340        return TCL_ERROR;
1341    }
1342
1343    /*
1344     *  Make sure that this command is being accessed in the
1345     *  proper context.  The merge info record should be set up
1346     *  properly.
1347     */
1348    if (!mergeInfo->archInfo || !mergeInfo->optionTable) {
1349        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1350        Tcl_AppendResult(interp,
1351            "improper usage: \"", token,
1352            "\" should only be accessed via itk_component",
1353            (char*)NULL);
1354        return TCL_ERROR;
1355    }
1356
1357    /*
1358     *  Scan through all of the options on the list, and make
1359     *  sure that they are valid options for this component.
1360     *  Remove them from the mega-widget.
1361     */
1362    for (i=1; i < objc; i++) {
1363        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
1364        entry = Tcl_FindHashEntry(mergeInfo->optionTable, token);
1365        if (!entry) {
1366            Tcl_AppendResult(interp, "option not recognized: ", token,
1367                (char*)NULL);
1368            return TCL_ERROR;
1369        }
1370        opt = (GenericConfigOpt*)Tcl_GetHashValue(entry);
1371
1372        /*
1373         *  If this option has already been integrated, then
1374         *  remove it.  Otherwise, ignore it.
1375         */
1376        Itk_IgnoreArchOptionPart(mergeInfo->archInfo, opt);
1377    }
1378    return TCL_OK;
1379}
1380
1381
1382/*
1383 * ------------------------------------------------------------------------
1384 *  Itk_ArchOptRenameCmd()
1385 *
1386 *  Invoked by [incr Tcl] to handle the "rename" command in the itk
1387 *  option parser.  Integrates one configuration option into a
1388 *  mega-widget, using a different name for the option.  Whenever the
1389 *  mega-widget option is updated, the renamed option will be updated
1390 *  as well.  Handles the following syntax:
1391 *
1392 *      rename <oldSwitch> <newSwitch> <resName> <resClass>
1393 *
1394 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1395 * ------------------------------------------------------------------------
1396 */
1397/* ARGSUSED */
1398static int
1399Itk_ArchOptRenameCmd(clientData, interp, objc, objv)
1400    ClientData clientData;   /* option merging info record */
1401    Tcl_Interp *interp;      /* current interpreter */
1402    int objc;                /* number of arguments */
1403    Tcl_Obj *CONST objv[];   /* argument objects */
1404{
1405    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;
1406
1407    int result;
1408    char *oldSwitch, *newSwitch, *resName, *resClass;
1409    Tcl_HashEntry *entry;
1410    GenericConfigOpt *opt;
1411    ArchOption *archOpt;
1412    ArchOptionPart *optPart;
1413    ConfigCmdline *cmdlinePtr;
1414
1415    if (objc != 5) {
1416        Tcl_WrongNumArgs(interp, 1, objv,
1417            "oldSwitch newSwitch resourceName resourceClass");
1418        return TCL_ERROR;
1419    }
1420
1421    /*
1422     *  Make sure that this command is being accessed in the
1423     *  proper context.  The merge info record should be set up
1424     *  properly.
1425     */
1426    if (!mergeInfo->archInfo || !mergeInfo->optionTable) {
1427        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1428        Tcl_AppendResult(interp,
1429            "improper usage: \"", token,
1430            "\" should only be accessed via itk_component",
1431            (char*)NULL);
1432        return TCL_ERROR;
1433    }
1434
1435    oldSwitch = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1436    newSwitch = Tcl_GetStringFromObj(objv[2], (int*)NULL);
1437    resName   = Tcl_GetStringFromObj(objv[3], (int*)NULL);
1438    resClass  = Tcl_GetStringFromObj(objv[4], (int*)NULL);
1439
1440    /*
1441     *  Make sure that the resource name and resource class look good.
1442     */
1443    if (!islower((int)*resName)) {
1444        Tcl_AppendResult(interp,
1445            "bad resource name \"", resName,
1446            "\": should start with a lower case letter",
1447            (char*)NULL);
1448        return TCL_ERROR;
1449    }
1450    if (!isupper((int)*resClass)) {
1451        Tcl_AppendResult(interp,
1452            "bad resource class \"", resClass,
1453            "\": should start with an upper case letter",
1454            (char*)NULL);
1455        return TCL_ERROR;
1456    }
1457
1458    /*
1459     *  Make sure that the specified switch exists in the widget.
1460     */
1461    entry = Tcl_FindHashEntry(mergeInfo->optionTable, oldSwitch);
1462    if (!entry) {
1463        Tcl_AppendResult(interp,
1464            "option not recognized: ", oldSwitch,
1465            (char*)NULL);
1466        return TCL_ERROR;
1467    }
1468    opt = (GenericConfigOpt*)Tcl_GetHashValue(entry);
1469
1470    /*
1471     *  If this option has already been integrated, then
1472     *  remove it and start again.
1473     */
1474    Itk_IgnoreArchOptionPart(mergeInfo->archInfo, opt);
1475
1476    /*
1477     *  Build a command prefix that can be used to apply changes
1478     *  to this option for this component.
1479     */
1480    cmdlinePtr = Itk_CreateConfigCmdline(interp,
1481        mergeInfo->archComp->accessCmd, oldSwitch);
1482
1483    optPart = Itk_CreateOptionPart(interp, (ClientData)cmdlinePtr,
1484        Itk_PropagateOption, Itk_DeleteConfigCmdline,
1485        (ClientData)mergeInfo->archComp);
1486
1487    /*
1488     *  Merge this option into the mega-widget with a new name.
1489     */
1490    result = Itk_AddOptionPart(interp, mergeInfo->archInfo, newSwitch,
1491        resName, resClass, opt->init, opt->value, optPart,
1492        &archOpt);
1493
1494    if (result == TCL_OK) {
1495        opt->integrated = archOpt;
1496        opt->optPart    = optPart;
1497    } else {
1498        Itk_DelOptionPart(optPart);
1499        result = TCL_ERROR;
1500    }
1501    return result;
1502}
1503
1504
1505/*
1506 * ------------------------------------------------------------------------
1507 *  Itk_ArchOptUsualCmd()
1508 *
1509 *  Invoked by [incr Tcl] to handle the "usual" command in the itk
1510 *  option parser.  Looks for a set of "usual" option-handling commands
1511 *  associated with the given tag or component class and then evaluates
1512 *  the commands in the option parser namespace.  This keeps the user
1513 *  from having to type a bunch of "keep" and "rename" commands for
1514 *  each component widget.
1515 *
1516 *  Handles the following syntax:
1517 *
1518 *      usual ?<tag>?
1519 *
1520 *  If the <tag> is not specified, then the class name for the
1521 *  component is used as the tag name.
1522 *
1523 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1524 * ------------------------------------------------------------------------
1525 */
1526/* ARGSUSED */
1527static int
1528Itk_ArchOptUsualCmd(clientData, interp, objc, objv)
1529    ClientData clientData;   /* option merging info record */
1530    Tcl_Interp *interp;      /* current interpreter */
1531    int objc;                /* number of arguments */
1532    Tcl_Obj *CONST objv[];   /* argument objects */
1533{
1534    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;
1535
1536    CONST char *tag;
1537    Tcl_HashEntry *entry;
1538    Tcl_Obj *codePtr;
1539
1540    if (objc > 2) {
1541        Tcl_WrongNumArgs(interp, 1, objv, "?tag?");
1542        return TCL_ERROR;
1543    }
1544
1545    /*
1546     *  Make sure that this command is being accessed in the
1547     *  proper context.  The merge info record should be set up
1548     *  properly.
1549     */
1550    if (!mergeInfo->archInfo || !mergeInfo->optionTable) {
1551        char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1552        Tcl_AppendResult(interp,
1553            "improper usage: \"", token,
1554            "\" should only be accessed via itk_component",
1555            (char*)NULL);
1556        return TCL_ERROR;
1557    }
1558
1559    /*
1560     *  If a tag name was specified, then use this to look up
1561     *  the "usual" code.  Otherwise, use the class name for
1562     *  the component widget.
1563     */
1564    if (objc == 2) {
1565        tag = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1566    } else {
1567        tag = Tk_Class(mergeInfo->archComp->tkwin);
1568    }
1569
1570    /*
1571     *  Look for some code associated with the tag and evaluate
1572     *  it in the current context.
1573     */
1574    entry = Tcl_FindHashEntry(&mergeInfo->usualCode, tag);
1575    if (entry) {
1576        codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
1577        return Tcl_EvalObj(interp, codePtr);
1578    }
1579
1580    Tcl_AppendResult(interp,
1581        "can't find usual code for tag \"", tag, "\"",
1582        (char*)NULL);
1583    return TCL_ERROR;
1584}
1585
1586
1587/*
1588 * ------------------------------------------------------------------------
1589 *  Itk_UsualCmd()
1590 *
1591 *  Invoked by [incr Tcl] to handle the "usual" command in the ::itk
1592 *  namespace.  Used to query or set the option-handling code associated
1593 *  with a widget class or arbitrary tag name.  This code is later
1594 *  used by the "usual" command in the "itk::option-parser" namespace.
1595 *
1596 *  Handles the following syntax:
1597 *
1598 *      usual ?<tag>? ?<code>?
1599 *
1600 *  If the <tag> is not specified, then this returns a list of all
1601 *  known tags.  If the <code> is not specified, then this returns
1602 *  the current code associated with <tag>, or an empty string if
1603 *  <tag> is not recognized.  Otherwise, it sets the code fragment
1604 *  for <tag> to <code>.
1605 *
1606 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1607 * ------------------------------------------------------------------------
1608 */
1609/* ARGSUSED */
1610int
1611Itk_UsualCmd(clientData, interp, objc, objv)
1612    ClientData clientData;   /* option merging info record */
1613    Tcl_Interp *interp;      /* current interpreter */
1614    int objc;                /* number of arguments */
1615    Tcl_Obj *CONST objv[];   /* argument objects */
1616{
1617    ArchMergeInfo *mergeInfo = (ArchMergeInfo*)clientData;
1618
1619    int newEntry;
1620    char *tag, *token;
1621    Tcl_HashEntry *entry;
1622    Tcl_HashSearch place;
1623    Tcl_Obj *codePtr;
1624
1625    if (objc > 3) {
1626        Tcl_WrongNumArgs(interp, 1, objv, "?tag? ?commands?");
1627        return TCL_ERROR;
1628    }
1629
1630    /*
1631     *  If no arguments were specified, then return a list of
1632     *  all known tags.
1633     */
1634    if (objc == 1) {
1635        entry = Tcl_FirstHashEntry(&mergeInfo->usualCode, &place);
1636        while (entry) {
1637            tag = Tcl_GetHashKey(&mergeInfo->usualCode, entry);
1638            Tcl_AppendElement(interp, tag);
1639            entry = Tcl_NextHashEntry(&place);
1640        }
1641        return TCL_OK;
1642    }
1643
1644    /*
1645     *  If a code fragment was specified, then save it in the
1646     *  hash table for "usual" code.
1647     */
1648    else if (objc == 3) {
1649        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1650        entry = Tcl_CreateHashEntry(&mergeInfo->usualCode, token, &newEntry);
1651        if (!newEntry) {
1652            codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
1653            Tcl_DecrRefCount(codePtr);
1654        }
1655
1656        codePtr = objv[2];
1657        Tcl_IncrRefCount(codePtr);
1658        Tcl_SetHashValue(entry, (ClientData)codePtr);
1659
1660        return TCL_OK;
1661    }
1662
1663    /*
1664     *  Otherwise, look for a code fragment with the specified tag.
1665     */
1666    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1667    entry = Tcl_FindHashEntry(&mergeInfo->usualCode, token);
1668    if (entry) {
1669        codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry);
1670        Tcl_SetObjResult(interp, codePtr);
1671    }
1672    return TCL_OK;
1673}
1674
1675
1676/*
1677 * ------------------------------------------------------------------------
1678 *  Itk_ArchInitCmd()
1679 *
1680 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_initialize
1681 *  method.  This method should be called out in the constructor for
1682 *  each mega-widget class, to build the composite option list at
1683 *  each class level.  Handles the following syntax:
1684 *
1685 *      itk_initialize ?-option val -option val...?
1686 *
1687 *  Integrates any class-based options into the composite option list,
1688 *  handles option settings from the command line, and then configures
1689 *  all options to have the proper initial value.
1690 *
1691 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1692 * ------------------------------------------------------------------------
1693 */
1694/* ARGSUSED */
1695static int
1696Itk_ArchInitCmd(dummy, interp, objc, objv)
1697    ClientData dummy;        /* unused */
1698    Tcl_Interp *interp;      /* current interpreter */
1699    int objc;                /* number of arguments */
1700    Tcl_Obj *CONST objv[];   /* argument objects */
1701{
1702    ItclClass *contextClass, *cdefn;
1703    ItclObject *contextObj;
1704    ArchInfo *info;
1705
1706    int i, result;
1707    CONST char *val;
1708    char *token;
1709    Itcl_CallFrame *framePtr;
1710    ItkClassOption *opt;
1711    ItkClassOptTable *optTable;
1712    Itcl_ListElem *part;
1713    ArchOption *archOpt;
1714    ArchOptionPart *optPart;
1715    ItclHierIter hier;
1716    ItclVarDefn *vdefn;
1717    Tcl_HashSearch place;
1718    Tcl_HashEntry *entry;
1719
1720    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
1721        !contextObj) {
1722
1723        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1724        Tcl_ResetResult(interp);
1725        Tcl_AppendResult(interp,
1726            "improper usage: should be \"object ",
1727            token, " ?-option value -option value...?\"",
1728            (char*)NULL);
1729        return TCL_ERROR;
1730    }
1731
1732    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
1733        return TCL_ERROR;
1734    }
1735
1736    /*
1737     *  See what class is being initialized by getting the namespace
1738     *  for the calling context.
1739     */
1740    framePtr = _Tcl_GetCallFrame(interp, 1);
1741    if (framePtr && Itcl_IsClassNamespace(framePtr->nsPtr)) {
1742        contextClass = (ItclClass*)framePtr->nsPtr->clientData;
1743    }
1744
1745    /*
1746     *  Integrate all public variables for the current class
1747     *  context into the composite option list.
1748     */
1749    Itcl_InitHierIter(&hier, contextClass);
1750    while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
1751        entry = Tcl_FirstHashEntry(&cdefn->variables, &place);
1752        while (entry) {
1753            vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
1754
1755            if (vdefn->member->protection == ITCL_PUBLIC) {
1756                optPart = Itk_FindArchOptionPart(info,
1757                    vdefn->member->name, (ClientData)vdefn);
1758
1759                if (!optPart) {
1760                    optPart = Itk_CreateOptionPart(interp, (ClientData)vdefn,
1761                        Itk_PropagatePublicVar, (Tcl_CmdDeleteProc*)NULL,
1762                        (ClientData)vdefn);
1763
1764                    val = Itcl_GetInstanceVar(interp, vdefn->member->fullname,
1765                        contextObj, contextObj->classDefn);
1766
1767                    result = Itk_AddOptionPart(interp, info,
1768                        vdefn->member->name, (char*)NULL, (char*)NULL,
1769                        val, (char*)NULL, optPart, &archOpt);
1770
1771                    if (result != TCL_OK) {
1772                        Itk_DelOptionPart(optPart);
1773                        return TCL_ERROR;
1774                    }
1775                }
1776            }
1777            entry = Tcl_NextHashEntry(&place);
1778        }
1779    }
1780    Itcl_DeleteHierIter(&hier);
1781
1782    /*
1783     *  Integrate all class-based options for the current class
1784     *  context into the composite option list.
1785     */
1786    optTable = Itk_FindClassOptTable(contextClass);
1787    if (optTable) {
1788        for (i=0; i < optTable->order.len; i++) {
1789            opt = (ItkClassOption*)Tcl_GetHashValue(optTable->order.list[i]);
1790
1791            optPart = Itk_FindArchOptionPart(info, opt->member->name,
1792                (ClientData)contextClass);
1793
1794            if (!optPart) {
1795                optPart = Itk_CreateOptionPart(interp, (ClientData)opt,
1796                    Itk_ConfigClassOption, (Tcl_CmdDeleteProc*)NULL,
1797                    (ClientData)contextClass);
1798
1799                result = Itk_AddOptionPart(interp, info,
1800                    opt->member->name, opt->resName, opt->resClass,
1801                    opt->init, (char*)NULL, optPart, &archOpt);
1802
1803                if (result != TCL_OK) {
1804                    Itk_DelOptionPart(optPart);
1805                    return TCL_ERROR;
1806                }
1807            }
1808        }
1809    }
1810
1811    /*
1812     *  If any option values were specified on the command line,
1813     *  override the current option settings.
1814     */
1815    if (objc > 1) {
1816        for (objc--,objv++; objc > 0; objc-=2, objv+=2) {
1817	    char *value;
1818            token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1819            if (objc < 2) {
1820	        /* Bug 227814
1821		 * Ensure that the interp result is unshared.
1822		 */
1823
1824	        Tcl_ResetResult(interp);
1825                Tcl_AppendResult(interp,
1826                    "value for \"", token, "\" missing",
1827                    (char*)NULL);
1828                return TCL_ERROR;
1829            }
1830
1831            value = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1832            if (Itk_ArchConfigOption(interp, info, token, value) != TCL_OK) {
1833                return TCL_ERROR;
1834            }
1835        }
1836    }
1837
1838    /*
1839     *  If this is most-specific class, then finish constructing
1840     *  the mega-widget:
1841     *
1842     *  Scan through all options in the composite list and
1843     *  look for any that have been set but not initialized.
1844     *  Invoke the parts of uninitialized options to propagate
1845     *  changes and update the widget.
1846     */
1847    if (contextObj->classDefn == contextClass) {
1848        for (i=0; i < info->order.len; i++) {
1849            archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);
1850
1851            if ((archOpt->flags & ITK_ARCHOPT_INIT) == 0) {
1852                val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
1853
1854                if (!val) {
1855                    Itk_ArchOptAccessError(interp, info, archOpt);
1856                    return TCL_ERROR;
1857                }
1858
1859                part = Itcl_FirstListElem(&archOpt->parts);
1860                while (part) {
1861                    optPart = (ArchOptionPart*)Itcl_GetListValue(part);
1862                    result  = (*optPart->configProc)(interp, contextObj,
1863                        optPart->clientData, val);
1864
1865                    if (result != TCL_OK) {
1866                        Itk_ArchOptConfigError(interp, info, archOpt);
1867                        return result;
1868                    }
1869                    part = Itcl_NextListElem(part);
1870                }
1871                archOpt->flags |= ITK_ARCHOPT_INIT;
1872            }
1873        }
1874    }
1875
1876    Tcl_ResetResult(interp);
1877    return TCL_OK;
1878}
1879
1880
1881/*
1882 * ------------------------------------------------------------------------
1883 *  Itk_ArchOptionCmd()
1884 *
1885 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_option
1886 *  method.  Handles the following options:
1887 *
1888 *      itk_option define <switch> <resName> <resClass> <init> ?<config>?
1889 *      itk_option add <name> ?<name>...?
1890 *      itk_option remove <name> ?<name>...?
1891 *
1892 *  These commands customize the options list of a specific widget.
1893 *  They are similar to the "itk_option" ensemble in the class definition
1894 *  parser, but manipulate a single instance instead of an entire class.
1895 *
1896 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1897 * ------------------------------------------------------------------------
1898 */
1899/* ARGSUSED */
1900static int
1901Itk_ArchOptionCmd(dummy, interp, objc, objv)
1902    ClientData dummy;        /* unused */
1903    Tcl_Interp *interp;      /* current interpreter */
1904    int objc;                /* number of arguments */
1905    Tcl_Obj *CONST objv[];   /* argument objects */
1906{
1907    char *cmd, *token, c;
1908    int length;
1909
1910    /*
1911     *  Check arguments and handle the various options...
1912     */
1913    if (objc < 2) {
1914        cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1915        Tcl_AppendResult(interp,
1916            "wrong # args: should be one of...\n",
1917            "  ", cmd, " add name ?name name...?\n",
1918            "  ", cmd, " define -switch resourceName resourceClass init ?config?\n",
1919            "  ", cmd, " remove name ?name name...?",
1920            (char*)NULL);
1921        return TCL_ERROR;
1922    }
1923
1924    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
1925    c = *token;
1926    length = strlen(token);
1927
1928    /*
1929     *  Handle:  itk_option add...
1930     */
1931    if (c == 'a' && strncmp(token, "add", length) == 0) {
1932        if (objc < 3) {
1933            Tcl_WrongNumArgs(interp, 1, objv, "add name ?name name...?");
1934            return TCL_ERROR;
1935        }
1936        return Itk_ArchOptionAddCmd(dummy, interp, objc-1, objv+1);
1937    }
1938
1939    /*
1940     *  Handle:  itk_option remove...
1941     */
1942    else if (c == 'r' && strncmp(token, "remove", length) == 0) {
1943        if (objc < 3) {
1944            Tcl_WrongNumArgs(interp, 1, objv, "remove name ?name name...?");
1945            return TCL_ERROR;
1946        }
1947        return Itk_ArchOptionRemoveCmd(dummy, interp, objc-1, objv+1);
1948    }
1949
1950    /*
1951     *  Handle:  itk_option define...
1952     */
1953    else if (c == 'd' && strncmp(token, "define", length) == 0) {
1954        Tcl_AppendResult(interp,
1955            "can only ", token, " options at the class level\n",
1956            "(move this command into the class definition)",
1957            (char*)NULL);
1958        return TCL_ERROR;
1959    }
1960
1961    /*
1962     *  Flag any errors.
1963     */
1964    cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL);
1965    Tcl_AppendResult(interp,
1966        "bad option \"", token,
1967        "\": should be one of...\n",
1968        "  ", cmd, " add name ?name name...?\n",
1969        "  ", cmd, " define -switch resourceName resourceClass init ?config?\n",
1970        "  ", cmd, " remove name ?name name...?",
1971        (char*)NULL);
1972    return TCL_ERROR;
1973}
1974
1975
1976/*
1977 * ------------------------------------------------------------------------
1978 *  Itk_ArchOptionAddCmd()
1979 *
1980 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_option add
1981 *  method.  Finds an option within a class definition or belonging to
1982 *  a component widget and adds it into the option list for this widget.
1983 *  If the option is already on the list, this method does nothing.
1984 *  Handles the following syntax:
1985 *
1986 *      itk_option add <name> ?<name> <name>...?
1987 *
1988 *      where <name> is one of:
1989 *        class::option
1990 *        component.option
1991 *
1992 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
1993 * ------------------------------------------------------------------------
1994 */
1995/* ARGSUSED */
1996static int
1997Itk_ArchOptionAddCmd(dummy, interp, objc, objv)
1998    ClientData dummy;        /* unused */
1999    Tcl_Interp *interp;      /* current interpreter */
2000    int objc;                /* number of arguments */
2001    Tcl_Obj *CONST objv[];   /* argument objects */
2002{
2003    ItclClass *contextClass, *cdefn;
2004    ItclObject *contextObj;
2005    ArchInfo *info;
2006
2007    int i, result;
2008    char *token, *head, *tail, *sep, tmp;
2009    ItkClassOption *opt;
2010    GenericConfigOpt *generic;
2011    ArchOption *archOpt;
2012    ArchOptionPart *optPart;
2013    ArchComponent *archComp;
2014    ConfigCmdline *cmdlinePtr;
2015    Tcl_HashEntry *entry;
2016    Tcl_DString buffer;
2017
2018    /*
2019     *  Get the Archetype info associated with this widget.
2020     */
2021    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
2022        !contextObj) {
2023
2024        Tcl_ResetResult(interp);
2025        Tcl_AppendResult(interp,
2026            "cannot access options without an object context",
2027            (char*)NULL);
2028        return TCL_ERROR;
2029    }
2030
2031    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
2032        return TCL_ERROR;
2033    }
2034
2035    /*
2036     *  Scan through the list of options and locate each one.
2037     *  If it is not already on the option part list, add it.
2038     */
2039    for (i=1; i < objc; i++) {
2040        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
2041        Itcl_ParseNamespPath(token, &buffer, &head, &tail);
2042
2043        /*
2044         *  HANDLE:  class::option
2045         */
2046        if (head) {
2047            cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
2048            if (!cdefn) {
2049                Tcl_DStringFree(&buffer);
2050                return TCL_ERROR;
2051            }
2052
2053            opt = Itk_FindClassOption(cdefn, tail);
2054            if (!opt) {
2055                Tcl_AppendResult(interp,
2056                    "option \"", tail, "\" not defined in class \"",
2057                    cdefn->fullname, "\"",
2058                    (char*)NULL);
2059                Tcl_DStringFree(&buffer);
2060                return TCL_ERROR;
2061            }
2062
2063            optPart = Itk_FindArchOptionPart(info, opt->member->name,
2064                (ClientData)cdefn);
2065
2066            if (!optPart) {
2067                optPart = Itk_CreateOptionPart(interp, (ClientData)opt,
2068                    Itk_ConfigClassOption, (Tcl_CmdDeleteProc*)NULL,
2069                    (ClientData)cdefn);
2070
2071                result = Itk_AddOptionPart(interp, info, opt->member->name,
2072                    opt->resName, opt->resClass, opt->init, (char*)NULL,
2073                    optPart, &archOpt);
2074
2075                if (result != TCL_OK) {
2076                    Itk_DelOptionPart(optPart);
2077                    Tcl_DStringFree(&buffer);
2078                    return TCL_ERROR;
2079                }
2080            }
2081            Tcl_DStringFree(&buffer);
2082            continue;
2083        }
2084
2085        Tcl_DStringFree(&buffer);
2086
2087        /*
2088         *  HANDLE:  component.option
2089         */
2090        sep = strstr(token, ".");
2091        if (sep) {
2092            tmp = *sep;
2093            *sep = '\0';
2094            head = token;
2095            tail = sep+1;
2096
2097            entry = Tcl_FindHashEntry(&info->components, head);
2098            if (!entry) {
2099                Tcl_AppendResult(interp,
2100                    "name \"", head, "\" is not a component",
2101                    (char*)NULL);
2102                *sep = tmp;
2103                return TCL_ERROR;
2104            }
2105            *sep = tmp;
2106            archComp = (ArchComponent*)Tcl_GetHashValue(entry);
2107
2108            generic = Itk_CreateGenericOpt(interp, tail, archComp->accessCmd);
2109            if (!generic) {
2110                char msg[256];
2111                sprintf(msg, "\n    (while adding option \"%.100s\")", token);
2112                Tcl_AddErrorInfo(interp, msg);
2113                return TCL_ERROR;
2114            }
2115
2116            optPart = Itk_FindArchOptionPart(info, generic->switchName,
2117                (ClientData)archComp);
2118
2119            if (!optPart) {
2120                cmdlinePtr = Itk_CreateConfigCmdline(interp,
2121                    archComp->accessCmd, generic->switchName);
2122
2123                optPart = Itk_CreateOptionPart(interp, (ClientData)cmdlinePtr,
2124                    Itk_PropagateOption, Itk_DeleteConfigCmdline,
2125                    (ClientData)archComp);
2126
2127                result = Itk_AddOptionPart(interp, info,
2128                    generic->switchName, generic->resName, generic->resClass,
2129                    generic->init, generic->value, optPart, &archOpt);
2130
2131                if (result != TCL_OK) {
2132                    Itk_DelOptionPart(optPart);
2133                    Itk_DelGenericOpt(generic);
2134                    return TCL_ERROR;
2135                }
2136            }
2137            Itk_DelGenericOpt(generic);
2138            continue;
2139        }
2140
2141        /*
2142         *  Anything else is an error.
2143         */
2144        Tcl_AppendResult(interp,
2145            "bad option \"", token, "\": should be one of...\n",
2146            "  class::option\n",
2147            "  component.option",
2148            (char*)NULL);
2149        return TCL_ERROR;
2150    }
2151
2152    return TCL_OK;
2153}
2154
2155
2156/*
2157 * ------------------------------------------------------------------------
2158 *  Itk_ArchOptionRemoveCmd()
2159 *
2160 *  Invoked by [incr Tcl] to handle the itk::Archetype::itk_option remove
2161 *  method.  Finds an option within a class definition or belonging to
2162 *  a component widget and removes it from the option list for this widget.
2163 *  If the option has already been removed from the list, this method does
2164 *  nothing.  Handles the following syntax:
2165 *
2166 *      itk_option remove <name> ?<name> <name>...?
2167 *
2168 *      where <name> is one of:
2169 *        class::option
2170 *        component.option
2171 *
2172 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
2173 * ------------------------------------------------------------------------
2174 */
2175/* ARGSUSED */
2176static int
2177Itk_ArchOptionRemoveCmd(dummy, interp, objc, objv)
2178    ClientData dummy;        /* unused */
2179    Tcl_Interp *interp;      /* current interpreter */
2180    int objc;                /* number of arguments */
2181    Tcl_Obj *CONST objv[];   /* argument objects */
2182{
2183    ItclClass *contextClass, *cdefn;
2184    ItclObject *contextObj;
2185    ArchInfo *info;
2186
2187    int i;
2188    char *name, *head, *tail, *sep, tmp;
2189    ItkClassOption *opt;
2190    GenericConfigOpt *generic;
2191    ArchComponent *archComp;
2192    Tcl_HashEntry *entry;
2193    Tcl_DString buffer;
2194
2195    /*
2196     *  Get the Archetype info associated with this widget.
2197     */
2198    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
2199        !contextObj) {
2200
2201        Tcl_ResetResult(interp);
2202        Tcl_AppendResult(interp,
2203            "cannot access options without an object context",
2204            (char*)NULL);
2205        return TCL_ERROR;
2206    }
2207
2208    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
2209        return TCL_ERROR;
2210    }
2211
2212    /*
2213     *  Scan through the list of options and locate each one.
2214     *  If it is on the option list, remove it.
2215     */
2216    for (i=1; i < objc; i++) {
2217        name = Tcl_GetStringFromObj(objv[i], (int*)NULL);
2218        Itcl_ParseNamespPath(name, &buffer, &head, &tail);
2219
2220        /*
2221         *  HANDLE:  class::option
2222         */
2223        if (head) {
2224            cdefn = Itcl_FindClass(interp, head, /* autoload */ 1);
2225            if (!cdefn) {
2226                Tcl_DStringFree(&buffer);
2227                return TCL_ERROR;
2228            }
2229
2230            opt = Itk_FindClassOption(cdefn, tail);
2231            if (!opt) {
2232                Tcl_AppendResult(interp,
2233                    "option \"", tail, "\" not defined in class \"",
2234                    cdefn->fullname, "\"",
2235                    (char*)NULL);
2236                Tcl_DStringFree(&buffer);
2237                return TCL_ERROR;
2238            }
2239
2240            Itk_RemoveArchOptionPart(info, opt->member->name,
2241                (ClientData)cdefn);
2242
2243            Tcl_DStringFree(&buffer);
2244            continue;
2245        }
2246        Tcl_DStringFree(&buffer);
2247
2248        /*
2249         *  HANDLE:  component.option
2250         */
2251        sep = strstr(name, ".");
2252        if (sep) {
2253            tmp = *sep;
2254            *sep = '\0';
2255            head = name;
2256            tail = sep+1;
2257
2258            entry = Tcl_FindHashEntry(&info->components, head);
2259            if (!entry) {
2260                Tcl_AppendResult(interp,
2261                    "name \"", head, "\" is not a component",
2262                    (char*)NULL);
2263                *sep = tmp;
2264                return TCL_ERROR;
2265            }
2266            *sep = tmp;
2267            archComp = (ArchComponent*)Tcl_GetHashValue(entry);
2268
2269            generic = Itk_CreateGenericOpt(interp, tail, archComp->accessCmd);
2270            if (!generic) {
2271                char msg[256];
2272                sprintf(msg, "\n    (while removing option \"%.100s\")",
2273                    name);
2274                Tcl_AddErrorInfo(interp, msg);
2275                return TCL_ERROR;
2276            }
2277
2278            Itk_RemoveArchOptionPart(info, generic->switchName,
2279                (ClientData)archComp);
2280
2281            Itk_DelGenericOpt(generic);
2282            continue;
2283        }
2284
2285        /*
2286         *  Anything else is an error.
2287         */
2288        Tcl_AppendResult(interp,
2289            "bad option \"", name, "\": should be one of...\n",
2290            "  class::option\n",
2291            "  component.option",
2292            (char*)NULL);
2293        return TCL_ERROR;
2294    }
2295
2296    return TCL_OK;
2297}
2298
2299
2300/*
2301 * ------------------------------------------------------------------------
2302 *  Itk_ArchCompAccessCmd()
2303 *
2304 *  Invoked by [incr Tcl] to handle the itk::Archetype::component method.
2305 *  Finds the requested component and invokes the <command> as a method
2306 *  on that component.
2307 *
2308 *  Handles the following syntax:
2309 *
2310 *      component
2311 *      component <name>
2312 *      component <name> <command> ?<arg> <arg>...?
2313 *
2314 *  With no arguments, this command returns the names of components
2315 *  that can be accessed from the current context.  Note that components
2316 *  respect public/protected/private declarations, so private and
2317 *  protected components may not be accessible from all namespaces.
2318 *
2319 *  If a component name is specified, then this command returns the
2320 *  window name for that component.
2321 *
2322 *  If a series of arguments follow the component name, they are treated
2323 *  as a method invocation, and dispatched to the component.
2324 *
2325 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
2326 * ------------------------------------------------------------------------
2327 */
2328/* ARGSUSED */
2329static int
2330Itk_ArchCompAccessCmd(dummy, interp, objc, objv)
2331    ClientData dummy;        /* unused */
2332    Tcl_Interp *interp;      /* current interpreter */
2333    int objc;                /* number of arguments */
2334    Tcl_Obj *CONST objv[];   /* argument objects */
2335{
2336    int i, result;
2337    char *token;
2338    CONST char *name, *val;
2339    Tcl_Namespace *callingNs;
2340    ItclClass *contextClass;
2341    ItclObject *contextObj;
2342    Itcl_CallFrame *framePtr;
2343    Tcl_HashEntry *entry;
2344    Tcl_HashSearch place;
2345    ArchInfo *info;
2346    ArchComponent *archComp;
2347    int cmdlinec;
2348    Tcl_Obj *objPtr, *cmdlinePtr, **cmdlinev;
2349
2350    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
2351        !contextObj) {
2352
2353        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
2354        Tcl_ResetResult(interp);
2355        Tcl_AppendResult(interp,
2356            "improper usage: should be \"object ",
2357            token, " ?name option arg arg...?\"",
2358            (char*)NULL);
2359        return TCL_ERROR;
2360    }
2361
2362    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
2363        return TCL_ERROR;
2364    }
2365
2366    framePtr = _Tcl_GetCallFrame(interp, 1);
2367    if (framePtr) {
2368        callingNs = framePtr->nsPtr;
2369    } else {
2370        callingNs = Tcl_GetGlobalNamespace(interp);
2371    }
2372
2373    /*
2374     *  With no arguments, return a list of components that can be
2375     *  accessed from the calling scope.
2376     */
2377    if (objc == 1) {
2378        entry = Tcl_FirstHashEntry(&info->components, &place);
2379        while (entry) {
2380            archComp = (ArchComponent*)Tcl_GetHashValue(entry);
2381            if (Itcl_CanAccess(archComp->member, callingNs)) {
2382                name = Tcl_GetHashKey(&info->components, entry);
2383                Tcl_AppendElement(interp, (CONST84 char *)name);
2384            }
2385            entry = Tcl_NextHashEntry(&place);
2386        }
2387        return TCL_OK;
2388    }
2389
2390    /*
2391     *  Make sure the requested component exists.
2392     */
2393    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
2394    entry = Tcl_FindHashEntry(&info->components, token);
2395    if (entry) {
2396        archComp = (ArchComponent*)Tcl_GetHashValue(entry);
2397    } else {
2398        archComp = NULL;
2399    }
2400
2401    if (archComp == NULL) {
2402        Tcl_AppendResult(interp,
2403            "name \"", token, "\" is not a component",
2404            (char*)NULL);
2405        return TCL_ERROR;
2406    }
2407
2408    if (!Itcl_CanAccess(archComp->member, callingNs)) {
2409        Tcl_AppendResult(interp,
2410            "can't access component \"", token, "\" from context \"",
2411            callingNs->fullName, "\"",
2412            (char*)NULL);
2413        return TCL_ERROR;
2414    }
2415
2416    /*
2417     *  If only the component name is specified, then return the
2418     *  window name for this component.
2419     */
2420    if (objc == 2) {
2421        val = Tcl_GetVar2(interp, "itk_component", token, 0);
2422        if (!val) {
2423            Tcl_ResetResult(interp);
2424            Tcl_AppendResult(interp,
2425                "internal error: cannot access itk_component(", token, ")",
2426                (char*)NULL);
2427
2428            if (contextObj->accessCmd) {
2429                Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
2430                Tcl_AppendToObj(resultPtr, " in widget \"", -1);
2431                Tcl_GetCommandFullName(contextObj->classDefn->interp,
2432                    contextObj->accessCmd, resultPtr);
2433                Tcl_AppendToObj(resultPtr, "\"", -1);
2434            }
2435            return TCL_ERROR;
2436        }
2437	/*
2438	 * Casting away CONST is safe because TCL_VOLATILE guarantees
2439	 * CONST treatment.
2440	 */
2441        Tcl_SetResult(interp, (char *) val, TCL_VOLATILE);
2442        return TCL_OK;
2443    }
2444
2445    /*
2446     *  Otherwise, treat the rest of the command line as a method
2447     *  invocation on the requested component.  Invoke the remaining
2448     *  command-line arguments as a method for that component.
2449     */
2450    cmdlinePtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
2451    Tcl_IncrRefCount(cmdlinePtr);
2452
2453    objPtr = Tcl_NewStringObj((char*)NULL, 0);
2454    Tcl_GetCommandFullName(interp, archComp->accessCmd, objPtr);
2455    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, objPtr);
2456
2457    for (i=2; i < objc; i++) {
2458        Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, objv[i]);
2459    }
2460
2461    (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
2462        &cmdlinec, &cmdlinev);
2463
2464    result = Itcl_EvalArgs(interp, cmdlinec, cmdlinev);
2465
2466    Tcl_DecrRefCount(cmdlinePtr);
2467
2468    return result;
2469}
2470
2471
2472/*
2473 * ------------------------------------------------------------------------
2474 *  Itk_ArchConfigureCmd()
2475 *
2476 *  Invoked by [incr Tcl] to handle the itk::Archetype::configure method.
2477 *  Mimics the usual Tk "configure" method for Archetype mega-widgets.
2478 *
2479 *      configure
2480 *      configure -name
2481 *      configure -name value ?-name value ...?
2482 *
2483 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
2484 * ------------------------------------------------------------------------
2485 */
2486/* ARGSUSED */
2487static int
2488Itk_ArchConfigureCmd(dummy, interp, objc, objv)
2489    ClientData dummy;        /* unused */
2490    Tcl_Interp *interp;      /* current interpreter */
2491    int objc;                /* number of arguments */
2492    Tcl_Obj *CONST objv[];   /* argument objects */
2493{
2494    int i;
2495    CONST char *val;
2496    char *token;
2497    ItclClass *contextClass;
2498    ItclObject *contextObj;
2499    ArchInfo *info;
2500    Tcl_HashEntry *entry;
2501    ArchOption *archOpt;
2502    Tcl_DString buffer;
2503
2504    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
2505        !contextObj) {
2506
2507        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
2508        Tcl_ResetResult(interp);
2509        Tcl_AppendResult(interp,
2510            "improper usage: should be \"object ",
2511            token, " ?-option? ?value -option value...?\"",
2512            (char*)NULL);
2513        return TCL_ERROR;
2514    }
2515
2516    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
2517        return TCL_ERROR;
2518    }
2519
2520    /*
2521     *  If there are no extra arguments, then return a list of all
2522     *  known configuration options.  Each option has the form:
2523     *    {name resName resClass init value}
2524     */
2525    if (objc == 1) {
2526        Tcl_DStringInit(&buffer);
2527
2528        for (i=0; i < info->order.len; i++) {
2529            archOpt = (ArchOption*)Tcl_GetHashValue(info->order.list[i]);
2530            val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
2531            if (!val) {
2532                Itk_ArchOptAccessError(interp, info, archOpt);
2533                Tcl_DStringFree(&buffer);
2534                return TCL_ERROR;
2535            }
2536
2537            Tcl_DStringStartSublist(&buffer);
2538            Tcl_DStringAppendElement(&buffer, archOpt->switchName);
2539            Tcl_DStringAppendElement(&buffer,
2540                (archOpt->resName) ? archOpt->resName : "");
2541            Tcl_DStringAppendElement(&buffer,
2542                (archOpt->resClass) ? archOpt->resClass : "");
2543            Tcl_DStringAppendElement(&buffer,
2544                (archOpt->init) ? archOpt->init : "");
2545            Tcl_DStringAppendElement(&buffer, val);
2546            Tcl_DStringEndSublist(&buffer);
2547        }
2548        Tcl_DStringResult(interp, &buffer);
2549        Tcl_DStringFree(&buffer);
2550        return TCL_OK;
2551    }
2552
2553    /*
2554     *  If there is just one argument, then query the information
2555     *  for that one argument and return:
2556     *    {name resName resClass init value}
2557     */
2558    else if (objc == 2) {
2559        token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
2560        entry = Tcl_FindHashEntry(&info->options, token);
2561        if (!entry) {
2562            Tcl_AppendResult(interp,
2563                "unknown option \"", token, "\"",
2564                (char*)NULL);
2565            return TCL_ERROR;
2566        }
2567
2568        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
2569        val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
2570        if (!val) {
2571            Itk_ArchOptAccessError(interp, info, archOpt);
2572            return TCL_ERROR;
2573        }
2574
2575        Tcl_AppendElement(interp, archOpt->switchName);
2576        Tcl_AppendElement(interp,
2577            (archOpt->resName) ? archOpt->resName : "");
2578        Tcl_AppendElement(interp,
2579            (archOpt->resClass) ? archOpt->resClass : "");
2580        Tcl_AppendElement(interp,
2581            (archOpt->init) ? archOpt->init : "");
2582        Tcl_AppendElement(interp, (CONST84 char *)val);
2583
2584        return TCL_OK;
2585    }
2586
2587    /*
2588     *  Otherwise, it must be a series of "-option value" assignments.
2589     *  Look up each option and assign the new value.
2590     */
2591    for (objc--,objv++; objc > 0; objc-=2, objv+=2) {
2592	char *value;
2593        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
2594        if (objc < 2) {
2595            Tcl_AppendResult(interp,
2596                "value for \"", token, "\" missing",
2597                (char*)NULL);
2598            return TCL_ERROR;
2599        }
2600        value = Tcl_GetStringFromObj(objv[1], (int*)NULL);
2601
2602        if (Itk_ArchConfigOption(interp, info, token, value) != TCL_OK) {
2603            return TCL_ERROR;
2604        }
2605    }
2606
2607    Tcl_ResetResult(interp);
2608    return TCL_OK;
2609}
2610
2611
2612/*
2613 * ------------------------------------------------------------------------
2614 *  Itk_ArchCgetCmd()
2615 *
2616 *  Invoked by [incr Tcl] to handle the itk::Archetype::cget method.
2617 *  Mimics the usual Tk "cget" method for Archetype mega-widgets.
2618 *
2619 *      cget -name
2620 *
2621 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
2622 * ------------------------------------------------------------------------
2623 */
2624/* ARGSUSED */
2625static int
2626Itk_ArchCgetCmd(dummy, interp, objc, objv)
2627    ClientData dummy;        /* unused */
2628    Tcl_Interp *interp;      /* current interpreter */
2629    int objc;                /* number of arguments */
2630    Tcl_Obj *CONST objv[];   /* argument objects */
2631{
2632    CONST char *token, *val;
2633    ItclClass *contextClass;
2634    ItclObject *contextObj;
2635    ArchInfo *info;
2636    Tcl_HashEntry *entry;
2637    ArchOption *archOpt;
2638
2639    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK ||
2640        !contextObj) {
2641
2642        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
2643        Tcl_ResetResult(interp);
2644        Tcl_AppendResult(interp,
2645            "improper usage: should be \"object ", token, " -option\"",
2646            (char*)NULL);
2647        return TCL_ERROR;
2648    }
2649
2650    if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) {
2651        return TCL_ERROR;
2652    }
2653
2654    if (objc != 2) {
2655        Tcl_WrongNumArgs(interp, 1, objv, "option");
2656        return TCL_ERROR;
2657    }
2658
2659    /*
2660     *  Look up the specified option and get its current value.
2661     */
2662    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
2663    entry = Tcl_FindHashEntry(&info->options, token);
2664    if (!entry) {
2665        Tcl_AppendResult(interp,
2666            "unknown option \"", token, "\"",
2667            (char*)NULL);
2668        return TCL_ERROR;
2669    }
2670
2671    archOpt = (ArchOption*)Tcl_GetHashValue(entry);
2672    val = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
2673    if (!val) {
2674        Itk_ArchOptAccessError(interp, info, archOpt);
2675        return TCL_ERROR;
2676    }
2677
2678    /*
2679     * Casting away CONST is safe because TCL_VOLATILE guarantees
2680     * CONST treatment.
2681     */
2682    Tcl_SetResult(interp, (char *) val, TCL_VOLATILE);
2683    return TCL_OK;
2684}
2685
2686
2687/*
2688 * ------------------------------------------------------------------------
2689 *  Itk_PropagateOption()
2690 *
2691 *  Invoked whenever a widget-based configuration option has been
2692 *  configured with a new value.  Propagates the new value down to
2693 *  the widget by invoking the "configure" method on the widget.
2694 *  This causes the widget to bring itself up to date automatically.
2695 *
2696 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
2697 *  message in the interpreter) if anything goes wrong.
2698 * ------------------------------------------------------------------------
2699 */
2700/* ARGSUSED */
2701static int
2702Itk_PropagateOption(interp, contextObj, cdata, newval)
2703    Tcl_Interp *interp;        /* interpreter managing the class */
2704    ItclObject *contextObj;    /* itcl object being configured */
2705    ClientData cdata;          /* command prefix to use for configuration */
2706    CONST char *newval;        /* new value for this option */
2707{
2708    ConfigCmdline *cmdlinePtr = (ConfigCmdline*)cdata;
2709    int result;
2710    Tcl_Obj *objPtr;
2711
2712    objPtr = Tcl_NewStringObj((CONST84 char *)newval, -1);
2713    Tcl_IncrRefCount(objPtr);
2714
2715    cmdlinePtr->objv[3] = objPtr;
2716    result = Itcl_EvalArgs(interp, 4, cmdlinePtr->objv);
2717
2718    Tcl_DecrRefCount(objPtr);
2719    return result;
2720}
2721
2722
2723/*
2724 * ------------------------------------------------------------------------
2725 *  Itk_PropagatePublicVar()
2726 *
2727 *  Invoked whenever a mega-widget configuration option containing
2728 *  a public variable part has been configured with a new value.
2729 *  Updates the public variable with the new value and invokes any
2730 *  "config" code associated with it.
2731 *
2732 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
2733 *  message in the interpreter) if anything goes wrong.
2734 * ------------------------------------------------------------------------
2735 */
2736/* ARGSUSED */
2737static int
2738Itk_PropagatePublicVar(interp, contextObj, cdata, newval)
2739    Tcl_Interp *interp;        /* interpreter managing the class */
2740    ItclObject *contextObj;    /* itcl object being configured */
2741    ClientData cdata;          /* command prefix to use for configuration */
2742    CONST char *newval;        /* new value for this option */
2743{
2744    ItclVarDefn *vdefn = (ItclVarDefn*)cdata;
2745
2746    int result;
2747    CONST char *val;
2748    ItclContext context;
2749    ItclMemberCode *mcode;
2750    Itcl_CallFrame *uplevelFramePtr, *oldFramePtr;
2751
2752    /*
2753     *  Update the public variable with the new option value.
2754     *  There should already be a call frame installed for handling
2755     *  instance variables, but make sure that the namespace context
2756     *  is the most-specific class, so that the public variable can
2757     *  be found.
2758     */
2759    result = Itcl_PushContext(interp, (ItclMember*)NULL,
2760        contextObj->classDefn, contextObj, &context);
2761
2762    if (result == TCL_OK) {
2763	/*
2764	 * Casting away CONST of newval only to satisfy Tcl 8.3 and
2765	 * earlier headers.
2766	 */
2767        val = Tcl_SetVar2(interp, vdefn->member->fullname, (char *) NULL,
2768            (char *) newval, TCL_LEAVE_ERR_MSG);
2769
2770        if (!val) {
2771            result = TCL_ERROR;
2772        }
2773        Itcl_PopContext(interp, &context);
2774    }
2775
2776    if (result != TCL_OK) {
2777        char msg[256];
2778        sprintf(msg, "\n    (error in configuration of public variable \"%.100s\")", vdefn->member->fullname);
2779        Tcl_AddErrorInfo(interp, msg);
2780        return TCL_ERROR;
2781    }
2782
2783    /*
2784     *  If this variable has some "config" code, invoke it now.
2785     *
2786     *  NOTE:  Invoke the "config" code in the class scope
2787     *    containing the data member.
2788     */
2789    mcode = vdefn->member->code;
2790    if (mcode && mcode->procPtr->bodyPtr) {
2791
2792        uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
2793        oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);
2794
2795        result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
2796            vdefn->member, contextObj, 0, (Tcl_Obj**)NULL);
2797
2798        (void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
2799
2800        if (result == TCL_OK) {
2801            Tcl_ResetResult(interp);
2802        } else {
2803            char msg[256];
2804            sprintf(msg, "\n    (error in configuration of public variable \"%.100s\")", vdefn->member->fullname);
2805            Tcl_AddErrorInfo(interp, msg);
2806        }
2807    }
2808
2809    return result;
2810}
2811
2812
2813/*
2814 * ------------------------------------------------------------------------
2815 *  Itk_ArchSetOption()
2816 *
2817 *  Sets a configuration option within an Archetype mega-widget.
2818 *  Changes the "itk_option" array to reflect the new value, but
2819 *  unlike Itk_ArchConfigOption(), this procedure does not update
2820 *  the widget by propagating changes or invoking any "config" code.
2821 *  It merely sets the widget state.  It is useful when a widget is
2822 *  first being constructed, to initialize option values.
2823 *
2824 *  NOTE:  This procedure assumes that there is a valid object context
2825 *    and a call frame supporting object data member access.  It is
2826 *    usually called from within the methods of the Archetype base
2827 *    class, so this is a good assumption.  If it is called anywhere
2828 *    else, the caller is responsible for installing the object context
2829 *    and setting up a call frame.
2830 *
2831 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
2832 *  message in the interpreter) if anything goes wrong.
2833 * ------------------------------------------------------------------------
2834 */
2835static int
2836Itk_ArchSetOption(interp, info, name, value)
2837    Tcl_Interp *interp;        /* interpreter managing this widget */
2838    ArchInfo *info;            /* Archetype info */
2839    CONST char *name;          /* name of configuration option */
2840    CONST char *value;               /* new value for configuration option */
2841{
2842    Tcl_HashEntry *entry;
2843    ArchOption *archOpt;
2844
2845    entry = Tcl_FindHashEntry(&info->options, name);
2846    if (!entry) {
2847        Tcl_AppendResult(interp,
2848            "unknown option \"", name, "\"",
2849            (char*)NULL);
2850        return TCL_ERROR;
2851    }
2852    archOpt = (ArchOption*)Tcl_GetHashValue(entry);
2853
2854    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
2855	    (CONST84 char *)value, 0)) {
2856        Itk_ArchOptAccessError(interp, info, archOpt);
2857        return TCL_ERROR;
2858    }
2859    return TCL_OK;
2860}
2861
2862
2863/*
2864 * ------------------------------------------------------------------------
2865 *  Itk_ArchConfigOption()
2866 *
2867 *  Sets a configuration option within an Archetype mega-widget.
2868 *  Changes the "itk_option" array to reflect the new value, and then
2869 *  invokes any option parts to handle the new setting or propagate
2870 *  the value down to component parts.
2871 *
2872 *  NOTE:  This procedure assumes that there is a valid object context
2873 *    and a call frame supporting object data member access.  It is
2874 *    usually called from within the methods of the Archetype base
2875 *    class, so this is a good assumption.  If it is called anywhere
2876 *    else, the caller is responsible for installing the object context
2877 *    and setting up a call frame.
2878 *
2879 *  Returns TCL_OK on success, or TCL_ERROR (along with an error
2880 *  message in the interpreter) if anything goes wrong.
2881 * ------------------------------------------------------------------------
2882 */
2883static int
2884Itk_ArchConfigOption(interp, info, name, value)
2885    Tcl_Interp *interp;        /* interpreter managing this widget */
2886    ArchInfo *info;            /* Archetype info */
2887    char *name;          /* name of configuration option */
2888    char *value;               /* new value for configuration option */
2889{
2890    int result;
2891    CONST char *v;
2892    char *lastval;
2893    Tcl_HashEntry *entry;
2894    ArchOption *archOpt;
2895    Itcl_ListElem *part;
2896    ArchOptionPart *optPart;
2897    Itcl_InterpState istate;
2898
2899    /*
2900     *  Query the "itk_option" array to get the current setting.
2901     */
2902    entry = Tcl_FindHashEntry(&info->options, name);
2903    if (!entry) {
2904        /* Bug 227876
2905	 * Ensure that the interp result is unshared.
2906	 */
2907
2908        Tcl_ResetResult (interp);
2909        Tcl_AppendResult(interp,
2910            "unknown option \"", name, "\"",
2911            (char*)NULL);
2912        return TCL_ERROR;
2913    }
2914    archOpt = (ArchOption*)Tcl_GetHashValue(entry);
2915
2916    v = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
2917    if (v) {
2918        lastval = (char*)ckalloc((unsigned)(strlen(v)+1));
2919        strcpy(lastval, v);
2920    } else {
2921        lastval = NULL;
2922    }
2923
2924    /*
2925     *  Update the "itk_option" array with the new setting.
2926     */
2927    if (!Tcl_SetVar2(interp, "itk_option", archOpt->switchName, value, 0)) {
2928        Itk_ArchOptAccessError(interp, info, archOpt);
2929        result = TCL_ERROR;
2930        goto configDone;
2931    }
2932
2933    /*
2934     *  Scan through all option parts to handle the new setting.
2935     */
2936    result = TCL_OK;
2937    part   = Itcl_FirstListElem(&archOpt->parts);
2938
2939    while (part) {
2940        optPart = (ArchOptionPart*)Itcl_GetListValue(part);
2941        result  = (*optPart->configProc)(interp, info->itclObj,
2942            optPart->clientData, value);
2943
2944        if (result != TCL_OK) {
2945            Itk_ArchOptConfigError(interp, info, archOpt);
2946            break;
2947        }
2948        part = Itcl_NextListElem(part);
2949    }
2950
2951    /*
2952     *  If the option configuration failed, then set the option
2953     *  back to its previous settings.  Scan back through all of
2954     *  the option parts and sync them up with the old value.
2955     */
2956    if (result == TCL_ERROR) {
2957        istate = Itcl_SaveInterpState(interp, result);
2958
2959        Tcl_SetVar2(interp, "itk_option", archOpt->switchName, lastval, 0);
2960
2961        part = Itcl_FirstListElem(&archOpt->parts);
2962        while (part) {
2963            optPart = (ArchOptionPart*)Itcl_GetListValue(part);
2964            (*optPart->configProc)(interp, info->itclObj,
2965                optPart->clientData, lastval);
2966
2967            part = Itcl_NextListElem(part);
2968        }
2969        result = Itcl_RestoreInterpState(interp, istate);
2970    }
2971
2972    archOpt->flags |= ITK_ARCHOPT_INIT;  /* option has been set */
2973
2974configDone:
2975    if (lastval) {
2976        ckfree(lastval);
2977    }
2978    return result;
2979}
2980
2981
2982/*
2983 * ------------------------------------------------------------------------
2984 *  Itk_ArchOptConfigError()
2985 *
2986 *  Simply utility which adds error information after a option
2987 *  configuration fails.  Adds traceback information to the given
2988 *  interpreter.
2989 * ------------------------------------------------------------------------
2990 */
2991static void
2992Itk_ArchOptConfigError(interp, info, archOpt)
2993    Tcl_Interp *interp;            /* interpreter handling this object */
2994    ArchInfo *info;                /* info associated with mega-widget */
2995    ArchOption *archOpt;           /* configuration option that failed */
2996{
2997    Tcl_Obj *objPtr;
2998
2999    objPtr = Tcl_NewStringObj((char*)NULL, 0);
3000    Tcl_IncrRefCount(objPtr);
3001
3002    Tcl_AppendToObj(objPtr, "\n    (while configuring option \"", -1);
3003    Tcl_AppendToObj(objPtr, archOpt->switchName, -1);
3004    Tcl_AppendToObj(objPtr, "\"", -1);
3005
3006    if (info->itclObj && info->itclObj->accessCmd) {
3007        Tcl_AppendToObj(objPtr, " for widget \"", -1);
3008        Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, objPtr);
3009        Tcl_AppendToObj(objPtr, "\")", -1);
3010    }
3011    Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
3012    Tcl_DecrRefCount(objPtr);
3013}
3014
3015
3016/*
3017 * ------------------------------------------------------------------------
3018 *  Itk_ArchOptAccessError()
3019 *
3020 *  Simply utility which adds error information after an option
3021 *  value access fails.  Adds traceback information to the given
3022 *  interpreter.
3023 * ------------------------------------------------------------------------
3024 */
3025static void
3026Itk_ArchOptAccessError(interp, info, archOpt)
3027    Tcl_Interp *interp;            /* interpreter handling this object */
3028    ArchInfo *info;                /* info associated with mega-widget */
3029    ArchOption *archOpt;           /* option that couldn't be accessed */
3030{
3031    Tcl_ResetResult(interp);
3032
3033    Tcl_AppendResult(interp,
3034        "internal error: cannot access itk_option(", archOpt->switchName, ")",
3035        (char*)NULL);
3036
3037    if (info->itclObj->accessCmd) {
3038        Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
3039        Tcl_AppendToObj(resultPtr, " in widget \"", -1);
3040        Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr);
3041        Tcl_AppendToObj(resultPtr, "\"", -1);
3042    }
3043}
3044
3045
3046/*
3047 * ------------------------------------------------------------------------
3048 *  Itk_GetArchInfo()
3049 *
3050 *  Finds the extra Archetype info associated with the given object.
3051 *  Returns TCL_OK and a pointer to the info if found.  Returns
3052 *  TCL_ERROR along with an error message in interp->result if not.
3053 * ------------------------------------------------------------------------
3054 */
3055static int
3056Itk_GetArchInfo(interp, contextObj, infoPtr)
3057    Tcl_Interp *interp;            /* interpreter handling this object */
3058    ItclObject *contextObj;        /* object with desired data */
3059    ArchInfo **infoPtr;            /* returns:  pointer to extra info */
3060{
3061    Tcl_HashTable *objsWithArchInfo;
3062    Tcl_HashEntry *entry;
3063
3064    /*
3065     *  If there is any problem finding the info, return an error.
3066     */
3067    objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
3068    entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);
3069
3070    if (!entry) {
3071        Tcl_AppendResult(interp,
3072            "internal error: no Archetype information for widget",
3073            (char*)NULL);
3074
3075        if (contextObj->accessCmd) {
3076            Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
3077            Tcl_AppendToObj(resultPtr, " \"", -1);
3078            Tcl_GetCommandFullName(interp, contextObj->accessCmd, resultPtr);
3079            Tcl_AppendToObj(resultPtr, "\"", -1);
3080        }
3081        return TCL_ERROR;
3082    }
3083
3084    /*
3085     *  Otherwise, return the requested info.
3086     */
3087    *infoPtr = (ArchInfo*)Tcl_GetHashValue(entry);
3088    return TCL_OK;
3089}
3090
3091
3092/*
3093 * ------------------------------------------------------------------------
3094 *  Itk_CreateArchComponent()
3095 *
3096 *  Creates the data representing a component widget within an Archetype
3097 *  mega-widget.  Each component has an access command that is used to
3098 *  communicate with it.  Each component is registered by its symbolic
3099 *  name in the "itk_component" array.
3100 *
3101 *  Returns a pointer to the new record.  If anything goes wrong,
3102 *  this returns NULL, along with an error message in the interpreter.
3103 * ------------------------------------------------------------------------
3104 */
3105static ArchComponent*
3106Itk_CreateArchComponent(interp, info, name, cdefn, accessCmd)
3107    Tcl_Interp *interp;            /* interpreter managing the object */
3108    ArchInfo *info;                /* info associated with mega-widget */
3109    char *name;                    /* symbolic name for this component */
3110    ItclClass *cdefn;              /* component created in this class */
3111    Tcl_Command accessCmd;         /* access command for component */
3112{
3113    CONST char *init;
3114    CONST char *wname;
3115    ArchComponent *archComp;
3116    ArchOption *archOpt;
3117    Tk_Window tkwin;
3118    Tcl_HashEntry *entry;
3119    Tcl_HashSearch place;
3120    ItclMember *memPtr;
3121
3122    /*
3123     *  Save this component in the itk_component() array.
3124     */
3125    wname = Tcl_GetCommandName(interp, accessCmd);
3126    Tcl_SetVar2(interp, "itk_component", name, (char *)wname, 0);
3127
3128    /*
3129     *  If the symbolic name for the component is "hull", then this
3130     *  is the toplevel or frame that embodies a mega-widget.  Update
3131     *  the Archtype info to include the window token.
3132     */
3133    tkwin = Tk_NameToWindow(interp, (char *)wname, Tk_MainWindow(interp));
3134
3135    if (strcmp(name, "hull") == 0) {
3136        if (tkwin == NULL) {
3137            Tcl_AppendResult(interp,
3138                "cannot find hull window with access command \"", wname, "\"",
3139                (char*)NULL);
3140            return NULL;
3141        }
3142        info->tkwin = tkwin;
3143
3144        /*
3145         *  We are now in a position to query configuration options
3146         *  relative to this window.  Scan through all existing options
3147         *  and update the initial values according to the X11 resource
3148         *  database.
3149         */
3150        entry = Tcl_FirstHashEntry(&info->options, &place);
3151        while (entry) {
3152            archOpt = (ArchOption*)Tcl_GetHashValue(entry);
3153
3154            init = NULL;
3155            if (archOpt->resName && archOpt->resClass) {
3156                init = Tk_GetOption(tkwin, archOpt->resName, archOpt->resClass);
3157            }
3158
3159            if (init && (!archOpt->init || strcmp(init, archOpt->init) != 0)) {
3160                if (!archOpt->init) {
3161                    ckfree(archOpt->init);
3162                }
3163                archOpt->init = (char*)ckalloc((unsigned)(strlen(init)+1));
3164                strcpy(archOpt->init, init);
3165
3166                if (Itk_ArchSetOption(interp, info,
3167                    archOpt->switchName, init) != TCL_OK) {
3168                    return NULL;
3169                }
3170            }
3171            entry = Tcl_NextHashEntry(&place);
3172        }
3173    }
3174
3175    /*
3176     *  Create the record to represent this component.
3177     */
3178    archComp = (ArchComponent*)ckalloc(sizeof(ArchComponent));
3179
3180    memPtr = (ItclMember*)ckalloc(sizeof(ItclMember));
3181    memPtr->interp      = interp;
3182    memPtr->classDefn   = cdefn;
3183    memPtr->name        = NULL;
3184    memPtr->fullname    = NULL;
3185    memPtr->flags       = 0;
3186    memPtr->protection  = ITCL_PUBLIC;
3187    memPtr->code        = NULL;
3188
3189    archComp->member     = memPtr;
3190    archComp->accessCmd  = accessCmd;
3191    archComp->tkwin      = tkwin;
3192    archComp->pathName   = (char *) ckalloc((unsigned)(strlen(wname)+1));
3193    strcpy(archComp->pathName, wname);
3194
3195    return archComp;
3196}
3197
3198
3199/*
3200 * ------------------------------------------------------------------------
3201 *  Itk_DelArchComponent()
3202 *
3203 *  Destroys an Archetype component record previously created by
3204 *  Itk_CreateArchComponent().
3205 * ------------------------------------------------------------------------
3206 */
3207static void
3208Itk_DelArchComponent(archComp)
3209    ArchComponent *archComp;  /* pointer to component data */
3210{
3211    ckfree((char*)archComp->member);
3212    ckfree((char*)archComp->pathName);
3213    ckfree((char*)archComp);
3214}
3215
3216
3217/*
3218 * ------------------------------------------------------------------------
3219 *  Itk_GetArchOption()
3220 *
3221 *  Finds or creates the data representing a composite configuration
3222 *  option for an Archetype mega-widget.  Each option acts as a single
3223 *  entity, but is composed of several parts which propagate changes
3224 *  down to the component widgets.  If the option already exists, then
3225 *  the specified resource name and resource class must match the
3226 *  existing definition.
3227 *
3228 *  If the option is created, an initial value for is determined by
3229 *  querying the X11 resource database, and if this fails, the
3230 *  hard-wired default value is used.
3231 *
3232 *  If successful, returns TCL_OK along with a pointer to the option
3233 *  record.  Returns TCL_ERROR (along with an error message in the
3234 *  interpreter) if anything goes wrong.
3235 * ------------------------------------------------------------------------
3236 */
3237static int
3238Itk_GetArchOption(interp, info, switchName, resName, resClass,
3239    defVal, currVal, aoPtr)
3240
3241    Tcl_Interp *interp;            /* interpreter managing the object */
3242    ArchInfo *info;                /* info for Archetype mega-widget */
3243    char *switchName;              /* name of command-line switch */
3244    char *resName;                 /* resource name in X11 database */
3245    char *resClass;                /* resource class name in X11 database */
3246    CONST char *defVal;            /* last-resort default value */
3247    char *currVal;                 /* current option value */
3248    ArchOption **aoPtr;            /* returns: option record */
3249{
3250    int result = TCL_OK;
3251
3252    int newEntry;
3253    char *name;
3254    ArchOption *archOpt;
3255    Tcl_HashEntry *entry;
3256
3257    /*
3258     *  If the switch does not have a leading "-", add it on.
3259     */
3260    if (*switchName != '-') {
3261        name = ckalloc((unsigned)(strlen(switchName)+2));
3262        *name = '-';
3263        strcpy(name+1, switchName);
3264    } else {
3265        name = switchName;
3266    }
3267
3268    /*
3269     *  See if an option already exists with the switch name.
3270     *  If it does, then make sure that the given resource name
3271     *  and resource class match the existing definition.
3272     */
3273    entry = Tcl_CreateHashEntry(&info->options, name, &newEntry);
3274    if (!newEntry) {
3275        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
3276
3277        if (resName && !archOpt->resName) {
3278            archOpt->resName = (char*)ckalloc((unsigned)(strlen(resName)+1));
3279            strcpy(archOpt->resName, resName);
3280        }
3281        else if (resName && strcmp(archOpt->resName, resName) != 0) {
3282            Tcl_AppendResult(interp,
3283                "bad resource name \"", resName, "\" for option \"",
3284                name, "\": should be \"", archOpt->resName, "\"",
3285                (char*)NULL);
3286            result = TCL_ERROR;
3287            goto getArchOptionDone;
3288        }
3289
3290        if (resClass && !archOpt->resClass) {
3291            archOpt->resClass = (char*)ckalloc((unsigned)(strlen(resClass)+1));
3292            strcpy(archOpt->resClass, resClass);
3293        }
3294        else if (resClass && strcmp(archOpt->resClass, resClass) != 0) {
3295            Tcl_AppendResult(interp,
3296                "bad resource class \"", resClass, "\" for option \"",
3297                name, "\": should be \"", archOpt->resClass, "\"",
3298                (char*)NULL);
3299            result = TCL_ERROR;
3300            goto getArchOptionDone;
3301        }
3302
3303        if (!archOpt->init) {
3304            Itk_InitArchOption(interp, info, archOpt, defVal, currVal);
3305        }
3306        *aoPtr = archOpt;
3307
3308        result = TCL_OK;
3309        goto getArchOptionDone;
3310    }
3311
3312    /*
3313     *  Create the record to represent this option, and save it
3314     *  in the option table.
3315     */
3316    archOpt = (ArchOption*)ckalloc(sizeof(ArchOption));
3317
3318    archOpt->switchName = (char*)ckalloc((unsigned)(strlen(name)+1));
3319    strcpy(archOpt->switchName, name);
3320
3321    if (resName) {
3322        archOpt->resName = (char*)ckalloc((unsigned)(strlen(resName)+1));
3323        strcpy(archOpt->resName, resName);
3324    }
3325    else {
3326        archOpt->resName = NULL;
3327    }
3328
3329    if (resClass) {
3330        archOpt->resClass = (char*)ckalloc((unsigned)(strlen(resClass)+1));
3331        strcpy(archOpt->resClass, resClass);
3332    }
3333    else {
3334        archOpt->resClass = NULL;
3335    }
3336
3337    archOpt->flags = 0;
3338    Itcl_InitList(&archOpt->parts);
3339
3340    archOpt->init = NULL;
3341    Itk_InitArchOption(interp,info,archOpt,defVal,currVal);
3342
3343    Tcl_SetHashValue(entry, (ClientData)archOpt);
3344    Itk_OptListAdd(&info->order, entry);
3345
3346    *aoPtr = archOpt;
3347
3348getArchOptionDone:
3349    if (name != switchName) {
3350        ckfree(name);
3351    }
3352    return result;
3353}
3354
3355/*
3356 * ------------------------------------------------------------------------
3357 *  Itk_InitArchOption()
3358 *
3359 *  Sets the initial value for a composite configuration option for
3360 *  an Archetype mega-widget.  This is usually invoked when an option
3361 *  is first created by Itk_GetArchOption().  It queries the X11
3362 *  resource database for an initial value, and if nothing is found,
3363 *  falls back on a last-resort value.  It stores the initial value
3364 *  in the "itk_option" array, adds a copy to the option info, and
3365 *  returns.
3366 *
3367 *  If successful, returns TCL_OK along with a pointer to the option
3368 *  record.  Returns TCL_ERROR (along with an error message in the
3369 *  interpreter) if anything goes wrong.
3370 * ------------------------------------------------------------------------
3371 */
3372static void
3373Itk_InitArchOption(interp, info, archOpt, defVal, currVal)
3374    Tcl_Interp *interp;            /* interpreter managing the object */
3375    ArchInfo *info;                /* info for Archetype mega-widget */
3376    ArchOption *archOpt;           /* option to initialize */
3377    CONST char *defVal;            /* last-resort default value */
3378    char *currVal;                 /* current option value */
3379{
3380    CONST char *init = NULL;
3381
3382    int result;
3383    CONST char *ival;
3384    char c;
3385    ItclContext context;
3386
3387    /*
3388     *  If the option is already initialized, then abort.
3389     */
3390    if (archOpt->init) {
3391        return;
3392    }
3393
3394    /*
3395     *  If this widget has a Tk window, query the X11 resource
3396     *  database for an initial option value.  If all else fails,
3397     *  use the hard-wired default value.
3398     */
3399    if (archOpt->resName && archOpt->resClass && info->tkwin != NULL) {
3400        init = Tk_GetOption(info->tkwin, archOpt->resName, archOpt->resClass);
3401    }
3402    if (init == NULL) {
3403        init = defVal;
3404    }
3405
3406    /*
3407     *  Normally, the initial value for the itk_option array is
3408     *  the same as the initial value for the option.  Watch
3409     *  out for the fixed Tk options (-class, -colormap, -screen
3410     *  and -visual).  Since these cannot be modified later,
3411     *  they must be set to their current value.
3412     */
3413    c = *(archOpt->switchName+1);
3414
3415    if ((c == 'c' && strcmp(archOpt->switchName,"-class") == 0) ||
3416        (c == 'c' && strcmp(archOpt->switchName,"-colormap") == 0) ||
3417        (c == 's' && strcmp(archOpt->switchName,"-screen") == 0) ||
3418        (c == 'v' && strcmp(archOpt->switchName,"-visual") == 0)) {
3419        ival = currVal;
3420    }
3421    else {
3422        ival = init;
3423    }
3424
3425    /*
3426     *  Set the initial value in the itk_option array.
3427     *  Since this might be called from the itk::option-parser
3428     *  namespace, reinstall the object context.
3429     */
3430    result = Itcl_PushContext(interp, (ItclMember*)NULL,
3431        info->itclObj->classDefn, info->itclObj, &context);
3432
3433    if (result == TCL_OK) {
3434	/*
3435	 * Casting away CONST of ival only to satisfy Tcl 8.3 and
3436	 * earlier headers.
3437	 */
3438        Tcl_SetVar2(interp, "itk_option", archOpt->switchName,
3439            (char *)((ival) ? ival : ""), 0);
3440        Itcl_PopContext(interp, &context);
3441    }
3442
3443    if (ival) {
3444        archOpt->init = (char*)ckalloc((unsigned)(strlen(ival)+1));
3445        strcpy(archOpt->init, ival);
3446    }
3447}
3448
3449/*
3450 * ------------------------------------------------------------------------
3451 *  Itk_DelArchOption()
3452 *
3453 *  Destroys an Archetype configuration option previously created by
3454 *  Itk_CreateArchOption().
3455 * ------------------------------------------------------------------------
3456 */
3457static void
3458Itk_DelArchOption(archOpt)
3459    ArchOption *archOpt;  /* pointer to option data */
3460{
3461    Itcl_ListElem *elem;
3462    ArchOptionPart *optPart;
3463
3464    /*
3465     *  Delete all "parts" relating to component widgets.
3466     */
3467    elem = Itcl_FirstListElem(&archOpt->parts);
3468    while (elem) {
3469        optPart = (ArchOptionPart*)Itcl_GetListValue(elem);
3470        Itk_DelOptionPart(optPart);
3471        elem = Itcl_DeleteListElem(elem);
3472    }
3473
3474    /*
3475     *  Free any remaining data.
3476     */
3477    ckfree(archOpt->switchName);
3478    if (archOpt->resName) {
3479        ckfree(archOpt->resName);
3480    }
3481    if (archOpt->resClass) {
3482        ckfree(archOpt->resClass);
3483    }
3484    if (archOpt->init) {
3485        ckfree(archOpt->init);
3486    }
3487    ckfree((char*)archOpt);
3488}
3489
3490
3491/*
3492 * ------------------------------------------------------------------------
3493 *  Itk_CreateOptionPart()
3494 *
3495 *  Creates the data representing a part within a configuration option
3496 *  for an Archetype mega-widget.  Each part has a bit of code used to
3497 *  apply configuration changes to some part of the mega-widget.
3498 *  This is characterized by a bit of ClientData, and a "config"
3499 *  procedure that knows how to execute it.  The ClientData is
3500 *  automatically disposed of by the delete proc when this option
3501 *  part is destroyed.
3502 *
3503 *  Option parts typically come from two sources:  Options defined
3504 *  in the class definition, and options propagated upward from
3505 *  component parts.
3506 *
3507 *  Returns a pointer to the new option part.
3508 * ------------------------------------------------------------------------
3509 */
3510static ArchOptionPart*
3511Itk_CreateOptionPart(interp, cdata, cproc, dproc, from)
3512    Tcl_Interp *interp;              /* interpreter handling this request */
3513    ClientData cdata;                /* data representing this part */
3514    Itk_ConfigOptionPartProc *cproc; /* proc used to apply config changes */
3515    Tcl_CmdDeleteProc *dproc;        /* proc used to clean up ClientData */
3516    ClientData from;                 /* who contributed this option */
3517{
3518    ArchOptionPart *optPart;
3519
3520    /*
3521     *  Create the record to represent this part of the option.
3522     */
3523    optPart = (ArchOptionPart*)ckalloc(sizeof(ArchOptionPart));
3524    optPart->clientData = cdata;
3525    optPart->configProc = cproc;
3526    optPart->deleteProc = dproc;
3527    optPart->from       = from;
3528
3529    return optPart;
3530}
3531
3532
3533/*
3534 * ------------------------------------------------------------------------
3535 *  Itk_AddOptionPart()
3536 *
3537 *  Integrates an option part into a composite configuration option
3538 *  for an Archetype mega-widget.  If a composite option does not
3539 *  yet exist with the specified switch name, it is created automatically.
3540 *
3541 *  Adds the option part onto the composite list, and reconfigures
3542 *  the widget to update this option properly.
3543 *
3544 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
3545 *  in the interpreter) if anything goes wrong.
3546 * ------------------------------------------------------------------------
3547 */
3548static int
3549Itk_AddOptionPart(interp, info, switchName, resName, resClass,
3550    defVal, currVal, optPart, raOpt)
3551
3552    Tcl_Interp *interp;              /* interpreter handling this request */
3553    ArchInfo *info;                  /* info for Archetype mega-widget */
3554    char *switchName;                /* name of command-line switch */
3555    char *resName;                   /* resource name in X11 database */
3556    char *resClass;                  /* resource class name in X11 database */
3557    CONST char *defVal;              /* last-resort default value */
3558    char *currVal;                   /* current value (or NULL) */
3559    ArchOptionPart *optPart;         /* part to be added in */
3560    ArchOption **raOpt;              /* returns: option containing new part */
3561{
3562    CONST char *init = NULL;
3563
3564    int result;
3565    ArchOption *archOpt;
3566    ItclContext context;
3567
3568    *raOpt = NULL;
3569
3570    /*
3571     *  Find or create a composite option for the mega-widget.
3572     */
3573    result = Itk_GetArchOption(interp, info, switchName, resName, resClass,
3574        defVal, currVal, &archOpt);
3575
3576    if (result != TCL_OK) {
3577        return TCL_ERROR;
3578    }
3579
3580    /*
3581     *  Add the option part to the composite option.  If the
3582     *  composite option has already been configured, then
3583     *  simply update this part to the current value.  Otherwise,
3584     *  leave the configuration to Itk_ArchInitCmd().
3585     */
3586    Itcl_AppendList(&archOpt->parts, (ClientData)optPart);
3587
3588    if ((archOpt->flags & ITK_ARCHOPT_INIT) != 0) {
3589
3590        result = Itcl_PushContext(interp, (ItclMember*)NULL,
3591            info->itclObj->classDefn, info->itclObj, &context);
3592
3593        if (result == TCL_OK) {
3594            init = Tcl_GetVar2(interp, "itk_option", archOpt->switchName, 0);
3595            Itcl_PopContext(interp, &context);
3596        }
3597
3598        if (!init) {
3599            Itk_ArchOptAccessError(interp, info, archOpt);
3600            return TCL_ERROR;
3601        }
3602
3603        if (!currVal || (strcmp(init,currVal) != 0)) {
3604            result  = (*optPart->configProc)(interp, info->itclObj,
3605                optPart->clientData, init);
3606
3607            if (result != TCL_OK) {
3608                Itk_ArchOptConfigError(interp, info, archOpt);
3609                return TCL_ERROR;
3610            }
3611        }
3612    }
3613
3614    *raOpt = archOpt;
3615    return TCL_OK;
3616}
3617
3618
3619/*
3620 * ------------------------------------------------------------------------
3621 *  Itk_FindArchOptionPart()
3622 *
3623 *  Searches for a specific piece of a composite configuration option
3624 *  for an Archetype mega-widget.  The specified name is treated as the
3625 *  "switch" name (e.g., "-option"), but this procedure will recognize
3626 *  it even without the leading "-".
3627 *
3628 *  Returns a pointer to the option with the matching switch name and
3629 *  source, or NULL if the option is not recognized.
3630 * ------------------------------------------------------------------------
3631 */
3632static ArchOptionPart*
3633Itk_FindArchOptionPart(info, switchName, from)
3634    ArchInfo *info;                /* info for Archetype mega-widget */
3635    char *switchName;              /* name of command-line switch */
3636    ClientData from;               /* who contributed this option */
3637{
3638    ArchOptionPart *optPart = NULL;
3639
3640    char *name;
3641    Tcl_HashEntry *entry;
3642    ArchOption *archOpt;
3643    ArchOptionPart *op;
3644    Itcl_ListElem *elem;
3645
3646    /*
3647     *  If the switch does not have a leading "-", add it on.
3648     */
3649    if (*switchName != '-') {
3650        name = ckalloc((unsigned)(strlen(switchName)+2));
3651        *name = '-';
3652        strcpy(name+1, switchName);
3653    } else {
3654        name = switchName;
3655    }
3656
3657    /*
3658     *  Look for a composite option, and then for a part with the
3659     *  matching source.
3660     */
3661    entry = Tcl_FindHashEntry(&info->options, name);
3662
3663    if (entry) {
3664        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
3665        elem = Itcl_FirstListElem(&archOpt->parts);
3666        while (elem) {
3667            op = (ArchOptionPart*)Itcl_GetListValue(elem);
3668            if (op->from == from) {
3669                optPart = op;
3670                break;
3671            }
3672            elem = Itcl_NextListElem(elem);
3673        }
3674    }
3675
3676    if (name != switchName) {
3677        ckfree(name);
3678    }
3679    return optPart;
3680}
3681
3682
3683/*
3684 * ------------------------------------------------------------------------
3685 *  Itk_RemoveArchOptionPart()
3686 *
3687 *  Searches for a specific piece of a composite configuration option
3688 *  for an Archetype mega-widget.  The specified name is treated as the
3689 *  "switch" name (e.g., "-option"), but this procedure will recognize
3690 *  it even without the leading "-".  If an option part with the
3691 *  specified name and source is found on the list, it is removed.
3692 *
3693 *  NOTE:  This procedure assumes that there is a valid object context
3694 *    and a call frame supporting object data member access.  It is
3695 *    usually called from within the methods of the Archetype base
3696 *    class, so this is a good assumption.  If it is called anywhere
3697 *    else, the caller is responsible for installing the object context
3698 *    and setting up a call frame.
3699 *
3700 *  Returns non-zero if the part was found and removed, and 0 otherwise.
3701 * ------------------------------------------------------------------------
3702 */
3703static int
3704Itk_RemoveArchOptionPart(info, switchName, from)
3705    ArchInfo *info;                /* info for Archetype mega-widget */
3706    char *switchName;              /* name of command-line switch */
3707    ClientData from;               /* who contributed this option */
3708{
3709    int result = 0;
3710
3711    char *name;
3712    Tcl_HashEntry *entry;
3713    ArchOption *archOpt;
3714    ArchOptionPart *op;
3715    Itcl_ListElem *elem;
3716
3717
3718    /*
3719     *  If the switch does not have a leading "-", add it on.
3720     */
3721    if (*switchName != '-') {
3722        name = ckalloc((unsigned)(strlen(switchName)+2));
3723        *name = '-';
3724        strcpy(name+1, switchName);
3725    } else {
3726        name = switchName;
3727    }
3728
3729    /*
3730     *  Look for a composite option, and then for a part with the
3731     *  matching source.  If found, remove it.
3732     */
3733    entry = Tcl_FindHashEntry(&info->options, name);
3734
3735    if (entry) {
3736        archOpt = (ArchOption*)Tcl_GetHashValue(entry);
3737        elem = Itcl_FirstListElem(&archOpt->parts);
3738        while (elem) {
3739            op = (ArchOptionPart*)Itcl_GetListValue(elem);
3740            if (op->from == from) {
3741                Itk_DelOptionPart(op);
3742                result = 1;
3743                elem = Itcl_DeleteListElem(elem);
3744            }
3745            else {
3746                elem = Itcl_NextListElem(elem);
3747            }
3748        }
3749
3750        /*
3751         *  If this option is now dead (no parts left), then
3752         *  remove it from the widget.  Be careful to delete it
3753         *  from the "itk_option" array as well.
3754         */
3755        if (Itcl_GetListLength(&archOpt->parts) == 0) {
3756            Tcl_UnsetVar2(info->itclObj->classDefn->interp,
3757                "itk_option", archOpt->switchName, 0);
3758
3759            Itk_DelArchOption(archOpt);
3760            Itk_OptListRemove(&info->order, entry);
3761            Tcl_DeleteHashEntry(entry);
3762        }
3763    }
3764
3765    if (name != switchName) {
3766        ckfree(name);
3767    }
3768    return result;
3769}
3770
3771
3772/*
3773 * ------------------------------------------------------------------------
3774 *  Itk_IgnoreArchOptionPart()
3775 *
3776 *  Removes the specified part from a composite configuration option
3777 *  for an Archetype mega-widget.  This is usually called before
3778 *  keeping or renaming an option, to make sure that the option
3779 *  is not already integrated elsewhere on the composite list.
3780 *  This also handles the action of "ignoring" a configuration option.
3781 *
3782 *  NOTE:  This procedure assumes that there is a valid object context
3783 *    and a call frame supporting object data member access.  It is
3784 *    usually called from within the methods of the Archetype base
3785 *    class, so this is a good assumption.  If it is called anywhere
3786 *    else, the caller is responsible for installing the object context
3787 *    and setting up a call frame.
3788 *
3789 *  Returns non-zero if the part was found and removed, and 0 otherwise.
3790 * ------------------------------------------------------------------------
3791 */
3792static int
3793Itk_IgnoreArchOptionPart(info, opt)
3794    ArchInfo *info;                /* info for Archetype mega-widget */
3795    GenericConfigOpt *opt;         /* part to be ignored */
3796{
3797    int result = 0;
3798
3799    Tcl_HashEntry *entry;
3800    ArchOptionPart *op;
3801    Itcl_ListElem *elem;
3802
3803    /*
3804     *  If the part is not integrated, then do nothing.
3805     *  Otherwise, find the missing part and remove it.
3806     */
3807    if (opt->integrated) {
3808        elem = Itcl_FirstListElem(&opt->integrated->parts);
3809        while (elem) {
3810            op = (ArchOptionPart*)Itcl_GetListValue(elem);
3811            if (op == opt->optPart) {
3812                Itk_DelOptionPart(op);
3813                result = 1;
3814                elem = Itcl_DeleteListElem(elem);
3815            }
3816            else {
3817                elem = Itcl_NextListElem(elem);
3818            }
3819        }
3820
3821        /*
3822         *  If this option is now dead (no parts left), then
3823         *  remove it from the widget.  Be careful to delete it
3824         *  from the "itk_option" array as well.
3825         */
3826        if (Itcl_GetListLength(&opt->integrated->parts) == 0) {
3827            Tcl_UnsetVar2(info->itclObj->classDefn->interp,
3828                "itk_option", opt->integrated->switchName, 0);
3829
3830            entry = Tcl_FindHashEntry(&info->options,
3831                opt->integrated->switchName);
3832
3833            if (entry) {
3834                Itk_OptListRemove(&info->order, entry);
3835                Tcl_DeleteHashEntry(entry);
3836            }
3837            Itk_DelArchOption(opt->integrated);
3838        }
3839
3840        /*
3841         *  Forget that this part was ever integrated.
3842         */
3843        opt->integrated = NULL;
3844        opt->optPart = NULL;
3845    }
3846    return result;
3847}
3848
3849
3850/*
3851 * ------------------------------------------------------------------------
3852 *  Itk_DelOptionPart()
3853 *
3854 *  Destroys part of an Archetype configuration option created by
3855 *  Itk_CreateOptionPart().
3856 * ------------------------------------------------------------------------
3857 */
3858static void
3859Itk_DelOptionPart(optPart)
3860    ArchOptionPart *optPart;  /* option part data to be destroyed */
3861{
3862    if (optPart->clientData && optPart->deleteProc) {
3863        (*optPart->deleteProc)(optPart->clientData);
3864    }
3865    ckfree((char*)optPart);
3866}
3867
3868
3869/*
3870 * ------------------------------------------------------------------------
3871 *  Itk_CreateConfigCmdline()
3872 *
3873 *  Creates the data representing a command line for a "configure"
3874 *  operation.  Each "configure" command has the following form:
3875 *
3876 *      <object> configure -<option> <value>
3877 *
3878 *  The first three arguments are created in this procedure.  The
3879 *  <value> argument is reinitialized each time the command is
3880 *  executed.
3881 *
3882 *  Returns a pointer to the new command record.
3883 * ------------------------------------------------------------------------
3884 */
3885static ConfigCmdline*
3886Itk_CreateConfigCmdline(interp, accessCmd, switchName)
3887    Tcl_Interp *interp;              /* interpreter handling this request */
3888    Tcl_Command accessCmd;           /* command for <object> being config'd */
3889    char *switchName;                /* switch name of option being config'd */
3890{
3891    int i;
3892    ConfigCmdline *cmdlinePtr;
3893    Tcl_Obj *objPtr;
3894
3895    /*
3896     *  Create the record to represent this part of the option.
3897     */
3898    cmdlinePtr = (ConfigCmdline*)ckalloc(sizeof(ConfigCmdline));
3899
3900    objPtr = Tcl_NewStringObj((char*)NULL, 0);
3901    Tcl_GetCommandFullName(interp, accessCmd, objPtr);
3902    cmdlinePtr->objv[0] = objPtr;
3903    cmdlinePtr->objv[1] = Tcl_NewStringObj("configure", -1);
3904    cmdlinePtr->objv[2] = Tcl_NewStringObj(switchName, -1);
3905
3906    for (i=0; i < 3; i++) {
3907        Tcl_IncrRefCount(cmdlinePtr->objv[i]);
3908    }
3909    return cmdlinePtr;
3910}
3911
3912/*
3913 * ------------------------------------------------------------------------
3914 *  Itk_DeleteConfigCmdline()
3915 *
3916 *  Deletes the data created by Itk_CreateConfigCmdline.  Called
3917 *  when an option part is deleted to free up the memory associated
3918 *  with the configure command.
3919 * ------------------------------------------------------------------------
3920 */
3921static void
3922Itk_DeleteConfigCmdline(cdata)
3923    ClientData cdata;                /* command to be freed */
3924{
3925    ConfigCmdline *cmdlinePtr = (ConfigCmdline*)cdata;
3926    int i;
3927
3928    /*
3929     *  TRICKY NOTE:  Decrement the reference counts for only the
3930     *    first three arguments on the command line.  The fourth
3931     *    argument is released after each configure operation.
3932     */
3933    for (i=0; i < 3; i++) {
3934        Tcl_DecrRefCount(cmdlinePtr->objv[i]);
3935    }
3936    ckfree((char*)cmdlinePtr);
3937}
3938
3939
3940/*
3941 * ------------------------------------------------------------------------
3942 *  Itk_CreateGenericOptTable()
3943 *
3944 *  Parses a string describing a widget's configuration options (of the
3945 *  form returned by the usual widget "configure" method) and creates
3946 *  a hash table for easy lookup of option information.  Entries in
3947 *  the hash table are indexed by switch names like "-background".
3948 *  Values are GenericConfigOpt records.  Alias options like "-bg" are
3949 *  ignored.
3950 *
3951 *  This table is used by option parsing commands in "itk::option-parser"
3952 *  to validate widget options.
3953 *
3954 *  Returns a pointer to a new hash table, which should later be freed
3955 *  via Itk_DelGenericOptTable().  Returns NULL if an error is found in
3956 *  the configuration list.
3957 * ------------------------------------------------------------------------
3958 */
3959static Tcl_HashTable*
3960Itk_CreateGenericOptTable(interp, options)
3961    Tcl_Interp *interp;          /* interpreter handling this request */
3962    char *options;               /* string description of config options */
3963{
3964    int confc;
3965    char **confv = NULL;
3966    int optc;
3967    char **optv = NULL;
3968
3969    int i, newEntry;
3970    Tcl_HashTable *tPtr;
3971    Tcl_HashEntry *entry;
3972    GenericConfigOpt *info;
3973
3974    tPtr = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
3975    Tcl_InitHashTable(tPtr, TCL_STRING_KEYS);
3976
3977    /*
3978     *  Split the list of options and store each one in the table.
3979     *  Only consider options with all 5 required components.  Avoid
3980     *  aliases like "-bg".
3981     */
3982    if (Tcl_SplitList(interp, options, &confc, &confv) != TCL_OK) {
3983        goto tableFail;
3984    }
3985    for (i=0; i < confc; i++) {
3986        if (Tcl_SplitList(interp, confv[i], &optc, &optv) != TCL_OK) {
3987            goto tableFail;
3988        }
3989        if (optc == 5) {    /* avoid aliased options */
3990            entry = Tcl_CreateHashEntry(tPtr, optv[0], &newEntry);
3991            if (newEntry) {
3992                info = (GenericConfigOpt*)ckalloc(sizeof(GenericConfigOpt));
3993                info->switchName = optv[0];
3994                info->resName    = optv[1];
3995                info->resClass   = optv[2];
3996                info->init       = optv[3];
3997                info->value      = optv[4];
3998                info->storage    = optv;
3999                info->integrated = NULL;
4000                info->optPart    = NULL;
4001                Tcl_SetHashValue(entry, (ClientData)info);
4002            }
4003        }
4004        else {
4005            ckfree((char*)optv);
4006        }
4007    }
4008
4009    ckfree((char*)confv);
4010    return tPtr;
4011
4012tableFail:
4013    if (confv) {
4014        ckfree((char*)confv);
4015    }
4016    Itk_DelGenericOptTable(tPtr);
4017    return NULL;
4018}
4019
4020
4021/*
4022 * ------------------------------------------------------------------------
4023 *  Itk_DelGenericOptTable()
4024 *
4025 *  Destroys an option table previously created by
4026 *  Itk_CreateGenericOptTable() and frees all memory associated with it.
4027 *  Should be called whenever a table is no longer needed, to free up
4028 *  resources.
4029 * ------------------------------------------------------------------------
4030 */
4031static void
4032Itk_DelGenericOptTable(tPtr)
4033    Tcl_HashTable *tPtr;  /* option table to be destroyed */
4034{
4035    Tcl_HashEntry *entry;
4036    Tcl_HashSearch place;
4037    GenericConfigOpt *info;
4038
4039    /*
4040     *  Scan through all options in the table and free entries.
4041     */
4042    entry = Tcl_FirstHashEntry(tPtr, &place);
4043    while (entry) {
4044        info = (GenericConfigOpt*)Tcl_GetHashValue(entry);
4045        ckfree((char*)info->storage);
4046        ckfree((char*)info);
4047        entry = Tcl_NextHashEntry(&place);
4048    }
4049
4050    Tcl_DeleteHashTable(tPtr);
4051    ckfree((char*)tPtr);
4052}
4053
4054
4055/*
4056 * ------------------------------------------------------------------------
4057 *  Itk_CreateGenericOpt()
4058 *
4059 *  Parses a string describing a widget's configuration option (of the
4060 *  form returned by the usual widget "configure" method) and creates
4061 *  a representation for one option.  Similar to
4062 *  Itk_CreateGenericOptTable(), but only handles one option at a
4063 *  time.
4064 *
4065 *  Returns a pointer to the option info, which should later be freed
4066 *  via Itk_DelGenericOpt().  Returns NULL (along with an error
4067 *  message in the interpreter) if an error is found.
4068 *
4069 *  SIDE EFFECT:  Resets the interpreter result.
4070 * ------------------------------------------------------------------------
4071 */
4072static GenericConfigOpt*
4073Itk_CreateGenericOpt(interp, switchName, accessCmd)
4074    Tcl_Interp *interp;          /* interpreter handling this request */
4075    char *switchName;            /* command-line switch for option */
4076    Tcl_Command accessCmd;       /* access command for component */
4077{
4078    GenericConfigOpt *genericOpt = NULL;
4079    Tcl_Obj *codePtr = NULL;
4080
4081    int optc, result;
4082    char **optv;
4083    char *name, *info;
4084    Tcl_Obj *resultPtr;
4085
4086    /*
4087     *  If the switch does not have a leading "-", add it on.
4088     */
4089    if (*switchName != '-') {
4090        name = ckalloc((unsigned)(strlen(switchName)+2));
4091        *name = '-';
4092        strcpy(name+1, switchName);
4093    } else {
4094        name = switchName;
4095    }
4096
4097    /*
4098     *  Build a "configure" command to query info for the requested
4099     *  option.  Evaluate the command and get option info.
4100     */
4101    codePtr = Tcl_NewStringObj((char*)NULL, 0);
4102    Tcl_IncrRefCount(codePtr);
4103
4104    Tcl_GetCommandFullName(interp, accessCmd, codePtr);
4105    Tcl_AppendToObj(codePtr, " configure ", -1);
4106    Tcl_AppendToObj(codePtr, name, -1);
4107
4108    if (Tcl_EvalObj(interp, codePtr) != TCL_OK) {
4109        goto optionDone;
4110    }
4111
4112    /*
4113     *  Only consider options with all 5 required components.  Avoid
4114     *  aliases like "-bg".
4115     */
4116    resultPtr = Tcl_GetObjResult(interp);
4117    Tcl_IncrRefCount(resultPtr);
4118    info = Tcl_GetStringFromObj(resultPtr, (int*)NULL);
4119
4120    result = Tcl_SplitList(interp, info, &optc, &optv);
4121
4122    Tcl_DecrRefCount(resultPtr);
4123
4124    if (result != TCL_OK) {
4125        goto optionDone;
4126    }
4127    if (optc == 5) {    /* avoid aliased options */
4128        genericOpt = (GenericConfigOpt*)ckalloc(sizeof(GenericConfigOpt));
4129        genericOpt->switchName = optv[0];
4130        genericOpt->resName    = optv[1];
4131        genericOpt->resClass   = optv[2];
4132        genericOpt->init       = optv[3];
4133        genericOpt->value      = optv[4];
4134        genericOpt->storage    = optv;
4135        genericOpt->integrated = NULL;
4136        genericOpt->optPart    = NULL;
4137    }
4138    else {
4139        ckfree((char*)optv);
4140    }
4141
4142optionDone:
4143    if (name != switchName) {
4144        ckfree(name);
4145    }
4146    if (codePtr) {
4147        Tcl_DecrRefCount(codePtr);
4148    }
4149    if (genericOpt) {
4150        Tcl_ResetResult(interp);
4151    }
4152    return genericOpt;
4153}
4154
4155
4156/*
4157 * ------------------------------------------------------------------------
4158 *  Itk_DelGenericOpt()
4159 *
4160 *  Destroys a generic option previously created by Itk_CreateGenericOpt()
4161 *  and frees all memory associated with it.  Should be called whenever
4162 *  an option representation is no longer needed, to free up resources.
4163 * ------------------------------------------------------------------------
4164 */
4165static void
4166Itk_DelGenericOpt(opt)
4167    GenericConfigOpt *opt;  /* option info to be destroyed */
4168{
4169    ckfree((char*)opt->storage);
4170    ckfree((char*)opt);
4171}
4172
4173
4174/*
4175 * ------------------------------------------------------------------------
4176 *  ItkGetObjsWithArchInfo()
4177 *
4178 *  Returns a pointer to a hash table containing the list of registered
4179 *  objects in the specified interpreter.  If the hash table does not
4180 *  already exist, it is created.
4181 * ------------------------------------------------------------------------
4182 */
4183static Tcl_HashTable*
4184ItkGetObjsWithArchInfo(interp)
4185    Tcl_Interp *interp;  /* interpreter handling this registration */
4186{
4187    Tcl_HashTable* objTable;
4188
4189    /*
4190     *  If the registration table does not yet exist, then create it.
4191     */
4192    objTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
4193        "itk_objsWithArchInfo", (Tcl_InterpDeleteProc**)NULL);
4194
4195    if (!objTable) {
4196        objTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
4197        Tcl_InitHashTable(objTable, TCL_ONE_WORD_KEYS);
4198        Tcl_SetAssocData(interp, "itk_objsWithArchInfo",
4199            ItkFreeObjsWithArchInfo, (ClientData)objTable);
4200    }
4201    return objTable;
4202}
4203
4204/*
4205 * ------------------------------------------------------------------------
4206 *  ItkFreeObjsWithArchInfo()
4207 *
4208 *  When an interpreter is deleted, this procedure is called to
4209 *  free up the associated data created by ItkGetObjsWithArchInfo.
4210 * ------------------------------------------------------------------------
4211 */
4212static void
4213ItkFreeObjsWithArchInfo(clientData, interp)
4214    ClientData clientData;       /* associated data */
4215    Tcl_Interp *interp;          /* interpreter being freed */
4216{
4217    Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
4218    Tcl_HashSearch place;
4219    Tcl_HashEntry *entry;
4220
4221    entry = Tcl_FirstHashEntry(tablePtr, &place);
4222    while (entry) {
4223        Itk_DelArchInfo( Tcl_GetHashValue(entry) );
4224        entry = Tcl_NextHashEntry(&place);
4225    }
4226
4227    Tcl_DeleteHashTable(tablePtr);
4228    ckfree((char*)tablePtr);
4229}
4230