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