util/src/TclTk/tcl8.6.12/pkgs/itcl4.2.2/generic/itclBuiltin.c

   1 /*
   2  * ------------------------------------------------------------------------
   3  *      PACKAGE:  [incr Tcl]
   4  *  DESCRIPTION:  Object-Oriented Extensions to Tcl
   5  *
   6  *  [incr Tcl] provides object-oriented extensions to Tcl, much as
   7  *  C++ provides object-oriented extensions to C.  It provides a means
   8  *  of encapsulating related procedures together with their shared data
   9  *  in a local namespace that is hidden from the outside world.  It
  10  *  promotes code re-use through inheritance.  More than anything else,
  11  *  it encourages better organization of Tcl applications through the
  12  *  object-oriented paradigm, leading to code that is easier to
  13  *  understand and maintain.
  14  *
  15  *  These procedures handle built-in class methods, including the
  16  *  "isa" method (to query hierarchy info) and the "info" method
  17  *  (to query class/object data).
  18  *
  19  * ========================================================================
  20  *  AUTHOR:  Michael J. McLennan
  21  *           Bell Labs Innovations for Lucent Technologies
  22  *           mmclennan@lucent.com
  23  *           http://www.tcltk.com/itcl
  24  *
  25  *  overhauled version author: Arnulf Wiedemann
  26  * ========================================================================
  27  *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
  28  * ------------------------------------------------------------------------
  29  * See the file "license.terms" for information on usage and redistribution
  30  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  31  */
  32 #include "itclInt.h"
  33
  34 static char initHullCmdsScript[] =
  35 "namespace eval ::itcl {\n"
  36 "    proc _find_hull_init {} {\n"
  37 "        global env tcl_library\n"
  38 "        variable library\n"
  39 "        variable patchLevel\n"
  40 "        rename _find_hull_init {}\n"
  41 "        if {[info exists library]} {\n"
  42 "            lappend dirs $library\n"
  43 "        } else {\n"
  44 "            set dirs {}\n"
  45 "            if {[info exists env(ITCL_LIBRARY)]} {\n"
  46 "                lappend dirs $env(ITCL_LIBRARY)\n"
  47 "            }\n"
  48 "            lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n"
  49 "            set bindir [file dirname [info nameofexecutable]]\n"
  50 "           lappend dirs [file join . library]\n"
  51 "            lappend dirs [file join $bindir .. lib itcl$patchLevel]\n"
  52 "            lappend dirs [file join $bindir .. library]\n"
  53 "            lappend dirs [file join $bindir .. .. library]\n"
  54 "            lappend dirs [file join $bindir .. .. itcl library]\n"
  55 "            lappend dirs [file join $bindir .. .. .. itcl library]\n"
  56 "            lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n"
  57 "            # On MacOSX, check the directories in the tcl_pkgPath\n"
  58 "            if {[string equal $::tcl_platform(platform) \"unix\"] && "
  59 "                    [string equal $::tcl_platform(os) \"Darwin\"]} {\n"
  60 "                foreach d $::tcl_pkgPath {\n"
  61 "                    lappend dirs [file join $d itcl$patchLevel]\n"
  62 "                }\n"
  63 "            }\n"
  64 "            # On *nix, check the directories in the tcl_pkgPath\n"
  65 "            if {[string equal $::tcl_platform(platform) \"unix\"]} {\n"
  66 "                foreach d $::tcl_pkgPath {\n"
  67 "                    lappend dirs $d\n"
  68 "                    lappend dirs [file join $d itcl$patchLevel]\n"
  69 "                }\n"
  70 "            }\n"
  71 "        }\n"
  72 "        foreach i $dirs {\n"
  73 "            set library $i\n"
  74 "            set itclfile [file join $i itclHullCmds.tcl]\n"
  75 "            if {![catch {uplevel #0 [list source $itclfile]} msg]} {\n"
  76 "                return\n"
  77 "            }\n"
  78 "puts stderr \"MSG!$msg!\"\n"
  79 "        }\n"
  80 "        set msg \"Can't find a usable itclHullCmds.tcl in the following directories:\n\"\n"
  81 "        append msg \"    $dirs\n\"\n"
  82 "        append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n"
  83 "        append msg \"If you know where the Itcl library directory was installed,\n\"\n"
  84 "        append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n"
  85 "        append msg \"to the library directory.\n\"\n"
  86 "        error $msg\n"
  87 "    }\n"
  88 "    _find_hull_init\n"
  89 "}";
  90
  91 static Tcl_ObjCmdProc Itcl_BiDestroyCmd;
  92 static Tcl_ObjCmdProc ItclExtendedConfigure;
  93 static Tcl_ObjCmdProc ItclExtendedCget;
  94 static Tcl_ObjCmdProc ItclExtendedSetGet;
  95 static Tcl_ObjCmdProc Itcl_BiCreateHullCmd;
  96 static Tcl_ObjCmdProc Itcl_BiSetupComponentCmd;
  97 static Tcl_ObjCmdProc Itcl_BiKeepComponentOptionCmd;
  98 static Tcl_ObjCmdProc Itcl_BiIgnoreComponentOptionCmd;
  99 static Tcl_ObjCmdProc Itcl_BiInitOptionsCmd;
 100
 101 /*
 102  *  FORWARD DECLARATIONS
 103  */
 104 static Tcl_Obj* ItclReportPublicOpt(Tcl_Interp *interp,
 105     ItclVariable *ivPtr, ItclObject *contextIoPtr);
 106
 107 static Tcl_ObjCmdProc ItclBiClassUnknownCmd;
 108 /*
 109  *  Standard list of built-in methods for all objects.
 110  */
 111 typedef struct BiMethod {
 112     const char* name;        /* method name */
 113     const char* usage;       /* string describing usage */
 114     const char* registration;/* registration name for C proc */
 115     Tcl_ObjCmdProc *proc;    /* implementation C proc */
 116     int flags;               /* flag for which type of class to be used */
 117 } BiMethod;
 118
 119 static const BiMethod BiMethodList[] = {
 120     { "callinstance",
 121         "<instancename>",
 122         "@itcl-builtin-callinstance",
 123         Itcl_BiCallInstanceCmd,
 124         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 125     },
 126     { "getinstancevar",
 127         "<instancename>",
 128         "@itcl-builtin-getinstancevar",
 129         Itcl_BiGetInstanceVarCmd,
 130         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 131     },
 132     { "cget",
 133         "-option",
 134         "@itcl-builtin-cget",
 135         Itcl_BiCgetCmd,
 136         ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 137     },
 138     { "configure",
 139         "?-option? ?value -option value...?",
 140         "@itcl-builtin-configure",
 141         Itcl_BiConfigureCmd,
 142         ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 143     },
 144     {"createhull",
 145         "widgetType widgetPath ?-class className? ?optionName value ...?",
 146         "@itcl-builtin-createhull",
 147         Itcl_BiCreateHullCmd,
 148         ITCL_ECLASS
 149     },
 150     { "destroy",
 151         "",
 152         "@itcl-builtin-destroy",
 153         Itcl_BiDestroyCmd,
 154         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 155     },
 156     { "installcomponent",
 157         "<componentName> using <classname> <winpath> ?-option value...?",
 158         "@itcl-builtin-installcomponent",
 159         Itcl_BiInstallComponentCmd,
 160         ITCL_WIDGET
 161     },
 162     { "itcl_hull",
 163         "",
 164         "@itcl-builtin-itcl_hull",
 165         Itcl_BiItclHullCmd,
 166         ITCL_WIDGET|ITCL_WIDGETADAPTOR
 167     },
 168     { "isa",
 169         "className",
 170         "@itcl-builtin-isa",
 171         Itcl_BiIsaCmd,
 172         ITCL_CLASS|ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET
 173     },
 174     {"itcl_initoptions",
 175         "?optionName value ...?",
 176         "@itcl-builtin-initoptions",
 177         Itcl_BiInitOptionsCmd,
 178         ITCL_ECLASS
 179     },
 180     { "mymethod",
 181         "",
 182         "@itcl-builtin-mymethod",
 183         Itcl_BiMyMethodCmd,
 184         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 185     },
 186     { "myvar",
 187         "",
 188         "@itcl-builtin-myvar",
 189         Itcl_BiMyVarCmd,
 190         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 191     },
 192     { "myproc",
 193         "",
 194         "@itcl-builtin-myproc",
 195         Itcl_BiMyProcCmd,
 196         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 197     },
 198     { "mytypemethod",
 199         "",
 200         "@itcl-builtin-mytypemethod",
 201         Itcl_BiMyTypeMethodCmd,
 202         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 203     },
 204     { "mytypevar",
 205         "",
 206         "@itcl-builtin-mytypevar",
 207         Itcl_BiMyTypeVarCmd,
 208         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 209     },
 210     { "setget",
 211         "varName ?value?",
 212         "@itcl-builtin-setget",
 213         ItclExtendedSetGet,
 214         ITCL_ECLASS
 215     },
 216     { "unknown",
 217         "",
 218         "@itcl-builtin-classunknown",
 219         ItclBiClassUnknownCmd,
 220         ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR
 221     },
 222     {"keepcomponentoption",
 223         "componentName optionName ?optionName ...?",
 224         "@itcl-builtin-keepcomponentoption",
 225         Itcl_BiKeepComponentOptionCmd,
 226         ITCL_ECLASS
 227     },
 228     {"ignorecomponentoption",
 229         "componentName optionName ?optionName ...?",
 230         "@itcl-builtin-ignorecomponentoption",
 231         Itcl_BiIgnoreComponentOptionCmd,
 232         ITCL_ECLASS
 233     },
 234     /* the next 3 are defined in library/itclHullCmds.tcl */
 235     {"addoptioncomponent",
 236         "componentName optionName ?optionName ...?",
 237         "@itcl-builtin-addoptioncomponent",
 238         NULL,
 239         ITCL_ECLASS
 240     },
 241     {"ignoreoptioncomponent",
 242         "componentName optionName ?optionName ...?",
 243         "@itcl-builtin-ignoreoptioncomponent",
 244         NULL,
 245         ITCL_ECLASS
 246     },
 247     {"renameoptioncomponent",
 248         "componentName optionName ?optionName ...?",
 249         "@itcl-builtin-renameoptioncomponent",
 250         NULL,
 251         ITCL_ECLASS
 252     },
 253     {"setupcomponent",
 254         "componentName using widgetType widgetPath ?optionName value ...?",
 255         "@itcl-builtin-setupcomponent",
 256         Itcl_BiSetupComponentCmd,
 257         ITCL_ECLASS
 258     },
 259 };
 260 static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
 261
 262 \f
 263 /*
 264  * ------------------------------------------------------------------------
 265  *  ItclRestoreInfoVars()
 266  *
 267  *  Delete callback to restore original "info" ensemble (revert inject of Itcl)
 268  *
 269  * ------------------------------------------------------------------------
 270  */
 271
 272 void
 273 ItclRestoreInfoVars(
 274     ClientData clientData)
 275 {
 276     ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
 277     Tcl_Interp *interp = infoPtr->interp;
 278     Tcl_Command cmd;
 279     Tcl_Obj *mapDict;
 280
 281     cmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
 282     if (cmd == NULL || !Tcl_IsEnsemble(cmd)) {
 283         goto done;
 284     }
 285     Tcl_GetEnsembleMappingDict(NULL, cmd, &mapDict);
 286     if (mapDict == NULL) {
 287         goto done;
 288     }
 289     if (infoPtr->infoVarsPtr == NULL || infoPtr->infoVars4Ptr == NULL) {
 290         /* Safety */
 291         goto done;
 292     }
 293     Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr, infoPtr->infoVarsPtr);
 294     Tcl_SetEnsembleMappingDict(interp, cmd, mapDict);
 295
 296 done:
 297     if (infoPtr->infoVarsPtr) {
 298         Tcl_DecrRefCount(infoPtr->infoVarsPtr);
 299         infoPtr->infoVarsPtr = NULL;
 300     }
 301     if (infoPtr->infoVars4Ptr) {
 302         Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
 303         infoPtr->infoVars4Ptr = NULL;
 304     }
 305 }
 306
 307 \f
 308 /*
 309  * ------------------------------------------------------------------------
 310  *  Itcl_BiInit()
 311  *
 312  *  Creates a namespace full of built-in methods/procs for [incr Tcl]
 313  *  classes.  This includes things like the "isa" method and "info"
 314  *  for querying class info.  Usually invoked by Itcl_Init() when
 315  *  [incr Tcl] is first installed into an interpreter.
 316  *
 317  *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 318  * ------------------------------------------------------------------------
 319  */
 320
 321 int
 322 Itcl_BiInit(
 323     Tcl_Interp *interp,      /* current interpreter */
 324     ItclObjectInfo *infoPtr)
 325 {
 326     Tcl_Namespace *itclBiNs;
 327     Tcl_DString buffer;
 328     Tcl_Obj *mapDict;
 329     Tcl_Command infoCmd;
 330     int result;
 331     int i;
 332
 333     /*
 334      *  "::itcl::builtin" commands.
 335      *  These commands are imported into each class
 336      *  just before the class definition is parsed.
 337      */
 338     Tcl_DStringInit(&buffer);
 339     for (i=0; i < BiMethodListLen; i++) {
 340         Tcl_DStringSetLength(&buffer, 0);
 341         Tcl_DStringAppend(&buffer, "::itcl::builtin::", -1);
 342         Tcl_DStringAppend(&buffer, BiMethodList[i].name, -1);
 343         Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
 344                 BiMethodList[i].proc, infoPtr, NULL);
 345     }
 346     Tcl_DStringFree(&buffer);
 347
 348     Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd,
 349             NULL, NULL);
 350
 351     Tcl_CreateObjCommand(interp, "::itcl::builtin::classunknown",
 352             ItclBiClassUnknownCmd, infoPtr, NULL);
 353
 354     ItclInfoInit(interp, infoPtr);
 355     /*
 356      *  Export all commands in the built-in namespace so we can
 357      *  import them later on.
 358      */
 359     itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin",
 360         NULL, TCL_LEAVE_ERR_MSG);
 361
 362     if ((itclBiNs == NULL) ||
 363         Tcl_Export(interp, itclBiNs, "[a-z]*", /* resetListFirst */ 1) != TCL_OK) {
 364         return TCL_ERROR;
 365     }
 366     /*
 367      * Install into the [info] ensemble.
 368      */
 369
 370     infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
 371     if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) {
 372         Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict);
 373         if (mapDict != NULL) {
 374             infoPtr->infoVars4Ptr = Tcl_NewStringObj("vars", -1);
 375             Tcl_IncrRefCount(infoPtr->infoVars4Ptr);
 376             result = Tcl_DictObjGet(NULL, mapDict, infoPtr->infoVars4Ptr,
 377                     &infoPtr->infoVarsPtr);
 378             if (result == TCL_OK && infoPtr->infoVarsPtr) {
 379                 Tcl_IncrRefCount(infoPtr->infoVarsPtr);
 380                 Tcl_DictObjPut(NULL, mapDict, infoPtr->infoVars4Ptr,
 381                         Tcl_NewStringObj("::itcl::builtin::Info::vars", -1));
 382                 Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict);
 383                 /*
 384                  * Note that ItclRestoreInfoVars is called in callback
 385                  * if built-in Itcl command info::vars or the ensemble get
 386                  * deleted (see ItclInfoInit registering that). */
 387             } else {
 388                 Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
 389                 infoPtr->infoVars4Ptr = NULL;
 390             }
 391         }
 392     }
 393
 394     return TCL_OK;
 395 }
 396
 397 \f
 398 /*
 399  * ------------------------------------------------------------------------
 400  *  Itcl_InstallBiMethods()
 401  *
 402  *  Invoked when a class is first created, just after the class
 403  *  definition has been parsed, to add definitions for built-in
 404  *  methods to the class.  If a method already exists in the class
 405  *  with the same name as the built-in, then the built-in is skipped.
 406  *  Otherwise, a method definition for the built-in method is added.
 407  *
 408  *  Returns TCL_OK if successful, or TCL_ERROR (along with an error
 409  *  message in the interpreter) if anything goes wrong.
 410  * ------------------------------------------------------------------------
 411  */
 412 int
 413 Itcl_InstallBiMethods(
 414     Tcl_Interp *interp,      /* current interpreter */
 415     ItclClass *iclsPtr)      /* class definition to be updated */
 416 {
 417     int result = TCL_OK;
 418
 419     int i;
 420     ItclHierIter hier;
 421     ItclClass *superPtr;
 422
 423     /*
 424      *  Scan through all of the built-in methods and see if
 425      *  that method already exists in the class.  If not, add
 426      *  it in.
 427      *
 428      *  TRICKY NOTE:  The virtual tables haven't been built yet,
 429      *    so look for existing methods the hard way--by scanning
 430      *    through all classes.
 431      */
 432     Tcl_Obj *objPtr = Tcl_NewStringObj("", 0);
 433     for (i=0; i < BiMethodListLen; i++) {
 434         Tcl_HashEntry *hPtr = NULL;
 435
 436         Itcl_InitHierIter(&hier, iclsPtr);
 437         Tcl_SetStringObj(objPtr, BiMethodList[i].name, -1);
 438         superPtr = Itcl_AdvanceHierIter(&hier);
 439         while (superPtr) {
 440             hPtr = Tcl_FindHashEntry(&superPtr->functions, (char *)objPtr);
 441             if (hPtr) {
 442                 break;
 443             }
 444             superPtr = Itcl_AdvanceHierIter(&hier);
 445         }
 446         Itcl_DeleteHierIter(&hier);
 447
 448         if (!hPtr) {
 449             if (iclsPtr->flags & BiMethodList[i].flags) {
 450                 result = Itcl_CreateMethod(interp, iclsPtr,
 451                     Tcl_NewStringObj(BiMethodList[i].name, -1),
 452                     BiMethodList[i].usage, BiMethodList[i].registration);
 453
 454                 if (result != TCL_OK) {
 455                     break;
 456                 }
 457             }
 458         }
 459     }
 460
 461     /*
 462      * Every Itcl class gets an info method installed so that each has
 463      * a proper context for the subcommands to do their context senstive
 464      * work.
 465      */
 466
 467     if (result == TCL_OK
 468             && (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
 469         result = Itcl_CreateMethod(interp, iclsPtr,
 470                 Tcl_NewStringObj("info", -1), NULL, "@itcl-builtin-info");
 471     }
 472
 473     Tcl_DecrRefCount(objPtr);
 474     return result;
 475 }
 476 \f
 477 /*
 478  * ------------------------------------------------------------------------
 479  *  Itcl_BiIsaCmd()
 480  *
 481  *  Invoked whenever the user issues the "isa" method for an object.
 482  *  Handles the following syntax:
 483  *
 484  *    <objName> isa <className>
 485  *
 486  *  Checks to see if the object has the given <className> anywhere
 487  *  in its heritage.  Returns 1 if so, and 0 otherwise.
 488  * ------------------------------------------------------------------------
 489  */
 490 /* ARGSUSED */
 491 int
 492 Itcl_BiIsaCmd(
 493     void *dummy,   /* class definition */
 494     Tcl_Interp *interp,      /* current interpreter */
 495     int objc,                /* number of arguments */
 496     Tcl_Obj *const objv[])   /* argument objects */
 497 {
 498     ItclClass *iclsPtr;
 499     const char *token;
 500
 501     ItclClass *contextIclsPtr;
 502     ItclObject *contextIoPtr;
 503     (void)dummy;
 504
 505     /*
 506      *  Make sure that this command is being invoked in the proper
 507      *  context.
 508      */
 509     contextIclsPtr = NULL;
 510     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
 511         return TCL_ERROR;
 512     }
 513
 514     if (contextIoPtr == NULL) {
 515         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 516             "improper usage: should be \"object isa className\"",
 517             NULL);
 518         return TCL_ERROR;
 519     }
 520     if (objc != 2) {
 521         token = Tcl_GetString(objv[0]);
 522         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 523             "wrong # args: should be \"object ", token, " className\"",
 524             NULL);
 525         return TCL_ERROR;
 526     }
 527
 528     /*
 529      *  Look for the requested class.  If it is not found, then
 530      *  try to autoload it.  If it absolutely cannot be found,
 531      *  signal an error.
 532      */
 533     token = Tcl_GetString(objv[1]);
 534     iclsPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
 535     if (iclsPtr == NULL) {
 536         return TCL_ERROR;
 537     }
 538
 539     if (Itcl_ObjectIsa(contextIoPtr, iclsPtr)) {
 540         Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1);
 541     } else {
 542         Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0);
 543     }
 544     return TCL_OK;
 545 }
 546
 547 \f
 548 /*
 549  * ------------------------------------------------------------------------
 550  *  Itcl_BiConfigureCmd()
 551  *
 552  *  Invoked whenever the user issues the "configure" method for an object.
 553  *  Handles the following syntax:
 554  *
 555  *    <objName> configure ?-<option>? ?<value> -<option> <value>...?
 556  *
 557  *  Allows access to public variables as if they were configuration
 558  *  options.  With no arguments, this command returns the current
 559  *  list of public variable options.  If -<option> is specified,
 560  *  this returns the information for just one option:
 561  *
 562  *    -<optionName> <initVal> <currentVal>
 563  *
 564  *  Otherwise, the list of arguments is parsed, and values are
 565  *  assigned to the various public variable options.  When each
 566  *  option changes, a big of "config" code associated with the option
 567  *  is executed, to bring the object up to date.
 568  * ------------------------------------------------------------------------
 569  */
 570 /* ARGSUSED */
 571 int
 572 Itcl_BiConfigureCmd(
 573     void *dummy,   /* class definition */
 574     Tcl_Interp *interp,      /* current interpreter */
 575     int objc,                /* number of arguments */
 576     Tcl_Obj *const objv[])   /* argument objects */
 577 {
 578     ItclClass *contextIclsPtr;
 579     ItclObject *contextIoPtr;
 580
 581     Tcl_Obj *resultPtr;
 582     Tcl_Obj *objPtr;
 583     Tcl_DString buffer;
 584     Tcl_DString buffer2;
 585     Tcl_HashSearch place;
 586     Tcl_HashEntry *hPtr;
 587     Tcl_Namespace *saveNsPtr;
 588     Tcl_Obj * const *unparsedObjv;
 589     ItclClass *iclsPtr;
 590     ItclVariable *ivPtr;
 591     ItclVarLookup *vlookup;
 592     ItclMemberCode *mcode;
 593     ItclHierIter hier;
 594     ItclObjectInfo *infoPtr;
 595     const char *lastval;
 596     const char *token;
 597     char *varName;
 598     int i;
 599     int unparsedObjc;
 600     int result;
 601     (void)dummy;
 602
 603     ItclShowArgs(1, "Itcl_BiConfigureCmd", objc, objv);
 604     vlookup = NULL;
 605     token = NULL;
 606     hPtr = NULL;
 607     unparsedObjc = objc;
 608     unparsedObjv = objv;
 609     Tcl_DStringInit(&buffer);
 610     Tcl_DStringInit(&buffer2);
 611
 612     /*
 613      *  Make sure that this command is being invoked in the proper
 614      *  context.
 615      */
 616     contextIclsPtr = NULL;
 617     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
 618         return TCL_ERROR;
 619     }
 620
 621     if (contextIoPtr == NULL) {
 622         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 623             "improper usage: should be ",
 624             "\"object configure ?-option? ?value -option value...?\"",
 625             NULL);
 626         return TCL_ERROR;
 627     }
 628
 629     /*
 630      *  BE CAREFUL:  work in the virtual scope!
 631      */
 632     if (contextIoPtr != NULL) {
 633         contextIclsPtr = contextIoPtr->iclsPtr;
 634     }
 635
 636     infoPtr = contextIclsPtr->infoPtr;
 637     if (!(contextIclsPtr->flags & ITCL_CLASS)) {
 638         /* first check if it is an option */
 639         if (objc > 1) {
 640             hPtr = Tcl_FindHashEntry(&contextIclsPtr->options,
 641                     (char *) objv[1]);
 642         }
 643         result = ItclExtendedConfigure(contextIclsPtr, interp, objc, objv);
 644         if (result != TCL_CONTINUE) {
 645             return result;
 646         }
 647         if (infoPtr->unparsedObjc > 0) {
 648             unparsedObjc = infoPtr->unparsedObjc;
 649             unparsedObjv = infoPtr->unparsedObjv;
 650         } else {
 651             unparsedObjc = objc;
 652         }
 653     }
 654     /*
 655      *  HANDLE:  configure
 656      */
 657     if (unparsedObjc == 1) {
 658         resultPtr = Tcl_NewListObj(0, NULL);
 659
 660         Itcl_InitHierIter(&hier, contextIclsPtr);
 661         while ((iclsPtr=Itcl_AdvanceHierIter(&hier)) != NULL) {
 662             hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place);
 663             while (hPtr) {
 664                 ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr);
 665                 if (ivPtr->protection == ITCL_PUBLIC) {
 666                     objPtr = ItclReportPublicOpt(interp, ivPtr, contextIoPtr);
 667
 668                     Tcl_ListObjAppendElement(NULL, resultPtr,
 669                         objPtr);
 670                 }
 671                 hPtr = Tcl_NextHashEntry(&place);
 672             }
 673         }
 674         Itcl_DeleteHierIter(&hier);
 675
 676         Tcl_SetObjResult(interp, resultPtr);
 677         return TCL_OK;
 678     } else {
 679
 680         /*
 681          *  HANDLE:  configure -option
 682          */
 683         if (unparsedObjc == 2) {
 684             token = Tcl_GetString(unparsedObjv[1]);
 685             if (*token != '-') {
 686                 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 687                     "improper usage: should be ",
 688                     "\"object configure ?-option? ?value -option value...?\"",
 689                     NULL);
 690                 return TCL_ERROR;
 691             }
 692
 693             vlookup = NULL;
 694             hPtr = ItclResolveVarEntry(contextIclsPtr, token+1);
 695             if (hPtr) {
 696                 vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
 697
 698                 if (vlookup->ivPtr->protection != ITCL_PUBLIC) {
 699                     vlookup = NULL;
 700                 }
 701             }
 702             if (!vlookup) {
 703                 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 704                     "unknown option \"", token, "\"",
 705                     NULL);
 706                 return TCL_ERROR;
 707             }
 708             resultPtr = ItclReportPublicOpt(interp,
 709                     vlookup->ivPtr, contextIoPtr);
 710             Tcl_SetObjResult(interp, resultPtr);
 711             return TCL_OK;
 712         }
 713     }
 714
 715     /*
 716      *  HANDLE:  configure -option value -option value...
 717      *
 718      *  Be careful to work in the virtual scope.  If this "configure"
 719      *  method was defined in a base class, the current namespace
 720      *  (from Itcl_ExecMethod()) will be that base class.  Activate
 721      *  the derived class namespace here, so that instance variables
 722      *  are accessed properly.
 723      */
 724     result = TCL_OK;
 725
 726     for (i=1; i < unparsedObjc; i+=2) {
 727         if (i+1 >= unparsedObjc) {
 728             Tcl_AppendResult(interp, "need option value pair", NULL);
 729             result = TCL_ERROR;
 730             goto configureDone;
 731         }
 732         vlookup = NULL;
 733         token = Tcl_GetString(unparsedObjv[i]);
 734         if (*token == '-') {
 735             hPtr = ItclResolveVarEntry(contextIclsPtr, token+1);
 736             if (hPtr == NULL) {
 737                 hPtr = ItclResolveVarEntry(contextIclsPtr, token);
 738             }
 739             if (hPtr) {
 740                 vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
 741             }
 742         }
 743
 744         if (!vlookup || (vlookup->ivPtr->protection != ITCL_PUBLIC)) {
 745             Tcl_AppendResult(interp, "unknown option \"", token, "\"",
 746                 NULL);
 747             result = TCL_ERROR;
 748             goto configureDone;
 749         }
 750         if (i == unparsedObjc-1) {
 751             Tcl_AppendResult(interp, "value for \"", token, "\" missing",
 752                 NULL);
 753             result = TCL_ERROR;
 754             goto configureDone;
 755         }
 756
 757         ivPtr = vlookup->ivPtr;
 758         Tcl_DStringSetLength(&buffer2, 0);
 759         if (!(ivPtr->flags & ITCL_COMMON)) {
 760             Tcl_DStringAppend(&buffer2,
 761                     Tcl_GetString(contextIoPtr->varNsNamePtr), -1);
 762         }
 763         Tcl_DStringAppend(&buffer2,
 764                 Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), -1);
 765         Tcl_DStringAppend(&buffer2, "::", 2);
 766         Tcl_DStringAppend(&buffer2,
 767                 Tcl_GetString(ivPtr->namePtr), -1);
 768         varName = Tcl_DStringValue(&buffer2);
 769         lastval = Tcl_GetVar2(interp, varName, NULL, 0);
 770         Tcl_DStringSetLength(&buffer, 0);
 771         Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);
 772
 773         token = Tcl_GetString(unparsedObjv[i+1]);
 774         if (Tcl_SetVar2(interp, varName, NULL, token,
 775                 TCL_LEAVE_ERR_MSG) == NULL) {
 776             Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 777                     "\n    (error in configuration of public variable \"%s\")",
 778                     Tcl_GetString(ivPtr->fullNamePtr)));
 779             result = TCL_ERROR;
 780             goto configureDone;
 781         }
 782
 783         /*
 784          *  If this variable has some "config" code, invoke it now.
 785          *
 786          *  TRICKY NOTE:  Be careful to evaluate the code one level
 787          *    up in the call stack, so that it's executed in the
 788          *    calling context, and not in the context that we've
 789          *    set up for public variable access.
 790          */
 791         mcode = ivPtr->codePtr;
 792         if (mcode && Itcl_IsMemberCodeImplemented(mcode)) {
 793             if (!ivPtr->iclsPtr->infoPtr->useOldResolvers) {
 794                 Itcl_SetCallFrameResolver(interp, contextIoPtr->resolvePtr);
 795             }
 796             saveNsPtr = Tcl_GetCurrentNamespace(interp);
 797             Itcl_SetCallFrameNamespace(interp, ivPtr->iclsPtr->nsPtr);
 798             result = Tcl_EvalObjEx(interp, mcode->bodyPtr, 0);
 799             Itcl_SetCallFrameNamespace(interp, saveNsPtr);
 800             if (result == TCL_OK) {
 801                 Tcl_ResetResult(interp);
 802             } else {
 803                     Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 804                             "\n    (error in configuration of public variable \"%s\")",
 805                             Tcl_GetString(ivPtr->fullNamePtr)));
 806                 Tcl_SetVar2(interp, varName,NULL,
 807                     Tcl_DStringValue(&buffer), 0);
 808
 809                 goto configureDone;
 810             }
 811         }
 812     }
 813
 814 configureDone:
 815     if (infoPtr->unparsedObjc > 0) {
 816         while (infoPtr->unparsedObjc-- > 1) {
 817             Tcl_DecrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc]);
 818         }
 819         ckfree ((char *)infoPtr->unparsedObjv);
 820         infoPtr->unparsedObjv = NULL;
 821         infoPtr->unparsedObjc = 0;
 822     }
 823     Tcl_DStringFree(&buffer2);
 824     Tcl_DStringFree(&buffer);
 825
 826     return result;
 827 }
 828
 829 \f
 830 /*
 831  * ------------------------------------------------------------------------
 832  *  Itcl_BiCgetCmd()
 833  *
 834  *  Invoked whenever the user issues the "cget" method for an object.
 835  *  Handles the following syntax:
 836  *
 837  *    <objName> cget -<option>
 838  *
 839  *  Allows access to public variables as if they were configuration
 840  *  options.  Mimics the behavior of the usual "cget" method for
 841  *  Tk widgets.  Returns the current value of the public variable
 842  *  with name <option>.
 843  * ------------------------------------------------------------------------
 844  */
 845 /* ARGSUSED */
 846 int
 847 Itcl_BiCgetCmd(
 848     void *dummy,   /* class definition */
 849     Tcl_Interp *interp,      /* current interpreter */
 850     int objc,                /* number of arguments */
 851     Tcl_Obj *const objv[])   /* argument objects */
 852 {
 853     ItclClass *contextIclsPtr;
 854     ItclObject *contextIoPtr;
 855
 856     Tcl_HashEntry *hPtr;
 857     ItclVarLookup *vlookup;
 858     const char *name;
 859     const char *val;
 860     int result;
 861     (void)dummy;
 862
 863     ItclShowArgs(1,"Itcl_BiCgetCmd", objc, objv);
 864     /*
 865      *  Make sure that this command is being invoked in the proper
 866      *  context.
 867      */
 868     contextIclsPtr = NULL;
 869     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
 870         return TCL_ERROR;
 871     }
 872     if ((contextIoPtr == NULL) || objc != 2) {
 873         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 874             "improper usage: should be \"object cget -option\"",
 875             NULL);
 876         return TCL_ERROR;
 877     }
 878
 879     /*
 880      *  BE CAREFUL:  work in the virtual scope!
 881      */
 882     if (contextIoPtr != NULL) {
 883         contextIclsPtr = contextIoPtr->iclsPtr;
 884     }
 885
 886     if (!(contextIclsPtr->flags & ITCL_CLASS)) {
 887         result = ItclExtendedCget(contextIclsPtr, interp, objc, objv);
 888         if (result != TCL_CONTINUE) {
 889             return result;
 890         }
 891     }
 892     name = Tcl_GetString(objv[1]);
 893
 894     vlookup = NULL;
 895     hPtr = ItclResolveVarEntry(contextIclsPtr, name+1);
 896     if (hPtr) {
 897         vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
 898     }
 899
 900     if ((vlookup == NULL) || (vlookup->ivPtr->protection != ITCL_PUBLIC)) {
 901         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 902             "unknown option \"", name, "\"",
 903             NULL);
 904         return TCL_ERROR;
 905     }
 906
 907     val = Itcl_GetInstanceVar(interp,
 908             Tcl_GetString(vlookup->ivPtr->namePtr),
 909             contextIoPtr, vlookup->ivPtr->iclsPtr);
 910
 911     if (val) {
 912         Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
 913     } else {
 914         Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1));
 915     }
 916     return TCL_OK;
 917 }
 918
 919 \f
 920 /*
 921  * ------------------------------------------------------------------------
 922  *  ItclReportPublicOpt()
 923  *
 924  *  Returns information about a public variable formatted as a
 925  *  configuration option:
 926  *
 927  *    -<varName> <initVal> <currentVal>
 928  *
 929  *  Used by Itcl_BiConfigureCmd() to report configuration options.
 930  *  Returns a Tcl_Obj containing the information.
 931  * ------------------------------------------------------------------------
 932  */
 933 static Tcl_Obj*
 934 ItclReportPublicOpt(
 935     Tcl_Interp *interp,      /* interpreter containing the object */
 936     ItclVariable *ivPtr,     /* public variable to be reported */
 937     ItclObject *contextIoPtr) /* object containing this variable */
 938 {
 939     const char *val;
 940     ItclClass *iclsPtr;
 941     Tcl_HashEntry *hPtr;
 942     ItclVarLookup *vlookup;
 943     Tcl_DString optName;
 944     Tcl_Obj *listPtr;
 945     Tcl_Obj *objPtr;
 946
 947     listPtr = Tcl_NewListObj(0, NULL);
 948
 949     /*
 950      *  Determine how the option name should be reported.
 951      *  If the simple name can be used to find it in the virtual
 952      *  data table, then use the simple name.  Otherwise, this
 953      *  is a shadowed variable; use the full name.
 954      */
 955     Tcl_DStringInit(&optName);
 956     Tcl_DStringAppend(&optName, "-", -1);
 957
 958     iclsPtr = (ItclClass*)contextIoPtr->iclsPtr;
 959     hPtr = ItclResolveVarEntry(iclsPtr,
 960             Tcl_GetString(ivPtr->fullNamePtr));
 961     assert(hPtr != NULL);
 962     vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
 963     Tcl_DStringAppend(&optName, vlookup->leastQualName, -1);
 964
 965     objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1);
 966     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
 967     Tcl_DStringFree(&optName);
 968
 969
 970     if (ivPtr->init) {
 971         objPtr = ivPtr->init;
 972     } else {
 973         objPtr = Tcl_NewStringObj("<undefined>", -1);
 974     }
 975     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
 976
 977     val = Itcl_GetInstanceVar(interp, Tcl_GetString(ivPtr->namePtr),
 978             contextIoPtr, ivPtr->iclsPtr);
 979
 980     if (val) {
 981         objPtr = Tcl_NewStringObj((const char *)val, -1);
 982     } else {
 983         objPtr = Tcl_NewStringObj("<undefined>", -1);
 984     }
 985     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
 986
 987     return listPtr;
 988 }
 989 \f
 990 /*
 991  * ------------------------------------------------------------------------
 992  *  ItclReportOption()
 993  *
 994  *  Returns information about an option formatted as a
 995  *  configuration option:
 996  *
 997  *    <optionName> <initVal> <currentVal>
 998  *
 999  *  Used by ItclExtendedConfigure() to report configuration options.
1000  *  Returns a Tcl_Obj containing the information.
1001  * ------------------------------------------------------------------------
1002  */
1003 static Tcl_Obj*
1004 ItclReportOption(
1005     Tcl_Interp *interp,      /* interpreter containing the object */
1006     ItclOption *ioptPtr,     /* option to be reported */
1007     ItclObject *contextIoPtr) /* object containing this variable */
1008 {
1009     Tcl_Obj *listPtr;
1010     Tcl_Obj *objPtr;
1011     ItclDelegatedOption *idoPtr;
1012     const char *val;
1013
1014     listPtr = Tcl_NewListObj(0, NULL);
1015     idoPtr = ioptPtr->iclsPtr->infoPtr->currIdoPtr;
1016     if (idoPtr != NULL) {
1017         Tcl_ListObjAppendElement(NULL, listPtr, idoPtr->namePtr);
1018         if (idoPtr->resourceNamePtr == NULL) {
1019             Tcl_ListObjAppendElement(NULL, listPtr,
1020                     Tcl_NewStringObj("", -1));
1021             /* FIXME possible memory leak */
1022         } else {
1023             Tcl_ListObjAppendElement(NULL, listPtr,
1024                     idoPtr->resourceNamePtr);
1025         }
1026         if (idoPtr->classNamePtr == NULL) {
1027             Tcl_ListObjAppendElement(NULL, listPtr,
1028                     Tcl_NewStringObj("", -1));
1029             /* FIXME possible memory leak */
1030         } else {
1031             Tcl_ListObjAppendElement(NULL, listPtr,
1032                     idoPtr->classNamePtr);
1033         }
1034     } else {
1035         Tcl_ListObjAppendElement(NULL, listPtr, ioptPtr->namePtr);
1036         Tcl_ListObjAppendElement(NULL, listPtr,
1037                 ioptPtr->resourceNamePtr);
1038         Tcl_ListObjAppendElement(NULL, listPtr,
1039                 ioptPtr->classNamePtr);
1040     }
1041     if (ioptPtr->defaultValuePtr) {
1042         objPtr = ioptPtr->defaultValuePtr;
1043     } else {
1044         objPtr = Tcl_NewStringObj("<undefined>", -1);
1045     }
1046     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
1047     val = ItclGetInstanceVar(interp, "itcl_options",
1048             Tcl_GetString(ioptPtr->namePtr),
1049             contextIoPtr, ioptPtr->iclsPtr);
1050     if (val) {
1051         objPtr = Tcl_NewStringObj((const char *)val, -1);
1052     } else {
1053         objPtr = Tcl_NewStringObj("<undefined>", -1);
1054     }
1055     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
1056     return listPtr;
1057 }
1058
1059
1060 \f
1061 /*
1062  * ------------------------------------------------------------------------
1063  *  Itcl_BiChainCmd()
1064  *
1065  *  Invoked to handle the "chain" command, to access the version of
1066  *  a method or proc that exists in a base class.  Handles the
1067  *  following syntax:
1068  *
1069  *    chain ?<arg> <arg>...?
1070  *
1071  *  Looks up the inheritance hierarchy for another implementation
1072  *  of the method/proc that is currently executing.  If another
1073  *  implementation is found, it is invoked with the specified
1074  *  <arg> arguments.  If it is not found, this command does nothing.
1075  *  This allows a base class method to be called out in a generic way,
1076  *  so the code will not have to change if the base class changes.
1077  * ------------------------------------------------------------------------
1078  */
1079 /* ARGSUSED */
1080 static int
1081 NRBiChainCmd(
1082     void *dummy,        /* not used */
1083     Tcl_Interp *interp,      /* current interpreter */
1084     int objc,                /* number of arguments */
1085     Tcl_Obj *const objv[])   /* argument objects */
1086 {
1087     int result = TCL_OK;
1088
1089     ItclClass *contextIclsPtr;
1090     ItclObject *contextIoPtr;
1091
1092     const char *cmd;
1093     char *cmd1;
1094     const char *head;
1095     ItclClass *iclsPtr;
1096     ItclHierIter hier;
1097     Tcl_HashEntry *hPtr;
1098     ItclMemberFunc *imPtr;
1099     Tcl_DString buffer;
1100     Tcl_Obj *cmdlinePtr;
1101     Tcl_Obj **newobjv;
1102     Tcl_Obj * const *cObjv;
1103     int cObjc;
1104     int idx;
1105     Tcl_Obj *objPtr;
1106     (void)dummy;
1107
1108     ItclShowArgs(1, "Itcl_BiChainCmd", objc, objv);
1109
1110     /*
1111      *  If this command is not invoked within a class namespace,
1112      *  signal an error.
1113      */
1114     contextIclsPtr = NULL;
1115     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
1116         Tcl_ResetResult(interp);
1117         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1118             "cannot chain functions outside of a class context",
1119             NULL);
1120         return TCL_ERROR;
1121     }
1122
1123     /*
1124      *  Try to get the command name from the current call frame.
1125      *  If it cannot be determined, do nothing.  Otherwise, trim
1126      *  off any leading path names.
1127      */
1128     cObjv = Itcl_GetCallVarFrameObjv(interp);
1129     if (cObjv == NULL) {
1130         return TCL_OK;
1131     }
1132     cObjc = Itcl_GetCallVarFrameObjc(interp);
1133
1134     if ((Itcl_GetCallFrameClientData(interp) == NULL) || (objc == 1)) {
1135         /* that has been a direct call, so no object in front !! */
1136         if (objc == 1 && cObjc >= 2) {
1137             idx = 1;
1138         } else {
1139             idx = 0;
1140         }
1141     } else {
1142         idx = 1;
1143     }
1144     cmd1 = (char *)ckalloc(strlen(Tcl_GetString(cObjv[idx]))+1);
1145     strcpy(cmd1, Tcl_GetString(cObjv[idx]));
1146     Itcl_ParseNamespPath(cmd1, &buffer, &head, &cmd);
1147
1148     /*
1149      *  Look for the specified command in one of the base classes.
1150      *  If we have an object context, then start from the most-specific
1151      *  class and walk up the hierarchy to the current context.  If
1152      *  there is multiple inheritance, having the entire inheritance
1153      *  hierarchy will allow us to jump over to another branch of
1154      *  the inheritance tree.
1155      *
1156      *  If there is no object context, just start with the current
1157      *  class context.
1158      */
1159     if (contextIoPtr != NULL) {
1160         Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr);
1161         while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
1162             if (iclsPtr == contextIclsPtr) {
1163                 break;
1164             }
1165         }
1166     } else {
1167         Itcl_InitHierIter(&hier, contextIclsPtr);
1168         Itcl_AdvanceHierIter(&hier);    /* skip the current class */
1169     }
1170
1171     /*
1172      *  Now search up the class hierarchy for the next implementation.
1173      *  If found, execute it.  Otherwise, do nothing.
1174      */
1175     objPtr = Tcl_NewStringObj(cmd, -1);
1176     ckfree(cmd1);
1177     Tcl_IncrRefCount(objPtr);
1178     while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) {
1179         hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr);
1180         if (hPtr) {
1181             int my_objc;
1182             imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr);
1183
1184             /*
1185              *  NOTE:  Avoid the usual "virtual" behavior of
1186              *         methods by passing the full name as
1187              *         the command argument.
1188              */
1189
1190             cmdlinePtr = Itcl_CreateArgs(interp,
1191                     Tcl_GetString(imPtr->fullNamePtr), objc-1, objv+1);
1192
1193             (void) Tcl_ListObjGetElements(NULL, cmdlinePtr,
1194                 &my_objc, &newobjv);
1195
1196             if (imPtr->flags & ITCL_CONSTRUCTOR) {
1197                 contextIoPtr = imPtr->iclsPtr->infoPtr->currIoPtr;
1198             }
1199             ItclShowArgs(1, "___chain", objc-1, newobjv+1);
1200             result = Itcl_EvalMemberCode(interp, imPtr, contextIoPtr,
1201                     my_objc-1, newobjv+1);
1202             Tcl_DecrRefCount(cmdlinePtr);
1203             break;
1204         }
1205     }
1206     Tcl_DecrRefCount(objPtr);
1207
1208     Tcl_DStringFree(&buffer);
1209     Itcl_DeleteHierIter(&hier);
1210     return result;
1211 }
1212 /* ARGSUSED */
1213 int
1214 Itcl_BiChainCmd(
1215     void *clientData,
1216     Tcl_Interp *interp,
1217     int objc,
1218     Tcl_Obj *const *objv)
1219 {
1220     return Tcl_NRCallObjProc(interp, NRBiChainCmd, clientData, objc, objv);
1221 }
1222
1223 static int
1224 CallCreateObject(
1225     void *data[],
1226     Tcl_Interp *interp,
1227     int result)
1228 {
1229     Tcl_CallFrame frame;
1230     Tcl_Namespace *nsPtr;
1231     ItclClass *iclsPtr = (ItclClass *)data[0];
1232     int objc = PTR2INT(data[1]);
1233     Tcl_Obj *const *objv = (Tcl_Obj *const *)data[2];
1234
1235     if (result != TCL_OK) {
1236         return result;
1237     }
1238     nsPtr = Itcl_GetUplevelNamespace(interp, 1);
1239     if (Itcl_PushCallFrame(interp, &frame, nsPtr,
1240             /*isProcCallFrame*/0) != TCL_OK) {
1241         return TCL_ERROR;
1242     }
1243     result = ItclClassCreateObject(iclsPtr->infoPtr, interp, objc, objv);
1244     Itcl_PopCallFrame(interp);
1245     Tcl_DecrRefCount(objv[2]);
1246     Tcl_DecrRefCount(objv[1]);
1247     Tcl_DecrRefCount(objv[0]);
1248     return result;
1249 }
1250
1251 static int
1252 PrepareCreateObject(
1253    Tcl_Interp *interp,
1254    ItclClass *iclsPtr,
1255    int objc,
1256    Tcl_Obj * const *objv)
1257 {
1258     Tcl_HashEntry *hPtr;
1259     Tcl_Obj **newObjv;
1260     void *callbackPtr;
1261     const char *funcName;
1262     int result;
1263     int offset;
1264
1265     offset = 1;
1266     funcName = Tcl_GetString(objv[1]);
1267     if (strcmp(funcName, "itcl_hull") == 0) {
1268         hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]);
1269         if (hPtr == NULL) {
1270             Tcl_AppendResult(interp, "INTERNAL ERROR ",
1271                     "cannot find itcl_hull method", NULL);
1272             return TCL_ERROR;
1273         }
1274         result = Itcl_ExecProc(Tcl_GetHashValue(hPtr), interp, objc, objv);
1275         return result;
1276     }
1277     if (strcmp(funcName, "create") == 0) {
1278         /* allow typeClassName create objectName */
1279         offset++;
1280     } else {
1281         /* allow typeClassName objectName */
1282     }
1283     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc+3-offset));
1284     newObjv[0] = objv[0];
1285     Tcl_IncrRefCount(newObjv[0]);
1286     newObjv[1] = iclsPtr->namePtr;
1287     Tcl_IncrRefCount(newObjv[1]);
1288     newObjv[2] = Tcl_NewStringObj(iclsPtr->nsPtr->fullName, -1);
1289     Tcl_IncrRefCount(newObjv[2]);
1290     memcpy(newObjv+3, objv+offset, (objc-offset) * sizeof(Tcl_Obj *));
1291     callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
1292     ItclShowArgs(1, "CREATE", objc+3-offset, newObjv);
1293     Tcl_NRAddCallback(interp, CallCreateObject, iclsPtr,
1294             INT2PTR(objc+3-offset), newObjv, NULL);
1295     result = Itcl_NRRunCallbacks(interp, callbackPtr);
1296     if (result != TCL_OK) {
1297         if (iclsPtr->infoPtr->currIoPtr != NULL) {
1298             /* we are in a constructor call */
1299             if (iclsPtr->infoPtr->currIoPtr->hadConstructorError == 0) {
1300                 iclsPtr->infoPtr->currIoPtr->hadConstructorError = 1;
1301             }
1302         }
1303     }
1304     ckfree((char *)newObjv);
1305     return result;
1306 }
1307 /*
1308  * ------------------------------------------------------------------------
1309  *  ItclBiClassUnknownCmd()
1310  *
1311  *  Invoked to handle the "classunknown" command
1312  *  this is called whenever an object is called with an unknown method/proc
1313  *  following syntax:
1314  *
1315  *    classunknown <object> <methodname> ?<arg> <arg>...?
1316  *
1317  * ------------------------------------------------------------------------
1318  */
1319 /* ARGSUSED */
1320 static int
1321 ItclBiClassUnknownCmd(
1322     void *clientData,   /* ItclObjectInfo Ptr */
1323     Tcl_Interp *interp,      /* current interpreter */
1324     int objc,                /* number of arguments */
1325     Tcl_Obj *const objv[])   /* argument objects */
1326 {
1327     FOREACH_HASH_DECLS;
1328     Tcl_HashEntry *hPtr2;
1329     Tcl_Obj **newObjv;
1330     Tcl_Obj **lObjv;
1331     Tcl_Obj *listPtr;
1332     Tcl_Obj *objPtr;
1333     Tcl_Obj *resPtr;
1334     Tcl_DString buffer;
1335     ItclClass *iclsPtr;
1336     ItclObjectInfo *infoPtr;
1337     ItclComponent *icPtr;
1338     ItclDelegatedFunction *idmPtr;
1339     ItclDelegatedFunction *idmPtr2;
1340     ItclDelegatedFunction *starIdmPtr;
1341     const char *resStr;
1342     const char *val;
1343     const char *funcName;
1344     int lObjc;
1345     int result;
1346     int offset;
1347     int useComponent;
1348     int isItclHull;
1349     int isTypeMethod;
1350     int isStar;
1351     int isNew;
1352     int idx;
1353
1354     ItclShowArgs(1, "ItclBiClassUnknownCmd", objc, objv);
1355     listPtr = NULL;
1356     useComponent = 1;
1357     isStar = 0;
1358     isTypeMethod = 0;
1359     isItclHull = 0;
1360     starIdmPtr = NULL;
1361     infoPtr = (ItclObjectInfo *)clientData;
1362     hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses,
1363             (char *)Tcl_GetCurrentNamespace(interp));
1364     if (hPtr == NULL) {
1365         Tcl_AppendResult(interp, "INTERNAL ERROR: ItclBiClassUnknownCmd ",
1366                 "cannot find class\n", NULL);
1367         return TCL_ERROR;
1368     }
1369     iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
1370     funcName = Tcl_GetString(objv[1]);
1371     if (strcmp(funcName, "create") == 0) {
1372         /* check if we have a user method create. If not, it is the builtin
1373          * create method and we don't need to check for delegation
1374          * and components with ITCL_COMPONENT_INHERIT
1375          */
1376         hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objv[1]);
1377         if (hPtr == NULL) {
1378             return PrepareCreateObject(interp, iclsPtr, objc, objv);
1379         }
1380     }
1381     if (strcmp(funcName, "itcl_hull") == 0) {
1382         isItclHull = 1;
1383     }
1384     if (!isItclHull) {
1385         FOREACH_HASH_VALUE(icPtr, &iclsPtr->components) {
1386             if (icPtr->flags & ITCL_COMPONENT_INHERIT) {
1387                 val = Tcl_GetVar2(interp, Tcl_GetString(icPtr->namePtr),
1388                         NULL, 0);
1389                 if ((val != NULL) && (strlen(val) > 0)) {
1390                     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
1391                     newObjv[0] = Tcl_NewStringObj(val, -1);
1392                     Tcl_IncrRefCount(newObjv[0]);
1393                     memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1));
1394                     ItclShowArgs(1, "UK EVAL1", objc, newObjv);
1395                     result = Tcl_EvalObjv(interp, objc, newObjv, 0);
1396                     Tcl_DecrRefCount(newObjv[0]);
1397                     ckfree((char *)newObjv);
1398                     return result;
1399                 }
1400             }
1401         }
1402     }
1403     /* from a class object only typemethods can be called directly
1404      * if delegated, so check for that, otherwise create an object
1405      * for ITCL_ECLASS we allow calling too
1406      */
1407     hPtr = NULL;
1408     isTypeMethod = 0;
1409     FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
1410         if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) {
1411             if (idmPtr->flags & ITCL_TYPE_METHOD) {
1412                isTypeMethod = 1;
1413             }
1414             if (iclsPtr->flags & ITCL_ECLASS) {
1415                isTypeMethod = 1;
1416             }
1417             break;
1418         }
1419         if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) {
1420             if (idmPtr->flags & ITCL_TYPE_METHOD) {
1421                isTypeMethod = 1;
1422             }
1423             starIdmPtr = idmPtr;
1424             break;
1425         }
1426     }
1427     idmPtr = NULL;
1428     if (isTypeMethod) {
1429         hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
1430         if (hPtr == NULL) {
1431             objPtr = Tcl_NewStringObj("*", -1);
1432             Tcl_IncrRefCount(objPtr);
1433             hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
1434                     (char *)objPtr);
1435             Tcl_DecrRefCount(objPtr);
1436             if (hPtr != NULL) {
1437                 idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
1438                 isStar = 1;
1439             }
1440         }
1441         if (isStar) {
1442             /* check if the function is in the exceptions */
1443             hPtr2 = Tcl_FindHashEntry(&starIdmPtr->exceptions, (char *)objv[1]);
1444             if (hPtr2 != NULL) {
1445                 const char *sep = "";
1446                 objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
1447                 Tcl_AppendToObj(objPtr, funcName, -1);
1448                 Tcl_AppendToObj(objPtr, "\": must be ", -1);
1449                 FOREACH_HASH_VALUE(idmPtr,
1450                         &iclsPtr->delegatedFunctions) {
1451                     funcName = Tcl_GetString(idmPtr->namePtr);
1452                     if (strcmp(funcName, "*") != 0) {
1453                         if (strlen(sep) > 0) {
1454                             Tcl_AppendToObj(objPtr, sep, -1);
1455                         }
1456                         Tcl_AppendToObj(objPtr, funcName, -1);
1457                         sep = " or ";
1458                     }
1459                 }
1460                 Tcl_SetObjResult(interp, objPtr);
1461                 return TCL_ERROR;
1462             }
1463         }
1464         if (hPtr != NULL) {
1465             idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
1466             val = NULL;
1467             if (idmPtr->icPtr != NULL) {
1468                 if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
1469                     val = Tcl_GetVar2(interp,
1470                             Tcl_GetString(idmPtr->icPtr->namePtr), NULL, 0);
1471                 } else {
1472                     ItclClass *contextIclsPtr;
1473                     ItclObject *contextIoPtr;
1474                     contextIclsPtr = NULL;
1475                     contextIoPtr = NULL;
1476                     Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr);
1477                     Tcl_DStringInit(&buffer);
1478                     Tcl_DStringAppend(&buffer,
1479                             Tcl_GetString(contextIoPtr->varNsNamePtr), -1);
1480                     Tcl_DStringAppend(&buffer,
1481                             Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr),
1482                             -1);
1483                     val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer),
1484                             NULL, 0);
1485                     Tcl_DStringFree(&buffer);
1486                 }
1487                 if (val == NULL) {
1488                     Tcl_AppendResult(interp, "INTERNAL ERROR: ",
1489                             "ItclBiClassUnknownCmd contents ",
1490                             "of component == NULL\n", NULL);
1491                     return TCL_ERROR;
1492                 }
1493             }
1494             offset = 1;
1495             lObjc = 0;
1496             if ((idmPtr->asPtr != NULL) || (idmPtr->usingPtr != NULL)) {
1497                 offset++;
1498                 listPtr = Tcl_NewListObj(0, NULL);
1499                 result = ExpandDelegateAs(interp, NULL, iclsPtr,
1500                         idmPtr, funcName, listPtr);
1501                 if (result != TCL_OK) {
1502                     return result;
1503                 }
1504                 result = Tcl_ListObjGetElements(interp, listPtr,
1505                         &lObjc, &lObjv);
1506                 if (result != TCL_OK) {
1507                     Tcl_DecrRefCount(listPtr);
1508                     return result;
1509                 }
1510                 if (idmPtr->usingPtr != NULL) {
1511                     useComponent = 0;
1512                 }
1513             }
1514             if (useComponent) {
1515                 if ((val == NULL) || (strlen(val) == 0)) {
1516                     Tcl_AppendResult(interp, "component \"",
1517                             Tcl_GetString(idmPtr->icPtr->namePtr),
1518                             "\" is not initialized", NULL);
1519                     return TCL_ERROR;
1520                 }
1521             }
1522             newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
1523                     (objc + lObjc - offset + useComponent));
1524             if (useComponent) {
1525                 newObjv[0] = Tcl_NewStringObj(val, -1);
1526                 Tcl_IncrRefCount(newObjv[0]);
1527             }
1528             for (idx = 0; idx < lObjc; idx++) {
1529                 newObjv[useComponent+idx] = lObjv[idx];
1530             }
1531             if (objc-offset > 0) {
1532                 memcpy(newObjv+useComponent+lObjc, objv+offset,
1533                         sizeof(Tcl_Obj *) * (objc-offset));
1534             }
1535             ItclShowArgs(1, "OBJ UK EVAL", objc+lObjc-offset+useComponent,
1536                     newObjv);
1537             result = Tcl_EvalObjv(interp,
1538                     objc+lObjc-offset+useComponent, newObjv, 0);
1539             if (isStar && (result == TCL_OK)) {
1540                 if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
1541                         (char *)newObjv[1]) == NULL) {
1542                     result = ItclCreateDelegatedFunction(interp, iclsPtr,
1543                             newObjv[1], idmPtr->icPtr, NULL, NULL,
1544                             NULL, &idmPtr2);
1545                     if (result == TCL_OK) {
1546                         if (isTypeMethod) {
1547                             idmPtr2->flags |= ITCL_TYPE_METHOD;
1548                         } else {
1549                             idmPtr2->flags |= ITCL_METHOD;
1550                         }
1551                         hPtr2 = Tcl_CreateHashEntry(
1552                                 &iclsPtr->delegatedFunctions,
1553                                 (char *)newObjv[1], &isNew);
1554                         Tcl_SetHashValue(hPtr2, idmPtr2);
1555                     }
1556                 }
1557             }
1558             if (useComponent) {
1559                 Tcl_DecrRefCount(newObjv[0]);
1560             }
1561             ckfree((char *)newObjv);
1562             if (listPtr != NULL) {
1563                 Tcl_DecrRefCount(listPtr);
1564             }
1565             if (result == TCL_ERROR) {
1566                 resStr = Tcl_GetString(Tcl_GetObjResult(interp));
1567                 /* FIXME ugly hack at the moment !! */
1568                 if (strncmp(resStr, "wrong # args: should be ", 24) == 0) {
1569                     resPtr = Tcl_NewStringObj("", -1);
1570                     Tcl_AppendToObj(resPtr, resStr, 25);
1571                     resStr += 25;
1572                     Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr),
1573                            -1);
1574                     resStr += strlen(val);
1575                     Tcl_AppendToObj(resPtr, resStr, -1);
1576                     Tcl_ResetResult(interp);
1577                     Tcl_SetObjResult(interp, resPtr);
1578                 }
1579             }
1580             return result;
1581         }
1582     }
1583     return PrepareCreateObject(interp, iclsPtr, objc, objv);
1584 }
1585 \f
1586 /*
1587  * ------------------------------------------------------------------------
1588  *  ItclUnknownGuts()
1589  *
1590  *  The unknown method handler of the itcl::Root class -- all Itcl
1591  *  objects land here when they cannot find a method.
1592  *
1593  * ------------------------------------------------------------------------
1594  */
1595
1596 int
1597 ItclUnknownGuts(
1598     ItclObject *ioPtr,       /* The ItclObject seeking method */
1599     Tcl_Interp *interp,      /* current interpreter */
1600     int objc,                /* number of arguments */
1601     Tcl_Obj *const objv[])   /* argument objects */
1602 {
1603     FOREACH_HASH_DECLS;
1604     Tcl_HashEntry *hPtr2;
1605     Tcl_Obj **newObjv;
1606     Tcl_Obj **lObjv;
1607     Tcl_Obj *listPtr = NULL;
1608     Tcl_Obj *objPtr;
1609     Tcl_Obj *resPtr;
1610     Tcl_DString buffer;
1611     ItclClass *iclsPtr;
1612     ItclComponent *icPtr;
1613     ItclDelegatedFunction *idmPtr;
1614     ItclDelegatedFunction *idmPtr2;
1615     const char *resStr;
1616     const char *val;
1617     const char *funcName;
1618     int lObjc;
1619     int result;
1620     int offset;
1621     int useComponent;
1622     int found;
1623     int isItclHull;
1624     int isStar;
1625     int isTypeMethod;
1626     int isNew;
1627     int idx;
1628
1629     if (objc < 2) {
1630         Tcl_AppendResult(interp, "wrong # args: should be one of...",
1631                 NULL);
1632         ItclReportObjectUsage(interp, ioPtr, NULL, NULL);
1633         return TCL_ERROR;
1634     }
1635     iclsPtr = ioPtr->iclsPtr;
1636     lObjc = 0;
1637     offset = 1;
1638     isStar = 0;
1639     found = 0;
1640     isItclHull = 0;
1641     useComponent = 1;
1642     result = TCL_OK;
1643     idmPtr = NULL;
1644     funcName = Tcl_GetString(objv[1]);
1645     if (strcmp(funcName, "itcl_hull") == 0) {
1646         isItclHull = 1;
1647     }
1648     icPtr = NULL;
1649     if (!isItclHull) {
1650         FOREACH_HASH_VALUE(icPtr, &ioPtr->objectComponents) {
1651             if (icPtr->flags & ITCL_COMPONENT_INHERIT) {
1652                 val = Itcl_GetInstanceVar(interp,
1653                         Tcl_GetString(icPtr->namePtr), ioPtr,
1654                         icPtr->ivPtr->iclsPtr);
1655                 if ((val != NULL) && (strlen(val) > 0)) {
1656                     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
1657                             (objc));
1658                     newObjv[0] = Tcl_NewStringObj(val, -1);
1659                     Tcl_IncrRefCount(newObjv[0]);
1660                     memcpy(newObjv+1, objv+1, sizeof(Tcl_Obj *) * (objc-1));
1661                     result = Tcl_EvalObjv(interp, objc, newObjv, 0);
1662                     Tcl_DecrRefCount(newObjv[0]);
1663                     ckfree((char *)newObjv);
1664                     return result;
1665                 }
1666             }
1667         }
1668     }
1669     isTypeMethod = 0;
1670     found = 0;
1671     FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
1672         if (strcmp(Tcl_GetString(idmPtr->namePtr), funcName) == 0) {
1673             if (idmPtr->flags & ITCL_TYPE_METHOD) {
1674                isTypeMethod = 1;
1675             }
1676             found = 1;
1677             break;
1678         }
1679         if (strcmp(Tcl_GetString(idmPtr->namePtr), "*") == 0) {
1680             if (idmPtr->flags & ITCL_TYPE_METHOD) {
1681                isTypeMethod = 1;
1682             }
1683             found = 1;
1684             break;
1685         }
1686     }
1687     if (! found) {
1688         idmPtr = NULL;
1689     }
1690     iclsPtr = ioPtr->iclsPtr;
1691     found = 0;
1692     hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]);
1693     if (hPtr == NULL) {
1694         objPtr = Tcl_NewStringObj("*", -1);
1695         Tcl_IncrRefCount(objPtr);
1696         hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
1697                 (char *)objPtr);
1698         Tcl_DecrRefCount(objPtr);
1699         if (hPtr != NULL) {
1700             idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
1701             isStar = 1;
1702         }
1703     } else {
1704         found = 1;
1705         idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
1706     }
1707     if (isStar) {
1708        /* check if the function is in the exceptions */
1709         hPtr2 = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]);
1710         if (hPtr2 != NULL) {
1711             const char *sep = "";
1712             objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
1713             Tcl_AppendToObj(objPtr, funcName, -1);
1714             Tcl_AppendToObj(objPtr, "\": must be ", -1);
1715             FOREACH_HASH_VALUE(idmPtr,
1716                     &iclsPtr->delegatedFunctions) {
1717                 funcName = Tcl_GetString(idmPtr->namePtr);
1718                 if (strcmp(funcName, "*") != 0) {
1719                     if (strlen(sep) > 0) {
1720                         Tcl_AppendToObj(objPtr, sep, -1);
1721                     }
1722                     Tcl_AppendToObj(objPtr, funcName, -1);
1723                     sep = " or ";
1724                 }
1725             }
1726             Tcl_SetObjResult(interp, objPtr);
1727             return TCL_ERROR;
1728         }
1729     }
1730     val = NULL;
1731     if ((idmPtr != NULL) && (idmPtr->icPtr != NULL)) {
1732         Tcl_Obj *objPtr;
1733         /* we cannot use Itcl_GetInstanceVar here as the object is not
1734          * yet completely built. So use the varNsNamePtr
1735          */
1736         if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) {
1737             objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1);
1738             Tcl_AppendToObj(objPtr,
1739                     (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, -1);
1740             Tcl_AppendToObj(objPtr, "::", -1);
1741             Tcl_AppendToObj(objPtr,
1742                     Tcl_GetString(idmPtr->icPtr->namePtr), -1);
1743             val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0);
1744             Tcl_DecrRefCount(objPtr);
1745         } else {
1746             Tcl_DStringInit(&buffer);
1747             Tcl_DStringAppend(&buffer,
1748                     Tcl_GetString(ioPtr->varNsNamePtr), -1);
1749             Tcl_DStringAppend(&buffer,
1750                     Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), -1);
1751             val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer),
1752                     NULL, 0);
1753             Tcl_DStringFree(&buffer);
1754         }
1755
1756         if (val == NULL) {
1757             Tcl_AppendResult(interp, "ItclBiObjectUnknownCmd contents of ",
1758                     "component == NULL\n", NULL);
1759             return TCL_ERROR;
1760         }
1761     }
1762
1763     offset = 1;
1764     if (isStar) {
1765         hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)objv[1]);
1766         /* we have no method name in that case in the caller */
1767         if (hPtr != NULL) {
1768             const char *sep = "";
1769             objPtr = Tcl_NewStringObj("unknown subcommand \"", -1);
1770             Tcl_AppendToObj(objPtr, funcName, -1);
1771             Tcl_AppendToObj(objPtr, "\": must be ", -1);
1772             FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) {
1773                 funcName = Tcl_GetString(idmPtr->namePtr);
1774                 if (strcmp(funcName, "*") != 0) {
1775                     if (strlen(sep) > 0) {
1776                         Tcl_AppendToObj(objPtr, sep, -1);
1777                     }
1778                     Tcl_AppendToObj(objPtr, funcName, -1);
1779                     sep = " or ";
1780                 }
1781             }
1782         }
1783     }
1784     if (idmPtr == NULL) {
1785         Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
1786                 "\": should be one of...", NULL);
1787         ItclReportObjectUsage(interp, ioPtr, NULL, NULL);
1788         return TCL_ERROR;
1789     }
1790     lObjc = 0;
1791     if ((idmPtr != NULL) && ((idmPtr->asPtr != NULL) ||
1792             (idmPtr->usingPtr != NULL))) {
1793         offset++;
1794         listPtr = Tcl_NewListObj(0, NULL);
1795         result = ExpandDelegateAs(interp, NULL, iclsPtr,
1796                 idmPtr, funcName, listPtr);
1797         if (result != TCL_OK) {
1798             Tcl_DecrRefCount(listPtr);
1799             return result;
1800         }
1801         result = Tcl_ListObjGetElements(interp, listPtr,
1802                 &lObjc, &lObjv);
1803         if (result != TCL_OK) {
1804             Tcl_DecrRefCount(listPtr);
1805             return result;
1806         }
1807         if (idmPtr->usingPtr != NULL) {
1808             useComponent = 0;
1809         }
1810     }
1811     if (useComponent) {
1812         if ((val == NULL) || (strlen(val) == 0)) {
1813             Tcl_AppendResult(interp, "component \"",
1814                     Tcl_GetString(idmPtr->icPtr->namePtr),
1815                     "\" is not initialized", NULL);
1816             return TCL_ERROR;
1817         }
1818     }
1819     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) *
1820                 (objc + lObjc - offset + useComponent));
1821     if (useComponent) {
1822         newObjv[0] = Tcl_NewStringObj(val, -1);
1823         Tcl_IncrRefCount(newObjv[0]);
1824     }
1825     for (idx = 0; idx < lObjc; idx++) {
1826         newObjv[useComponent+idx] = lObjv[idx];
1827     }
1828     if (objc-offset > 0) {
1829         memcpy(newObjv+useComponent+lObjc, objv+offset,
1830                 sizeof(Tcl_Obj *) * (objc-offset));
1831     }
1832     ItclShowArgs(1, "UK EVAL2", objc+lObjc-offset+useComponent,
1833             newObjv);
1834     result = Tcl_EvalObjv(interp, objc+lObjc-offset+useComponent,
1835             newObjv, 0);
1836     if (isStar && (result == TCL_OK)) {
1837         if (Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
1838                 (char *)newObjv[1]) == NULL) {
1839             result = ItclCreateDelegatedFunction(interp, iclsPtr,
1840                     newObjv[1], idmPtr->icPtr, NULL, NULL,
1841                     NULL, &idmPtr2);
1842             if (result == TCL_OK) {
1843                 if (isTypeMethod) {
1844                     idmPtr2->flags |= ITCL_TYPE_METHOD;
1845                 } else {
1846                     idmPtr2->flags |= ITCL_METHOD;
1847                 }
1848                 hPtr2 = Tcl_CreateHashEntry(
1849                         &iclsPtr->delegatedFunctions, (char *)newObjv[1],
1850                         &isNew);
1851                 Tcl_SetHashValue(hPtr2, idmPtr2);
1852             }
1853         }
1854     }
1855     if (useComponent) {
1856         Tcl_DecrRefCount(newObjv[0]);
1857     }
1858     if (listPtr != NULL) {
1859         Tcl_DecrRefCount(listPtr);
1860     }
1861     ckfree((char *)newObjv);
1862     if (result == TCL_OK) {
1863         return TCL_OK;
1864     }
1865     resStr = Tcl_GetString(Tcl_GetObjResult(interp));
1866     /* FIXME ugly hack at the moment !! */
1867     if (strncmp(resStr, "wrong # args: should be ", 24) == 0) {
1868         resPtr = Tcl_NewStringObj("", -1);
1869         Tcl_AppendToObj(resPtr, resStr, 25);
1870         resStr += 25;
1871         Tcl_AppendToObj(resPtr, Tcl_GetString(iclsPtr->namePtr), -1);
1872         resStr += strlen(val);
1873         Tcl_AppendToObj(resPtr, resStr, -1);
1874         Tcl_ResetResult(interp);
1875         Tcl_SetObjResult(interp, resPtr);
1876     }
1877     return result;
1878 }
1879
1880 static Tcl_Obj *makeAsOptionInfo(
1881     Tcl_Interp *interp,
1882     Tcl_Obj *optNamePtr,
1883     ItclDelegatedOption *idoPtr,
1884     int lObjc2,
1885     Tcl_Obj * const *lObjv2)
1886 {
1887     Tcl_Obj *objPtr;
1888     int j;
1889
1890     objPtr = Tcl_NewListObj(0, NULL);
1891     Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
1892             Tcl_GetString(optNamePtr), -1));
1893     Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
1894             Tcl_GetString(idoPtr->resourceNamePtr), -1));
1895     Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
1896             Tcl_GetString(idoPtr->classNamePtr), -1));
1897     for (j = 3; j < lObjc2; j++) {
1898          Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
1899                 Tcl_GetString(lObjv2[j]), -1));
1900     }
1901     return objPtr;
1902 }
1903 \f
1904 /*
1905  * ------------------------------------------------------------------------
1906  *  ItclExtendedConfigure()
1907  *
1908  *  Invoked whenever the user issues the "configure" method for an object.
1909  *  If the class is not ITCL_CLASS
1910  *  Handles the following syntax:
1911  *
1912  *    <objName> configure ?-<option>? ?<value> -<option> <value>...?
1913  *
1914  *  Allows access to public variables as if they were configuration
1915  *  options.  With no arguments, this command returns the current
1916  *  list of public variable options.  If -<option> is specified,
1917  *  this returns the information for just one option:
1918  *
1919  *    -<optionName> <initVal> <currentVal>
1920  *
1921  *  Otherwise, the list of arguments is parsed, and values are
1922  *  assigned to the various public variable options.  When each
1923  *  option changes, a big of "config" code associated with the option
1924  *  is executed, to bring the object up to date.
1925  * ------------------------------------------------------------------------
1926  */
1927 /* ARGSUSED */
1928 static int
1929 ItclExtendedConfigure(
1930     void *dummy,   /* class definition */
1931     Tcl_Interp *interp,      /* current interpreter */
1932     int objc,                /* number of arguments */
1933     Tcl_Obj *const objv[])   /* argument objects */
1934 {
1935     FOREACH_HASH_DECLS;
1936     Tcl_HashTable unique;
1937     Tcl_HashEntry *hPtr2;
1938     Tcl_HashEntry *hPtr3;
1939     Tcl_Object oPtr;
1940     Tcl_Obj *listPtr;
1941     Tcl_Obj *listPtr2;
1942     Tcl_Obj *resultPtr;
1943     Tcl_Obj *objPtr;
1944     Tcl_Obj *optNamePtr;
1945     Tcl_Obj *methodNamePtr;
1946     Tcl_Obj *configureMethodPtr;
1947     Tcl_Obj **lObjv;
1948     Tcl_Obj **newObjv;
1949     Tcl_Obj *lObjvOne[1];
1950     Tcl_Obj **lObjv2;
1951     Tcl_Obj **lObjv3;
1952     Tcl_Namespace *saveNsPtr;
1953     Tcl_Namespace *evalNsPtr;
1954     ItclClass *contextIclsPtr;
1955     ItclClass *iclsPtr2;
1956     ItclComponent *componentIcPtr;
1957     ItclObject *contextIoPtr;
1958     ItclDelegatedFunction *idmPtr;
1959     ItclDelegatedOption *idoPtr;
1960     ItclDelegatedOption *saveIdoPtr;
1961     ItclObject *ioPtr;
1962     ItclComponent *icPtr;
1963     ItclOption *ioptPtr;
1964     ItclObjectInfo *infoPtr;
1965     const char *val;
1966     int lObjc;
1967     int lObjc2;
1968     int lObjc3;
1969     int i;
1970     int j;
1971     int isNew;
1972     int result;
1973     int isOneOption;
1974     (void)dummy;
1975
1976     ItclShowArgs(1, "ItclExtendedConfigure", objc, objv);
1977     ioptPtr = NULL;
1978     optNamePtr = NULL;
1979     /*
1980      *  Make sure that this command is being invoked in the proper
1981      *  context.
1982      */
1983     contextIclsPtr = NULL;
1984     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
1985         return TCL_ERROR;
1986     }
1987
1988     if (contextIoPtr == NULL) {
1989         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1990             "improper usage: should be ",
1991             "\"object configure ?-option? ?value -option value...?\"",
1992             NULL);
1993         return TCL_ERROR;
1994     }
1995
1996     /*
1997      *  BE CAREFUL:  work in the virtual scope!
1998      */
1999     if (contextIoPtr != NULL) {
2000         contextIclsPtr = contextIoPtr->iclsPtr;
2001     }
2002     infoPtr = contextIclsPtr->infoPtr;
2003     if (infoPtr->currContextIclsPtr != NULL) {
2004         contextIclsPtr = infoPtr->currContextIclsPtr;
2005     }
2006
2007     hPtr = NULL;
2008     /* first check if method configure is delegated */
2009     methodNamePtr = Tcl_NewStringObj("*", -1);
2010     hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)
2011             methodNamePtr);
2012     if (hPtr != NULL) {
2013         /* all methods are delegated */
2014         idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
2015         Tcl_SetStringObj(methodNamePtr, "configure", -1);
2016         hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr);
2017         if (hPtr == NULL) {
2018             icPtr = idmPtr->icPtr;
2019             val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
2020                     NULL, contextIoPtr, contextIclsPtr);
2021             if (val != NULL) {
2022                 newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+5));
2023                 newObjv[0] = Tcl_NewStringObj(val, -1);
2024                 Tcl_IncrRefCount(newObjv[0]);
2025                 newObjv[1] = Tcl_NewStringObj("configure", -1);
2026                 Tcl_IncrRefCount(newObjv[1]);
2027                 for(i=1;i<objc;i++) {
2028                     newObjv[i+1] = objv[i];
2029                 }
2030                 objPtr = Tcl_NewStringObj(val, -1);
2031                 Tcl_IncrRefCount(objPtr);
2032                 oPtr = Tcl_GetObjectFromObj(interp, objPtr);
2033                 if (oPtr != NULL) {
2034                     ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2035                             infoPtr->object_meta_type);
2036                     infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
2037                 }
2038                 ItclShowArgs(1, "EXTENDED CONFIGURE EVAL1", objc+1, newObjv);
2039                 result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
2040                 Tcl_DecrRefCount(newObjv[0]);
2041                 Tcl_DecrRefCount(newObjv[1]);
2042                 ckfree((char *)newObjv);
2043                 Tcl_DecrRefCount(objPtr);
2044                 if (oPtr != NULL) {
2045                     infoPtr->currContextIclsPtr = NULL;
2046                 }
2047                 Tcl_DecrRefCount(methodNamePtr);
2048                 return result;
2049             }
2050         } else {
2051             /* configure is not delegated, so reset hPtr for checks later on! */
2052             hPtr = NULL;
2053         }
2054     }
2055     Tcl_DecrRefCount(methodNamePtr);
2056     /* now do the hard work */
2057     if (objc == 1) {
2058         Tcl_InitObjHashTable(&unique);
2059         /* plain configure */
2060         listPtr = Tcl_NewListObj(0, NULL);
2061         if (contextIclsPtr->flags & ITCL_ECLASS) {
2062             result = Tcl_EvalEx(interp, "::itcl::builtin::getEclassOptions", -1, 0);
2063             return result;
2064         }
2065         FOREACH_HASH_VALUE(ioptPtr, &contextIoPtr->objectOptions) {
2066             hPtr2 = Tcl_CreateHashEntry(&unique,
2067                     (char *)ioptPtr->namePtr, &isNew);
2068             if (!isNew) {
2069                 continue;
2070             }
2071             objPtr = Tcl_NewListObj(0, NULL);
2072             Tcl_ListObjAppendElement(interp, objPtr,
2073                     Tcl_NewStringObj(Tcl_GetString(ioptPtr->namePtr), -1));
2074             Tcl_ListObjAppendElement(interp, objPtr,
2075                     Tcl_NewStringObj(
2076                     Tcl_GetString(ioptPtr->resourceNamePtr), -1));
2077             Tcl_ListObjAppendElement(interp, objPtr,
2078                     Tcl_NewStringObj(Tcl_GetString(ioptPtr->classNamePtr), -1));
2079             if (ioptPtr->defaultValuePtr != NULL) {
2080                 Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(
2081                         Tcl_GetString(ioptPtr->defaultValuePtr), -1));
2082             } else {
2083                 Tcl_ListObjAppendElement(interp, objPtr,
2084                         Tcl_NewStringObj("", -1));
2085             }
2086             val = ItclGetInstanceVar(interp, "itcl_options",
2087                     Tcl_GetString(ioptPtr->namePtr), contextIoPtr,
2088                     contextIclsPtr);
2089             if (val == NULL) {
2090                 val = "<undefined>";
2091             }
2092             Tcl_ListObjAppendElement(interp, objPtr,
2093                     Tcl_NewStringObj(val, -1));
2094             Tcl_ListObjAppendElement(interp, listPtr, objPtr);
2095         }
2096         /* now check for delegated options */
2097         FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) {
2098
2099             if (idoPtr->icPtr != NULL) {
2100                 icPtr = idoPtr->icPtr;
2101                 val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
2102                     NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
2103                 if ((val != NULL) && (strlen(val) != 0)) {
2104
2105                     objPtr = Tcl_NewStringObj(val, -1);
2106                     Tcl_IncrRefCount(objPtr);
2107                     Tcl_AppendToObj(objPtr, " configure ", -1);
2108                     isOneOption = 0;
2109                     if (strcmp(Tcl_GetString(idoPtr->namePtr), "*") != 0) {
2110                         Tcl_AppendToObj(objPtr, " ", -1);
2111                         if (idoPtr->asPtr != NULL) {
2112                             Tcl_AppendToObj(objPtr, Tcl_GetString(
2113                                     idoPtr->asPtr), -1);
2114                         } else {
2115                             Tcl_AppendToObj(objPtr, Tcl_GetString(
2116                                     idoPtr->namePtr), -1);
2117                         }
2118                         isOneOption = 1;
2119                     }
2120                     result = Tcl_EvalObjEx(interp, objPtr, 0);
2121                     Tcl_DecrRefCount(objPtr);
2122                     if (result != TCL_OK) {
2123                         return TCL_ERROR;
2124                     }
2125                     listPtr2 = Tcl_GetObjResult(interp);
2126                     if (isOneOption) {
2127                         lObjc = 1;
2128                         lObjvOne[0] = listPtr2;
2129                         lObjv = &lObjvOne[0];
2130                     } else {
2131                         Tcl_ListObjGetElements(interp, listPtr2,
2132                                 &lObjc, &lObjv);
2133                     }
2134                     for (i = 0; i < lObjc; i++) {
2135                         objPtr = lObjv[i];
2136                         Tcl_ListObjGetElements(interp, objPtr,
2137                             &lObjc2, &lObjv2);
2138                         optNamePtr = idoPtr->namePtr;
2139                         if (lObjc2 == 0) {
2140                             hPtr = NULL;
2141                         } else {
2142                             hPtr = Tcl_FindHashEntry(&idoPtr->exceptions,
2143                                     (char *)lObjv2[0]);
2144                             if (isOneOption) {
2145                                 /* avoid wrong name where asPtr != NULL */
2146                                 optNamePtr = idoPtr->namePtr;
2147                             } else {
2148                                 optNamePtr = lObjv2[0];
2149                             }
2150                         }
2151                         if ((hPtr == NULL) && (lObjc2 > 0)) {
2152                             if (icPtr->haveKeptOptions) {
2153                                 hPtr = Tcl_FindHashEntry(&icPtr->keptOptions,
2154                                         (char *)optNamePtr);
2155                                 if (hPtr == NULL) {
2156                                    if (idoPtr->asPtr != NULL) {
2157                                        if (strcmp(Tcl_GetString(idoPtr->asPtr),
2158                                                Tcl_GetString(lObjv2[0])) == 0) {
2159                                            hPtr = Tcl_FindHashEntry(
2160                                                 &icPtr->keptOptions,
2161                                                 (char *)optNamePtr);
2162                                            if (hPtr == NULL) {
2163                                                /* not in kept list, so ignore */
2164                                                continue;
2165                                            }
2166                                            objPtr = makeAsOptionInfo(interp,
2167                                                optNamePtr, idoPtr, lObjc2,
2168                                                lObjv2);
2169                                        }
2170                                     }
2171                                 }
2172                                 if (hPtr != NULL) {
2173                                     hPtr2 = Tcl_CreateHashEntry(&unique,
2174                                             (char *)optNamePtr, &isNew);
2175                                     if (!isNew) {
2176                                         continue;
2177                                     }
2178                                     /* add the option */
2179                                     if (idoPtr->asPtr != NULL) {
2180                                         objPtr = makeAsOptionInfo(interp,
2181                                                 optNamePtr, idoPtr, lObjc2,
2182                                                 lObjv2);
2183                                     }
2184                                     Tcl_ListObjAppendElement(interp, listPtr,
2185                                             objPtr);
2186                                 }
2187                             } else {
2188                                 Tcl_ListObjGetElements(interp, lObjv2[i],
2189                                         &lObjc3, &lObjv3);
2190                                 hPtr2 = Tcl_CreateHashEntry(&unique,
2191                                         (char *)lObjv3[0], &isNew);
2192                                 if (!isNew) {
2193                                     continue;
2194                                 }
2195                                 /* add the option */
2196                                 if (idoPtr->asPtr != NULL) {
2197                                     objPtr = makeAsOptionInfo(interp,
2198                                             optNamePtr, idoPtr, lObjc2,
2199                                             lObjv2);
2200                                 }
2201                                 Tcl_ListObjAppendElement(interp, listPtr,
2202                                     objPtr);
2203                             }
2204                         }
2205                     }
2206                 }
2207             }
2208         }
2209         Tcl_SetObjResult(interp, listPtr);
2210         Tcl_DeleteHashTable(&unique);
2211         return TCL_OK;
2212     }
2213     hPtr2 = NULL;
2214     /* first handle delegated options */
2215     hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
2216             objv[1]);
2217     if (hPtr == NULL) {
2218         Tcl_Obj *objPtr;
2219         objPtr = Tcl_NewStringObj("*",1);
2220         Tcl_IncrRefCount(objPtr);
2221         /* check if all options are delegated */
2222         hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions,
2223                 (char *)objPtr);
2224         Tcl_DecrRefCount(objPtr);
2225         if (hPtr != NULL) {
2226             /* now check the exceptions */
2227             idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
2228             hPtr2 = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)objv[1]);
2229             if (hPtr2 != NULL) {
2230                 /* found in exceptions, so no delegation for this option */
2231                 hPtr = NULL;
2232             }
2233         }
2234     }
2235     componentIcPtr = NULL;
2236     /* check if it is not a local option defined before delegate option "*"
2237      */
2238     hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
2239             (char *)objv[1]);
2240     if (hPtr != NULL) {
2241         idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
2242         icPtr = idoPtr->icPtr;
2243         if (icPtr != NULL) {
2244             if (icPtr->haveKeptOptions) {
2245                 hPtr3 = Tcl_FindHashEntry(&icPtr->keptOptions, (char *)objv[1]);
2246                 if (hPtr3 != NULL) {
2247                     /* ignore if it is an object option only */
2248                     ItclHierIter hier;
2249                     int found;
2250
2251                     found = 0;
2252                     Itcl_InitHierIter(&hier, contextIoPtr->iclsPtr);
2253                     iclsPtr2 = Itcl_AdvanceHierIter(&hier);
2254                     while (iclsPtr2 != NULL) {
2255                         if (Tcl_FindHashEntry(&iclsPtr2->options,
2256                                 (char *)objv[1]) != NULL) {
2257                             found = 1;
2258                             break;
2259                         }
2260                         iclsPtr2 = Itcl_AdvanceHierIter(&hier);
2261                     }
2262                     Itcl_DeleteHierIter(&hier);
2263                     if (! found) {
2264                         hPtr2 = NULL;
2265                         componentIcPtr = icPtr;
2266                     }
2267                 }
2268             }
2269         }
2270     }
2271     if ((objc <= 3) && (hPtr != NULL) && (hPtr2 == NULL)) {
2272         /* the option is delegated */
2273         idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
2274         if (componentIcPtr != NULL) {
2275             icPtr = componentIcPtr;
2276         } else {
2277             icPtr = idoPtr->icPtr;
2278         }
2279         val = ItclGetInstanceVar(interp,
2280                 Tcl_GetString(icPtr->namePtr),
2281                 NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
2282         if ((val != NULL) && (strlen(val) > 0)) {
2283             if (idoPtr->asPtr != NULL) {
2284                 icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr;
2285             }
2286             newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2));
2287             newObjv[0] = Tcl_NewStringObj(val, -1);
2288             Tcl_IncrRefCount(newObjv[0]);
2289             newObjv[1] = Tcl_NewStringObj("configure", 9);
2290             Tcl_IncrRefCount(newObjv[1]);
2291             if (idoPtr->asPtr != NULL) {
2292                 newObjv[2] = idoPtr->asPtr;
2293             } else {
2294                 newObjv[2] = objv[1];
2295             }
2296             Tcl_IncrRefCount(newObjv[2]);
2297             for(i=2;i<objc;i++) {
2298                 newObjv[i+1] = objv[i];
2299             }
2300             objPtr = Tcl_NewStringObj(val, -1);
2301             Tcl_IncrRefCount(objPtr);
2302             oPtr = Tcl_GetObjectFromObj(interp, objPtr);
2303             if (oPtr != NULL) {
2304                 ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2305                         infoPtr->object_meta_type);
2306                 infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
2307             }
2308             Tcl_DecrRefCount(objPtr);
2309             ItclShowArgs(1, "extended eval delegated option", objc + 1,
2310                     newObjv);
2311             result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
2312             Tcl_DecrRefCount(newObjv[2]);
2313             Tcl_DecrRefCount(newObjv[1]);
2314             Tcl_DecrRefCount(newObjv[0]);
2315             ckfree((char *)newObjv);
2316             icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL;
2317             if (oPtr != NULL) {
2318                 infoPtr->currContextIclsPtr = NULL;
2319             }
2320             return result;
2321         } else {
2322             Tcl_AppendResult(interp, "INTERNAL ERROR component \"",
2323                     Tcl_GetString(icPtr->namePtr), "\" not found",
2324                     " or not set in ItclExtendedConfigure delegated option",
2325                     NULL);
2326             return TCL_ERROR;
2327         }
2328     }
2329
2330     if (objc == 2) {
2331         saveIdoPtr = infoPtr->currIdoPtr;
2332         /* now look if it is an option at all */
2333         if (hPtr2 == NULL) {
2334             hPtr2 = Tcl_FindHashEntry(&contextIclsPtr->options,
2335                     (char *) objv[1]);
2336             if (hPtr2 == NULL) {
2337                 hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
2338                         (char *) objv[1]);
2339             } else {
2340                infoPtr->currIdoPtr = NULL;
2341             }
2342         }
2343         if (hPtr2 == NULL) {
2344             if (contextIclsPtr->flags & ITCL_ECLASS) {
2345                 newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
2346                 newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1);
2347                 Tcl_IncrRefCount(newObjv[0]);
2348                 for (j = 1; j < objc; j++) {
2349                     newObjv[j] = objv[j];
2350                     Tcl_IncrRefCount(newObjv[j]);
2351                 }
2352                 result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
2353                 for (j = 0; j < objc; j++) {
2354                     Tcl_DecrRefCount(newObjv[j]);
2355                 }
2356                 ckfree((char *)newObjv);
2357                 if (result == TCL_OK) {
2358                   return TCL_OK;
2359                 }
2360             }
2361             /* no option at all, let the normal configure do the job */
2362             infoPtr->currIdoPtr = saveIdoPtr;
2363             return TCL_CONTINUE;
2364         }
2365         ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2);
2366         resultPtr = ItclReportOption(interp, ioptPtr, contextIoPtr);
2367         infoPtr->currIdoPtr = saveIdoPtr;
2368         Tcl_SetObjResult(interp, resultPtr);
2369         return TCL_OK;
2370     }
2371     result = TCL_OK;
2372     /* set one or more options */
2373     for (i=1; i < objc; i+=2) {
2374         if (i+1 >= objc) {
2375             Tcl_AppendResult(interp, "need option value pair", NULL);
2376             result = TCL_ERROR;
2377             break;
2378         }
2379         hPtr = Tcl_FindHashEntry(&contextIoPtr->objectOptions,
2380                 (char *) objv[i]);
2381         if (hPtr == NULL) {
2382             if (contextIclsPtr->flags & ITCL_ECLASS) {
2383                 newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc));
2384                 newObjv[0] = Tcl_NewStringObj("::itcl::builtin::eclassConfigure", -1);
2385                 Tcl_IncrRefCount(newObjv[0]);
2386                 for (j = 1; j < objc; j++) {
2387                     newObjv[j] = objv[j];
2388                     Tcl_IncrRefCount(newObjv[j]);
2389                 }
2390                 result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
2391                 for (j = 0; j < objc; j++) {
2392                     Tcl_DecrRefCount(newObjv[j]);
2393                 }
2394                 ckfree((char *)newObjv);
2395                 if (result == TCL_OK) {
2396                   continue;
2397                 }
2398             }
2399             hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions,
2400                     (char *) objv[i]);
2401             if (hPtr != NULL) {
2402                 /* the option is delegated */
2403                 idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
2404                 icPtr = idoPtr->icPtr;
2405                 val = ItclGetInstanceVar(interp,
2406                         Tcl_GetString(icPtr->ivPtr->namePtr),
2407                         NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
2408                 if ((val != NULL) && (strlen(val) > 0)) {
2409                     if (idoPtr->asPtr != NULL) {
2410                         icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = idoPtr;
2411                     }
2412                     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2));
2413                     newObjv[0] = Tcl_NewStringObj(val, -1);
2414                     Tcl_IncrRefCount(newObjv[0]);
2415                     newObjv[1] = Tcl_NewStringObj("configure", 9);
2416                     Tcl_IncrRefCount(newObjv[1]);
2417                     if (idoPtr->asPtr != NULL) {
2418                         newObjv[2] = idoPtr->asPtr;
2419                     } else {
2420                         newObjv[2] = objv[i];
2421                     }
2422                     Tcl_IncrRefCount(newObjv[2]);
2423                     newObjv[3] = objv[i+1];
2424                     objPtr = Tcl_NewStringObj(val, -1);
2425                     Tcl_IncrRefCount(objPtr);
2426                     oPtr = Tcl_GetObjectFromObj(interp, objPtr);
2427                     if (oPtr != NULL) {
2428                         ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2429                                 infoPtr->object_meta_type);
2430                         infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
2431                     }
2432                     Tcl_DecrRefCount(objPtr);
2433                     ItclShowArgs(1, "extended eval delegated option", 4,
2434                             newObjv);
2435                     result = Tcl_EvalObjv(interp, 4, newObjv, TCL_EVAL_DIRECT);
2436                     Tcl_DecrRefCount(newObjv[2]);
2437                     Tcl_DecrRefCount(newObjv[1]);
2438                     Tcl_DecrRefCount(newObjv[0]);
2439                     ckfree((char *)newObjv);
2440                     icPtr->ivPtr->iclsPtr->infoPtr->currIdoPtr = NULL;
2441                     if (oPtr != NULL) {
2442                         infoPtr->currContextIclsPtr = NULL;
2443                     }
2444                     continue;
2445                 } else {
2446                     Tcl_AppendResult(interp, "INTERNAL ERROR component not ",
2447                             "found or not set in ItclExtendedConfigure ",
2448                             "delegated option", NULL);
2449                     return TCL_ERROR;
2450                 }
2451             }
2452         }
2453         if (hPtr == NULL) {
2454             infoPtr->unparsedObjc += 2;
2455             if (infoPtr->unparsedObjv == NULL) {
2456                 infoPtr->unparsedObjc++; /* keep the first slot for
2457                                             correct working !! */
2458                 infoPtr->unparsedObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)
2459                         *(infoPtr->unparsedObjc));
2460                 infoPtr->unparsedObjv[0] = objv[0];
2461             } else {
2462                 infoPtr->unparsedObjv = (Tcl_Obj **)ckrealloc(
2463                         (char *)infoPtr->unparsedObjv, sizeof(Tcl_Obj *)
2464                         *(infoPtr->unparsedObjc));
2465             }
2466             infoPtr->unparsedObjv[infoPtr->unparsedObjc-2] = objv[i];
2467             Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-2]);
2468             infoPtr->unparsedObjv[infoPtr->unparsedObjc-1] = objv[i+1];
2469             Tcl_IncrRefCount(infoPtr->unparsedObjv[infoPtr->unparsedObjc-1]);
2470             /* check if normal public variable/common ? */
2471             /* FIXME !!! temporary */
2472             continue;
2473         }
2474         ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr);
2475         if (ioptPtr->flags & ITCL_OPTION_READONLY) {
2476             if (infoPtr->currIoPtr == NULL) {
2477                 /* allow only setting during instance creation
2478                  * infoPtr->currIoPtr != NULL during instance creation
2479                  */
2480                 Tcl_AppendResult(interp, "option \"",
2481                         Tcl_GetString(ioptPtr->namePtr),
2482                         "\" can only be set at instance creation", NULL);
2483                 return TCL_ERROR;
2484             }
2485         }
2486         if (ioptPtr->validateMethodPtr != NULL) {
2487             newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 3);
2488             newObjv[0] = ioptPtr->validateMethodPtr;
2489             newObjv[1] = objv[i];
2490             newObjv[2] = objv[i+1];
2491             infoPtr->inOptionHandling = 1;
2492             saveNsPtr = Tcl_GetCurrentNamespace(interp);
2493             Itcl_SetCallFrameNamespace(interp, contextIclsPtr->nsPtr);
2494             ItclShowArgs(1, "EVAL validatemethod", 3, newObjv);
2495             result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
2496             Itcl_SetCallFrameNamespace(interp, saveNsPtr);
2497             infoPtr->inOptionHandling = 0;
2498             ckfree((char *)newObjv);
2499             if (result != TCL_OK) {
2500                 break;
2501             }
2502         }
2503         configureMethodPtr = NULL;
2504         evalNsPtr = NULL;
2505         if (ioptPtr->configureMethodPtr != NULL) {
2506             configureMethodPtr = ioptPtr->configureMethodPtr;
2507             Tcl_IncrRefCount(configureMethodPtr);
2508             evalNsPtr = ioptPtr->iclsPtr->nsPtr;
2509         }
2510         if (ioptPtr->configureMethodVarPtr != NULL) {
2511             val = ItclGetInstanceVar(interp,
2512                     Tcl_GetString(ioptPtr->configureMethodVarPtr), NULL,
2513                     contextIoPtr, ioptPtr->iclsPtr);
2514             if (val == NULL) {
2515                 Tcl_AppendResult(interp, "configure cannot get value for",
2516                         " configuremethodvar \"",
2517                         Tcl_GetString(ioptPtr->configureMethodVarPtr),
2518                         "\"", NULL);
2519                 return TCL_ERROR;
2520             }
2521             objPtr = Tcl_NewStringObj(val, -1);
2522             hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveCmds,
2523                 (char *)objPtr);
2524             Tcl_DecrRefCount(objPtr);
2525             if (hPtr != NULL) {
2526                 ItclMemberFunc *imPtr;
2527                 ItclCmdLookup *clookup;
2528                 clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
2529                 imPtr = clookup->imPtr;
2530                 evalNsPtr = imPtr->iclsPtr->nsPtr;
2531             } else {
2532                 Tcl_AppendResult(interp, "cannot find method \"",
2533                         val, "\" found in configuremethodvar", NULL);
2534                 return TCL_ERROR;
2535             }
2536             configureMethodPtr = Tcl_NewStringObj(val, -1);
2537             Tcl_IncrRefCount(configureMethodPtr);
2538         }
2539         if (configureMethodPtr != NULL) {
2540             newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3);
2541             newObjv[0] = configureMethodPtr;
2542             Tcl_IncrRefCount(newObjv[0]);
2543             newObjv[1] = objv[i];
2544             Tcl_IncrRefCount(newObjv[1]);
2545             newObjv[2] = objv[i+1];
2546             Tcl_IncrRefCount(newObjv[2]);
2547             saveNsPtr = Tcl_GetCurrentNamespace(interp);
2548             Itcl_SetCallFrameNamespace(interp, evalNsPtr);
2549             ItclShowArgs(1, "EVAL configuremethod", 3, newObjv);
2550             result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
2551             Tcl_DecrRefCount(newObjv[0]);
2552             Tcl_DecrRefCount(newObjv[1]);
2553             Tcl_DecrRefCount(newObjv[2]);
2554             ckfree((char *)newObjv);
2555             Itcl_SetCallFrameNamespace(interp, saveNsPtr);
2556             Tcl_DecrRefCount(configureMethodPtr);
2557             if (result != TCL_OK) {
2558                 break;
2559             }
2560         } else {
2561             if (ItclSetInstanceVar(interp, "itcl_options",
2562                     Tcl_GetString(objv[i]), Tcl_GetString(objv[i+1]),
2563                     contextIoPtr, ioptPtr->iclsPtr) == NULL) {
2564                 result = TCL_ERROR;
2565                 break;
2566             }
2567         }
2568         Tcl_ResetResult(interp);
2569         result = TCL_OK;
2570     }
2571     if (infoPtr->unparsedObjc > 0) {
2572         if (result == TCL_OK) {
2573             return TCL_CONTINUE;
2574         }
2575     }
2576     return result;
2577 }
2578 \f
2579 /*
2580  * ------------------------------------------------------------------------
2581  *  ItclExtendedCget()
2582  *
2583  *  Invoked whenever the user issues the "cget" method for an object.
2584  *  If the class is NOT ITCL_CLASS
2585  *  Handles the following syntax:
2586  *
2587  *    <objName> cget -<option>
2588  *
2589  *  Allows access to public variables as if they were configuration
2590  *  options.  Mimics the behavior of the usual "cget" method for
2591  *  Tk widgets.  Returns the current value of the public variable
2592  *  with name <option>.
2593  * ------------------------------------------------------------------------
2594  */
2595 /* ARGSUSED */
2596 static int
2597 ItclExtendedCget(
2598     void *dummy,   /* class definition */
2599     Tcl_Interp *interp,      /* current interpreter */
2600     int objc,                /* number of arguments */
2601     Tcl_Obj *const objv[])   /* argument objects */
2602 {
2603     Tcl_HashEntry *hPtr;
2604     Tcl_HashEntry *hPtr2;
2605     Tcl_HashEntry *hPtr3;
2606     Tcl_Obj *objPtr2;
2607     Tcl_Obj *objPtr;
2608     Tcl_Object oPtr;
2609     Tcl_Obj *methodNamePtr;
2610     Tcl_Obj **newObjv;
2611     ItclClass *contextIclsPtr;
2612     ItclObject *contextIoPtr;
2613     ItclDelegatedFunction *idmPtr;
2614     ItclDelegatedOption *idoPtr;
2615     ItclComponent *icPtr;
2616     ItclObjectInfo *infoPtr;
2617     ItclOption *ioptPtr;
2618     ItclObject *ioPtr;
2619     const char *val;
2620     int i;
2621     int result;
2622     (void)dummy;
2623
2624     ItclShowArgs(1,"ItclExtendedCget", objc, objv);
2625     /*
2626      *  Make sure that this command is being invoked in the proper
2627      *  context.
2628      */
2629     contextIclsPtr = NULL;
2630     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
2631         return TCL_ERROR;
2632     }
2633     if ((contextIoPtr == NULL) || objc != 2) {
2634         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2635             "improper usage: should be \"object cget -option\"",
2636             NULL);
2637         return TCL_ERROR;
2638     }
2639
2640     /*
2641      *  BE CAREFUL:  work in the virtual scope!
2642      */
2643     if (contextIoPtr != NULL) {
2644         contextIclsPtr = contextIoPtr->iclsPtr;
2645     }
2646     infoPtr = contextIclsPtr->infoPtr;
2647     if (infoPtr->currContextIclsPtr != NULL) {
2648         contextIclsPtr = infoPtr->currContextIclsPtr;
2649     }
2650
2651     hPtr = NULL;
2652     /* first check if method cget is delegated */
2653     methodNamePtr = Tcl_NewStringObj("*", -1);
2654     hPtr = Tcl_FindHashEntry(&contextIclsPtr->delegatedFunctions, (char *)
2655             methodNamePtr);
2656     if (hPtr != NULL) {
2657         idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr);
2658         Tcl_SetStringObj(methodNamePtr, "cget", -1);
2659         hPtr = Tcl_FindHashEntry(&idmPtr->exceptions, (char *)methodNamePtr);
2660         if (hPtr == NULL) {
2661             icPtr = idmPtr->icPtr;
2662             val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
2663                     NULL, contextIoPtr, contextIclsPtr);
2664             if (val != NULL) {
2665                 newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1));
2666                 newObjv[0] = Tcl_NewStringObj(val, -1);
2667                 Tcl_IncrRefCount(newObjv[0]);
2668                 newObjv[1] = Tcl_NewStringObj("cget", 4);
2669                 Tcl_IncrRefCount(newObjv[1]);
2670                 for(i=1;i<objc;i++) {
2671                     newObjv[i+1] = objv[i];
2672                 }
2673                 objPtr = Tcl_NewStringObj(val, -1);
2674                 Tcl_IncrRefCount(objPtr);
2675                 oPtr = Tcl_GetObjectFromObj(interp, objPtr);
2676                 if (oPtr != NULL) {
2677                     ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2678                             infoPtr->object_meta_type);
2679                     infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
2680                 }
2681                 ItclShowArgs(1, "DELEGATED EVAL", objc+1, newObjv);
2682                 result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
2683                 Tcl_DecrRefCount(newObjv[0]);
2684                 Tcl_DecrRefCount(newObjv[1]);
2685                 Tcl_DecrRefCount(objPtr);
2686                 if (oPtr != NULL) {
2687                     infoPtr->currContextIclsPtr = NULL;
2688                 }
2689                 Tcl_DecrRefCount(methodNamePtr);
2690                 return result;
2691             }
2692         }
2693     }
2694     Tcl_DecrRefCount(methodNamePtr);
2695     if (objc == 1) {
2696         Tcl_WrongNumArgs(interp, 1, objv, "option");
2697         return TCL_ERROR;
2698     }
2699     /* now do the hard work */
2700     /* first handle delegated options */
2701     hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
2702             objv[1]);
2703     hPtr3 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)
2704             objv[1]);
2705     hPtr2 = NULL;
2706     if (hPtr == NULL) {
2707         objPtr2 = Tcl_NewStringObj("*", -1);
2708         /* check for "*" option delegated */
2709         hPtr = Tcl_FindHashEntry(&contextIoPtr->objectDelegatedOptions, (char *)
2710                 objPtr2);
2711         Tcl_DecrRefCount(objPtr2);
2712         hPtr2 = Tcl_FindHashEntry(&contextIoPtr->objectOptions, (char *)
2713                 objv[1]);
2714     }
2715     if ((hPtr != NULL) && (hPtr2 == NULL) && (hPtr3 == NULL)) {
2716         /* the option is delegated */
2717         idoPtr = (ItclDelegatedOption *)Tcl_GetHashValue(hPtr);
2718         /* if the option is in the exceptions, do nothing */
2719         hPtr = Tcl_FindHashEntry(&idoPtr->exceptions, (char *)
2720                 objv[1]);
2721         if (hPtr) {
2722             return TCL_CONTINUE;
2723         }
2724         icPtr = idoPtr->icPtr;
2725         if (icPtr->ivPtr->flags & ITCL_COMMON) {
2726             val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
2727                     NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
2728         } else {
2729             val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
2730                     NULL, contextIoPtr, icPtr->ivPtr->iclsPtr);
2731         }
2732         if ((val != NULL) && (strlen(val) > 0)) {
2733             newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+1));
2734             newObjv[0] = Tcl_NewStringObj(val, -1);
2735             Tcl_IncrRefCount(newObjv[0]);
2736             newObjv[1] = Tcl_NewStringObj("cget", 4);
2737             Tcl_IncrRefCount(newObjv[1]);
2738             for(i=1;i<objc;i++) {
2739                 if (strcmp(Tcl_GetString(idoPtr->namePtr),
2740                         Tcl_GetString(objv[i])) == 0) {
2741                     if (idoPtr->asPtr != NULL) {
2742                         newObjv[i+1] = idoPtr->asPtr;
2743                     } else {
2744                         newObjv[i+1] = objv[i];
2745                     }
2746                 } else {
2747                     newObjv[i+1] = objv[i];
2748                 }
2749             }
2750             objPtr = Tcl_NewStringObj(val, -1);
2751             Tcl_IncrRefCount(objPtr);
2752             oPtr = Tcl_GetObjectFromObj(interp, objPtr);
2753             if (oPtr != NULL) {
2754                 ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
2755                         infoPtr->object_meta_type);
2756                 infoPtr->currContextIclsPtr = ioPtr->iclsPtr;
2757             }
2758             ItclShowArgs(1, "ExtendedCget delegated option", objc+1, newObjv);
2759             result = Tcl_EvalObjv(interp, objc+1, newObjv, TCL_EVAL_DIRECT);
2760             Tcl_DecrRefCount(newObjv[0]);
2761             Tcl_DecrRefCount(newObjv[1]);
2762             Tcl_DecrRefCount(objPtr);
2763             if (oPtr != NULL) {
2764                 infoPtr->currContextIclsPtr = NULL;
2765             }
2766             ckfree((char *)newObjv);
2767             return result;
2768         } else {
2769             Tcl_ResetResult(interp);
2770             Tcl_AppendResult(interp, "component \"",
2771                     Tcl_GetString(icPtr->namePtr),
2772                     "\" is undefined, needed for option \"",
2773                     Tcl_GetString(objv[1]),
2774                     "\"", NULL);
2775             return TCL_ERROR;
2776         }
2777     }
2778
2779     /* now look if it is an option at all */
2780     if ((hPtr2 == NULL) && (hPtr3 == NULL)) {
2781         /* no option at all, let the normal configure do the job */
2782         return TCL_CONTINUE;
2783     }
2784     if (hPtr3 != NULL) {
2785         ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr3);
2786     } else {
2787         ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr2);
2788     }
2789     result = TCL_CONTINUE;
2790     if (ioptPtr->cgetMethodPtr != NULL) {
2791         newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*2);
2792         newObjv[0] = ioptPtr->cgetMethodPtr;
2793         Tcl_IncrRefCount(newObjv[0]);
2794         newObjv[1] = objv[1];
2795         Tcl_IncrRefCount(newObjv[1]);
2796         ItclShowArgs(1, "eval cget method", objc, newObjv);
2797         result = Tcl_EvalObjv(interp, objc, newObjv, TCL_EVAL_DIRECT);
2798         Tcl_DecrRefCount(newObjv[1]);
2799         Tcl_DecrRefCount(newObjv[0]);
2800         ckfree((char *)newObjv);
2801     } else {
2802         val = ItclGetInstanceVar(interp, "itcl_options",
2803                 Tcl_GetString(ioptPtr->namePtr),
2804                 contextIoPtr, ioptPtr->iclsPtr);
2805         if (val) {
2806             Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
2807         } else {
2808             Tcl_SetObjResult(interp, Tcl_NewStringObj("<undefined>", -1));
2809         }
2810         result = TCL_OK;
2811     }
2812     return result;
2813 }
2814 \f
2815 /*
2816  * ------------------------------------------------------------------------
2817  *  ItclExtendedSetGet()
2818  *
2819  *  Invoked whenever the user writes to a methodvariable or calls the method
2820  *  with the same name as the variable.
2821  *  only for not ITCL_CLASS classes
2822  *  Handles the following syntax:
2823  *
2824  *    <objName> setget varName ?<value>?
2825  *
2826  *  Allows access to methodvariables as if they hat a setter and getter
2827  *  method
2828  *  With no arguments, this command returns the current
2829  *  value of the variable.  If <value> is specified,
2830  *  this sets the variable to the value calling a callback if exists:
2831  *
2832  * ------------------------------------------------------------------------
2833  */
2834 /* ARGSUSED */
2835 static int
2836 ItclExtendedSetGet(
2837     void *dummy,   /* class definition */
2838     Tcl_Interp *interp,      /* current interpreter */
2839     int objc,                /* number of arguments */
2840     Tcl_Obj *const objv[])   /* argument objects */
2841 {
2842     ItclClass *contextIclsPtr;
2843     ItclObject *contextIoPtr;
2844
2845     Tcl_HashEntry *hPtr;
2846     Tcl_Obj **newObjv;
2847     ItclMethodVariable *imvPtr;
2848     ItclObjectInfo *infoPtr;
2849     const char *usageStr;
2850     const char *val;
2851     int result;
2852     int setValue;
2853     (void)dummy;
2854
2855     ItclShowArgs(1, "ItclExtendedSetGet", objc, objv);
2856     imvPtr = NULL;
2857     result = TCL_OK;
2858     /*
2859      *  Make sure that this command is being invoked in the proper
2860      *  context.
2861      */
2862     contextIclsPtr = NULL;
2863     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
2864         return TCL_ERROR;
2865     }
2866
2867     usageStr = "improper usage: should be \"object setget varName ?value?\"";
2868     if (contextIoPtr == NULL) {
2869         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2870                 usageStr, NULL);
2871         return TCL_ERROR;
2872     }
2873
2874     /*
2875      *  BE CAREFUL:  work in the virtual scope!
2876      */
2877     if (contextIoPtr != NULL) {
2878         contextIclsPtr = contextIoPtr->iclsPtr;
2879     }
2880     infoPtr = contextIclsPtr->infoPtr;
2881     if (infoPtr->currContextIclsPtr != NULL) {
2882         contextIclsPtr = infoPtr->currContextIclsPtr;
2883     }
2884
2885     hPtr = NULL;
2886     if (objc < 2) {
2887         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2888                 usageStr, NULL);
2889         return TCL_ERROR;
2890     }
2891     /* look if it is an methodvariable at all */
2892     hPtr = Tcl_FindHashEntry(&contextIoPtr->objectMethodVariables,
2893             (char *) objv[1]);
2894     if (hPtr == NULL) {
2895         Tcl_AppendResult(interp, "no such methodvariable \"",
2896                 Tcl_GetString(objv[1]), "\"", NULL);
2897         return TCL_ERROR;
2898     }
2899     imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr);
2900     if (objc == 2) {
2901         val = ItclGetInstanceVar(interp, Tcl_GetString(objv[1]), NULL,
2902                 contextIoPtr, imvPtr->iclsPtr);
2903         if (val == NULL) {
2904             result = TCL_ERROR;
2905         } else {
2906            Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
2907         }
2908         return result;
2909     }
2910     imvPtr = (ItclMethodVariable *)Tcl_GetHashValue(hPtr);
2911     result = TCL_OK;
2912     setValue = 1;
2913     if (imvPtr->callbackPtr != NULL) {
2914         newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*3);
2915         newObjv[0] = imvPtr->callbackPtr;
2916         Tcl_IncrRefCount(newObjv[0]);
2917         newObjv[1] = objv[1];
2918         Tcl_IncrRefCount(newObjv[1]);
2919         newObjv[2] = objv[2];
2920         Tcl_IncrRefCount(newObjv[2]);
2921         result = Tcl_EvalObjv(interp, 3, newObjv, TCL_EVAL_DIRECT);
2922         Tcl_DecrRefCount(newObjv[0]);
2923         Tcl_DecrRefCount(newObjv[1]);
2924         Tcl_DecrRefCount(newObjv[2]);
2925         ckfree((char *)newObjv);
2926     }
2927     if (result == TCL_OK) {
2928         Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &setValue);
2929         /* if setValue != 0 set the new value of the variable here */
2930         if (setValue) {
2931             if (ItclSetInstanceVar(interp, Tcl_GetString(objv[1]), NULL,
2932                     Tcl_GetString(objv[2]), contextIoPtr,
2933                     imvPtr->iclsPtr) == NULL) {
2934                 result = TCL_ERROR;
2935             }
2936         }
2937     }
2938     return result;
2939 }
2940 /*
2941  * ------------------------------------------------------------------------
2942  *  Itcl_BiInstallComponentCmd()
2943  *
2944  *  Invoked whenever the user issues the "installcomponent" method for an
2945  *  object.
2946  *  Handles the following syntax:
2947  *
2948  *    installcomponent <componentName> using <widgetClassName> <widgetPathName>
2949  *      ?-option value -option value ...?
2950  *
2951  * ------------------------------------------------------------------------
2952  */
2953 /* ARGSUSED */
2954 int
2955 Itcl_BiInstallComponentCmd(
2956     void *dummy,   /* class definition */
2957     Tcl_Interp *interp,      /* current interpreter */
2958     int objc,                /* number of arguments */
2959     Tcl_Obj *const objv[])   /* argument objects */
2960 {
2961     FOREACH_HASH_DECLS;
2962     Tcl_Obj ** newObjv;
2963     ItclClass *contextIclsPtr;
2964     ItclObject *contextIoPtr;
2965     ItclDelegatedOption *idoPtr;
2966     const char *usageStr;
2967     const char *componentName;
2968     const char *componentValue;
2969     const char *token;
2970     int numOpts;
2971     int result;
2972     (void)dummy;
2973
2974     ItclShowArgs(1, "Itcl_BiInstallComponentCmd", objc, objv);
2975     /*
2976      *  Make sure that this command is being invoked in the proper
2977      *  context.
2978      */
2979     contextIclsPtr = NULL;
2980     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
2981         return TCL_ERROR;
2982     }
2983
2984     if (contextIoPtr == NULL) {
2985         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2986             "improper usage: should be \"object installcomponent \"",
2987             NULL);
2988         return TCL_ERROR;
2989     }
2990     if (objc < 5) {
2991         /* FIXME strip off the :: parts here properly*/
2992         token = Tcl_GetString(objv[0])+2;
2993         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2994             "wrong # args: should be \"", token, " <componentName> using",
2995             " <widgetClassName> <widgetPathName>",
2996             " ?-option value -option value ...?\"",
2997             NULL);
2998         return TCL_ERROR;
2999     }
3000
3001     /* get component name and check, if it exists */
3002     token = Tcl_GetString(objv[1]);
3003     if (contextIclsPtr == NULL) {
3004         Tcl_AppendResult(interp, "cannot find context class for object \"",
3005                 Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"",
3006                 NULL);
3007         return TCL_ERROR;
3008     }
3009     if (!(contextIclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
3010         Tcl_AppendResult(interp, "no such method \"installcomponent\"", NULL);
3011         return TCL_ERROR;
3012     }
3013     hPtr = Tcl_FindHashEntry(&contextIclsPtr->components, (char *)objv[1]);
3014     if (hPtr == NULL) {
3015         numOpts = 0;
3016         FOREACH_HASH_VALUE(idoPtr, &contextIoPtr->objectDelegatedOptions) {
3017             if (idoPtr == NULL) {
3018                 /* FIXME need code here !! */
3019             }
3020             numOpts++;
3021         }
3022         if (numOpts == 0) {
3023             /* there are no delegated options, so no problem that the
3024              * component does not exist. We have nothing to do */
3025             return TCL_OK;
3026         }
3027         Tcl_AppendResult(interp, "class \"",
3028                 Tcl_GetString(contextIclsPtr->namePtr),
3029                 "\" has no component \"",
3030                 Tcl_GetString(objv[1]), "\"", NULL);
3031         return TCL_ERROR;
3032     }
3033     if (contextIclsPtr->flags & ITCL_TYPE) {
3034         Tcl_Obj *objPtr;
3035         usageStr = "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?";
3036         if (objc < 4) {
3037             Tcl_AppendResult(interp, usageStr, NULL);
3038             return TCL_ERROR;
3039         }
3040         if (strcmp(Tcl_GetString(objv[2]), "using") != 0) {
3041             Tcl_AppendResult(interp, usageStr, NULL);
3042             return TCL_ERROR;
3043         }
3044         componentName = Tcl_GetString(objv[1]);
3045         /* as it is no widget, we don't need to check for delegated option */
3046         newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc - 3));
3047         memcpy(newObjv, objv + 3, sizeof(Tcl_Obj *) * ((objc - 3)));
3048         ItclShowArgs(1, "BiInstallComponent", objc - 3, newObjv);
3049         result = Tcl_EvalObjv(interp, objc - 3, newObjv, 0);
3050         ckfree((char *)newObjv);
3051         if (result != TCL_OK) {
3052             return result;
3053         }
3054         componentValue = Tcl_GetString(Tcl_GetObjResult(interp));
3055         objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1);
3056         Tcl_AppendToObj(objPtr,
3057                 (Tcl_GetObjectNamespace(contextIclsPtr->oPtr))->fullName, -1);
3058         Tcl_AppendToObj(objPtr, "::", -1);
3059         Tcl_AppendToObj(objPtr, componentName, -1);
3060
3061         Tcl_SetVar2(interp, Tcl_GetString(objPtr), NULL, componentValue, 0);
3062         Tcl_DecrRefCount(objPtr);
3063
3064     } else {
3065         newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 1));
3066         newObjv[0] = Tcl_NewStringObj("::itcl::builtin::installcomponent", -1);
3067         Tcl_IncrRefCount(newObjv[0]);
3068         memcpy(newObjv, objv + 1, sizeof(Tcl_Obj *) * ((objc - 1)));
3069         result = Tcl_EvalObjv(interp, objc, newObjv, 0);
3070         Tcl_DecrRefCount(newObjv[0]);
3071         ckfree((char *)newObjv);
3072         return result;
3073     }
3074     return TCL_OK;
3075 }
3076 /*
3077  * ------------------------------------------------------------------------
3078  *  Itcl_BiDestroyCmd()
3079  *
3080  *  Invoked whenever the user issues the "destroy" method for an
3081  *  object.
3082  *  Handles the following syntax:
3083  *
3084  *    destroy
3085  *
3086  * ------------------------------------------------------------------------
3087  */
3088 /* ARGSUSED */
3089 static int
3090 Itcl_BiDestroyCmd(
3091     void *dummy,   /* class definition */
3092     Tcl_Interp *interp,      /* current interpreter */
3093     int objc,                /* number of arguments */
3094     Tcl_Obj *const objv[])   /* argument objects */
3095 {
3096     Tcl_Obj **newObjv;
3097     ItclClass *contextIclsPtr;
3098     ItclObject *contextIoPtr;
3099     int result;
3100     (void)dummy;
3101
3102     /*
3103      *  Make sure that this command is being invoked in the proper
3104      *  context.
3105      */
3106     ItclShowArgs(1, "Itcl_BiDestroyCmd", objc, objv);
3107     contextIoPtr = NULL;
3108     contextIclsPtr = NULL;
3109     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3110         return TCL_ERROR;
3111     }
3112
3113     if (contextIclsPtr == NULL) {
3114         Tcl_AppendResult(interp, "cannot find context class for object \"",
3115                 Tcl_GetCommandName(interp, contextIoPtr->accessCmd), "\"",
3116                 NULL);
3117         return TCL_ERROR;
3118     }
3119     if ((objc > 1) || !(contextIclsPtr->flags &
3120             (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) {
3121         /* try to execute destroy in uplevel namespace */
3122         newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + 2));
3123         newObjv[0] = Tcl_NewStringObj("uplevel", -1);
3124         Tcl_IncrRefCount(newObjv[0]);
3125         newObjv[1] = Tcl_NewStringObj("#0", -1);
3126         Tcl_IncrRefCount(newObjv[1]);
3127         newObjv[2] = Tcl_NewStringObj("destroy", -1);
3128         Tcl_IncrRefCount(newObjv[2]);
3129         memcpy(newObjv + 3, objv + 1, sizeof(Tcl_Obj *) * (objc - 1));
3130         ItclShowArgs(1, "DESTROY", objc + 2, newObjv);
3131         result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0);
3132         Tcl_DecrRefCount(newObjv[2]);
3133         Tcl_DecrRefCount(newObjv[1]);
3134         Tcl_DecrRefCount(newObjv[0]);
3135         return result;
3136     }
3137     if (objc != 1) {
3138         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3139             "wrong # args: should be \"", Tcl_GetString(objv[0]), NULL);
3140         return TCL_ERROR;
3141     }
3142
3143     if (contextIoPtr != NULL) {
3144         Tcl_Obj *objPtr = Tcl_NewObj();
3145         Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
3146         Itcl_RenameCommand(interp, Tcl_GetString(objPtr), "");
3147         Tcl_DecrRefCount(objPtr);
3148         result = TCL_OK;
3149     } else {
3150         result = Itcl_DeleteClass(interp, contextIclsPtr);
3151     }
3152     return result;
3153 }
3154 /*
3155  * ------------------------------------------------------------------------
3156  *  Itcl_BiCallInstanceCmd()
3157  *
3158  *  Invoked whenever the a script generated by mytypemethod, mymethod or
3159  *  myproc is evauated later on:
3160  *  Handles the following syntax:
3161  *
3162  *    callinstance <instanceName> ?arg arg ...?
3163  *
3164  * ------------------------------------------------------------------------
3165  */
3166 /* ARGSUSED */
3167 int
3168 Itcl_BiCallInstanceCmd(
3169     void *dummy,   /* class definition */
3170     Tcl_Interp *interp,      /* current interpreter */
3171     int objc,                /* number of arguments */
3172     Tcl_Obj *const objv[])   /* argument objects */
3173 {
3174     Tcl_HashEntry *hPtr;
3175     Tcl_Obj *objPtr;
3176     Tcl_Obj **newObjv;
3177     ItclClass *contextIclsPtr;
3178     ItclObject *contextIoPtr;
3179     ItclObject *ioPtr;
3180     const char *token;
3181     int result;
3182     (void)dummy;
3183
3184     /*
3185      *  Make sure that this command is being invoked in the proper
3186      *  context.
3187      */
3188     ItclShowArgs(1, "Itcl_BiCallInstanceCmd", objc, objv);
3189     contextIclsPtr = NULL;
3190     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3191         return TCL_ERROR;
3192     }
3193
3194     if (objc < 2) {
3195         token = Tcl_GetString(objv[0]);
3196         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3197             "wrong # args: should be \"", token, " <instanceName>",
3198             NULL);
3199         return TCL_ERROR;
3200     }
3201
3202     hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances,
3203             Tcl_GetString(objv[1]));
3204     if (hPtr == NULL) {
3205         Tcl_AppendResult(interp,
3206                 "no such instanceName \"",
3207                 Tcl_GetString(objv[1]), "\"", NULL);
3208         return TCL_ERROR;
3209     }
3210     ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr);
3211     objPtr =Tcl_NewObj();
3212     Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr);
3213     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1));
3214     newObjv[0] = objPtr;
3215     Tcl_IncrRefCount(newObjv[0]);
3216     memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
3217     result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
3218     Tcl_DecrRefCount(newObjv[0]);
3219     ckfree((char *)newObjv);
3220     return result;
3221 }
3222 /*
3223  * ------------------------------------------------------------------------
3224  *  Itcl_BiGetInstanceVarCmd()
3225  *
3226  *  Invoked whenever the a script generated by mytypevar, myvar or
3227  *  mycommon is evauated later on:
3228  *  Handles the following syntax:
3229  *
3230  *    getinstancevar <instanceName> ?arg arg ...?
3231  *
3232  * ------------------------------------------------------------------------
3233  */
3234 /* ARGSUSED */
3235 int
3236 Itcl_BiGetInstanceVarCmd(
3237     void *dummy,   /* class definition */
3238     Tcl_Interp *interp,      /* current interpreter */
3239     int objc,                /* number of arguments */
3240     Tcl_Obj *const objv[])   /* argument objects */
3241 {
3242     Tcl_HashEntry *hPtr;
3243     Tcl_Obj *objPtr;
3244     Tcl_Obj **newObjv;
3245     ItclClass *contextIclsPtr;
3246     ItclObject *contextIoPtr;
3247     ItclObject *ioPtr;
3248     const char *token;
3249     int result;
3250     (void)dummy;
3251
3252     /*
3253      *  Make sure that this command is being invoked in the proper
3254      *  context.
3255      */
3256     ItclShowArgs(1, "Itcl_BiGetInstanceVarCmd", objc, objv);
3257     contextIclsPtr = NULL;
3258     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3259         return TCL_ERROR;
3260     }
3261
3262     if (objc < 2) {
3263         token = Tcl_GetString(objv[0]);
3264         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3265             "wrong # args: should be \"", token, " <instanceName>",
3266             NULL);
3267         return TCL_ERROR;
3268     }
3269
3270     hPtr = Tcl_FindHashEntry(&contextIclsPtr->infoPtr->instances,
3271             Tcl_GetString(objv[1]));
3272     if (hPtr == NULL) {
3273         Tcl_AppendResult(interp,
3274                 "no such instanceName \"",
3275                 Tcl_GetString(objv[1]), "\"", NULL);
3276         return TCL_ERROR;
3277     }
3278     ioPtr = (ItclObject *)Tcl_GetHashValue(hPtr);
3279     objPtr = Tcl_NewObj();
3280     Tcl_GetCommandFullName(interp, ioPtr->accessCmd, objPtr);
3281     newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * (objc - 1));
3282     newObjv[0] = objPtr;
3283     Tcl_IncrRefCount(newObjv[0]);
3284     memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
3285     result = Tcl_EvalObjv(interp, objc - 1, newObjv, 0);
3286     Tcl_DecrRefCount(newObjv[0]);
3287     return result;
3288 }
3289 /*
3290  * ------------------------------------------------------------------------
3291  *  Itcl_BiMyTypeMethodCmd()
3292  *
3293  *  Invoked when a user calls mytypemethod
3294  *
3295  *  Handles the following syntax:
3296  *
3297  *    mytypemethod ?arg arg ...?
3298  *
3299  * ------------------------------------------------------------------------
3300  */
3301 /* ARGSUSED */
3302 int
3303 Itcl_BiMyTypeMethodCmd(
3304     void *dummy,   /* class definition */
3305     Tcl_Interp *interp,      /* current interpreter */
3306     int objc,                /* number of arguments */
3307     Tcl_Obj *const objv[])   /* argument objects */
3308 {
3309     Tcl_Obj *objPtr;
3310     Tcl_Obj *resultPtr;
3311     ItclClass *contextIclsPtr;
3312     ItclObject *contextIoPtr;
3313     int i;
3314     (void)dummy;
3315
3316     /*
3317      *  Make sure that this command is being invoked in the proper
3318      *  context.
3319      */
3320     ItclShowArgs(1, "Itcl_BiMyTypeMethodCmd", objc, objv);
3321     contextIclsPtr = NULL;
3322     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3323         return TCL_ERROR;
3324     }
3325     if (objc < 2) {
3326         Tcl_AppendResult(interp, "usage: mytypemethod <name>", NULL);
3327         return TCL_ERROR;
3328     }
3329     objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
3330     resultPtr = Tcl_NewListObj(0, NULL);
3331     Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
3332
3333     for (i = 1; i < objc; i++) {
3334         Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
3335     }
3336     Tcl_SetObjResult(interp, resultPtr);
3337
3338     return TCL_OK;
3339 }
3340 /*
3341  * ------------------------------------------------------------------------
3342  *  Itcl_BiMyMethodCmd()
3343  *
3344  *  Invoked when a user calls mymethod
3345  *
3346  *  Handles the following syntax:
3347  *
3348  *    mymethod ?arg arg ...?
3349  *
3350  * ------------------------------------------------------------------------
3351  */
3352 /* ARGSUSED */
3353 int
3354 Itcl_BiMyMethodCmd(
3355     void *dummy,   /* class definition */
3356     Tcl_Interp *interp,      /* current interpreter */
3357     int objc,                /* number of arguments */
3358     Tcl_Obj *const objv[])   /* argument objects */
3359 {
3360     Tcl_Obj *resultPtr;
3361     int i;
3362     ItclClass *contextIclsPtr;
3363     ItclObject *contextIoPtr;
3364     (void)dummy;
3365
3366     /*
3367      *  Make sure that this command is being invoked in the proper
3368      *  context.
3369      */
3370     ItclShowArgs(1, "Itcl_BiMyMethodCmd", objc, objv);
3371     contextIclsPtr = NULL;
3372     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3373         return TCL_ERROR;
3374     }
3375     if (contextIoPtr != NULL) {
3376         resultPtr = Tcl_NewListObj(0, NULL);
3377         Tcl_ListObjAppendElement(interp, resultPtr,
3378                 Tcl_NewStringObj("::itcl::builtin::callinstance", -1));
3379         Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(
3380                 (Tcl_GetObjectNamespace(contextIoPtr->oPtr))->fullName, -1));
3381         for (i = 1; i < objc; i++) {
3382             Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
3383         }
3384         Tcl_SetObjResult(interp, resultPtr);
3385         return TCL_OK;
3386     }
3387
3388     return TCL_OK;
3389 }
3390 /*
3391  * ------------------------------------------------------------------------
3392  *  Itcl_BiMyProcCmd()
3393  *
3394  *  Invoked when a user calls myproc
3395  *
3396  *  Handles the following syntax:
3397  *
3398  *    myproc ?arg arg ...?
3399  *
3400  * ------------------------------------------------------------------------
3401  */
3402 /* ARGSUSED */
3403 int
3404 Itcl_BiMyProcCmd(
3405     void *dummy,   /* class definition */
3406     Tcl_Interp *interp,      /* current interpreter */
3407     int objc,                /* number of arguments */
3408     Tcl_Obj *const objv[])   /* argument objects */
3409 {
3410     Tcl_Obj *objPtr;
3411     Tcl_Obj *resultPtr;
3412     ItclClass *contextIclsPtr;
3413     ItclObject *contextIoPtr;
3414     int i;
3415     (void)dummy;
3416
3417     /*
3418      *  Make sure that this command is being invoked in the proper
3419      *  context.
3420      */
3421     ItclShowArgs(1, "Itcl_BiMyProcCmd", objc, objv);
3422     contextIclsPtr = NULL;
3423     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3424         return TCL_ERROR;
3425     }
3426     if (objc < 2) {
3427         Tcl_AppendResult(interp, "usage: myproc <name>", NULL);
3428         return TCL_ERROR;
3429     }
3430     objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
3431     Tcl_AppendToObj(objPtr, "::", -1);
3432     Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1);
3433     resultPtr = Tcl_NewListObj(0, NULL);
3434     Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
3435
3436     for (i = 2; i < objc; i++) {
3437         Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
3438     }
3439     Tcl_SetObjResult(interp, resultPtr);
3440     return TCL_OK;
3441 }
3442 /*
3443  * ------------------------------------------------------------------------
3444  *  Itcl_BiMyTypeVarCmd()
3445  *
3446  *  Invoked when a user calls mytypevar
3447  *
3448  *  Handles the following syntax:
3449  *
3450  *    mytypevar ?arg arg ...?
3451  *
3452  * ------------------------------------------------------------------------
3453  */
3454 /* ARGSUSED */
3455 int
3456 Itcl_BiMyTypeVarCmd(
3457     void *dummy,   /* class definition */
3458     Tcl_Interp *interp,      /* current interpreter */
3459     int objc,                /* number of arguments */
3460     Tcl_Obj *const objv[])   /* argument objects */
3461 {
3462     Tcl_Obj *objPtr;
3463     Tcl_Obj *resultPtr;
3464     ItclClass *contextIclsPtr;
3465     ItclObject *contextIoPtr;
3466     int i;
3467     (void)dummy;
3468
3469     /*
3470      *  Make sure that this command is being invoked in the proper
3471      *  context.
3472      */
3473     ItclShowArgs(1, "Itcl_BiMyTypeVarCmd", objc, objv);
3474     contextIclsPtr = NULL;
3475     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3476         return TCL_ERROR;
3477     }
3478     if (objc < 2) {
3479         Tcl_AppendResult(interp, "usage: mytypevar <name>", NULL);
3480         return TCL_ERROR;
3481     }
3482     objPtr = Tcl_NewStringObj(contextIclsPtr->nsPtr->fullName, -1);
3483     Tcl_AppendToObj(objPtr, "::", -1);
3484     Tcl_AppendToObj(objPtr, Tcl_GetString(objv[1]), -1);
3485     resultPtr = Tcl_NewListObj(0, NULL);
3486     Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
3487
3488     for (i = 2; i < objc; i++) {
3489         Tcl_ListObjAppendElement(interp, resultPtr, objv[i]);
3490     }
3491     Tcl_SetObjResult(interp, resultPtr);
3492
3493     return TCL_OK;
3494 }
3495 /*
3496  * ------------------------------------------------------------------------
3497  *  Itcl_BiMyVarCmd()
3498  *
3499  *  Invoked when a user calls myvar
3500  *
3501  *  Handles the following syntax:
3502  *
3503  *    myvar ?arg arg ...?
3504  *
3505  * ------------------------------------------------------------------------
3506  */
3507 /* ARGSUSED */
3508 int
3509 Itcl_BiMyVarCmd(
3510     void *dummy,   /* class definition */
3511     Tcl_Interp *interp,      /* current interpreter */
3512     int objc,                /* number of arguments */
3513     Tcl_Obj *const objv[])   /* argument objects */
3514 {
3515     Tcl_Obj *resultPtr;
3516     ItclClass *contextIclsPtr;
3517     ItclObject *contextIoPtr;
3518     (void)dummy;
3519
3520     /*
3521      *  Make sure that this command is being invoked in the proper
3522      *  context.
3523      */
3524     ItclShowArgs(1, "Itcl_BiMyVarCmd", objc, objv);
3525     contextIclsPtr = NULL;
3526     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3527         return TCL_ERROR;
3528     }
3529     if ((contextIoPtr != NULL) && (objc > 1)) {
3530         resultPtr = Tcl_NewStringObj(Tcl_GetString(contextIoPtr->varNsNamePtr),
3531                 -1);
3532         Tcl_AppendToObj(resultPtr, "::", -1);
3533         Tcl_AppendToObj(resultPtr, Tcl_GetString(contextIclsPtr->namePtr), -1);
3534         Tcl_AppendToObj(resultPtr, "::", -1);
3535         Tcl_AppendToObj(resultPtr, Tcl_GetString(objv[1]), -1);
3536         Tcl_SetObjResult(interp, resultPtr);
3537     }
3538     return TCL_OK;
3539 }
3540 /*
3541  * ------------------------------------------------------------------------
3542  *  Itcl_BiItclHullCmd()
3543  *
3544  *  Invoked when a user calls itcl_hull
3545  *
3546  *  Handles the following syntax:
3547  *
3548  *    itcl_hull ?arg arg ...?
3549  *
3550  * ------------------------------------------------------------------------
3551  */
3552 /* ARGSUSED */
3553 int
3554 Itcl_BiItclHullCmd(
3555     void *dummy,   /* class definition */
3556     Tcl_Interp *interp,      /* current interpreter */
3557     int objc,                /* number of arguments */
3558     Tcl_Obj *const objv[])   /* argument objects */
3559 {
3560     ItclClass *contextIclsPtr;
3561     ItclObject *contextIoPtr;
3562     const char *val;
3563     (void)dummy;
3564     (void)objc;
3565     (void)objv;
3566
3567     /*
3568      *  Make sure that this command is being invoked in the proper
3569      *  context.
3570      */
3571     ItclShowArgs(1, "Itcl_BiItclHullCmd", objc, objv);
3572     contextIclsPtr = NULL;
3573     if (Itcl_GetContext(interp, &contextIclsPtr, &contextIoPtr) != TCL_OK) {
3574         return TCL_ERROR;
3575     }
3576     if (contextIoPtr != NULL) {
3577         val = ItclGetInstanceVar(interp, "itcl_hull", NULL,
3578                 contextIoPtr, contextIclsPtr);
3579         Tcl_SetObjResult(interp, Tcl_NewStringObj(val, -1));
3580     }
3581     return TCL_OK;
3582 }
3583 \f
3584 /*
3585  * ------------------------------------------------------------------------
3586  *  Itcl_BiCreateHullCmd()
3587  *
3588  *  Invoked by Tcl normally during evaluating constructor
3589  *  the "createhull" command is invoked to install and setup an
3590  *  ::itcl::extendedclass itcl_hull
3591  *  for an object.  Handles the following syntax:
3592  *
3593  *      createhull <widget_type> <widget_path> ?-class <widgetClassName>?
3594  *          ?<optionName> <optionValue> <optionName> <optionValue> ...?
3595  *
3596  * ------------------------------------------------------------------------
3597  */
3598 static int
3599 Itcl_BiCreateHullCmd(
3600     void *clientData,   /* info for all known objects */
3601     Tcl_Interp *interp,      /* current interpreter */
3602     int objc,                /* number of arguments */
3603     Tcl_Obj *const objv[])   /* argument objects */
3604 {
3605     int result;
3606     ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
3607
3608     ItclShowArgs(1, "Itcl_BiCreateHullCmd", objc, objv);
3609     if (!infoPtr->itclHullCmdsInitted) {
3610         result =  Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
3611         if (result != TCL_OK) {
3612             return result;
3613         }
3614         infoPtr->itclHullCmdsInitted = 1;
3615     }
3616     return Tcl_EvalObjv(interp, objc, objv, 0);
3617 }
3618 \f
3619 /*
3620  * ------------------------------------------------------------------------
3621  *  Itcl_BiSetupComponentCmd()
3622  *
3623  *  Invoked by Tcl during evaluating constructor whenever
3624  *  the "setupcomponent" command is invoked to install and setup an
3625  *  ::itcl::extendedclass component
3626  *  for an object.  Handles the following syntax:
3627  *
3628  *      setupcomponent <componentName> using <widgetType> <widget_path>
3629  *          ?<optionName> <optionValue> <optionName> <optionValue> ...?
3630  *
3631  * ------------------------------------------------------------------------
3632  */
3633 static int
3634 Itcl_BiSetupComponentCmd(
3635     void *clientData,   /* info for all known objects */
3636     Tcl_Interp *interp,      /* current interpreter */
3637     int objc,                /* number of arguments */
3638     Tcl_Obj *const objv[])   /* argument objects */
3639 {
3640     int result;
3641     ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
3642
3643     ItclShowArgs(1, "Itcl_BiSetupComponentCmd", objc, objv);
3644     if (!infoPtr->itclHullCmdsInitted) {
3645         result =  Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
3646         if (result != TCL_OK) {
3647             return result;
3648         }
3649         infoPtr->itclHullCmdsInitted = 1;
3650     }
3651     return Tcl_EvalObjv(interp, objc, objv, 0);
3652 }
3653 \f
3654 /*
3655  * ------------------------------------------------------------------------
3656  *  Itcl_BiInitOptionsCmd()
3657  *
3658  *  Invoked by Tcl during evaluating constructor whenever
3659  *  the "itcl_initoptions" command is invoked to install and setup an
3660  *  ::itcl::extendedclass options
3661  *  for an object.  Handles the following syntax:
3662  *
3663  *      itcl_initoptions
3664  *          ?<optionName> <optionValue> <optionName> <optionValue> ...?
3665  * FIXME !!!! seems no longer been used !!!
3666  *
3667  * ------------------------------------------------------------------------
3668  */
3669 static int
3670 Itcl_BiInitOptionsCmd(
3671     void *clientData,   /* info for all known objects */
3672     Tcl_Interp *interp,      /* current interpreter */
3673     int objc,                /* number of arguments */
3674     Tcl_Obj *const objv[])   /* argument objects */
3675 {
3676     int result;
3677     ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
3678     ItclClass *iclsPtr;
3679     ItclObject *ioPtr;
3680     ItclDelegatedOption *idoptPtr;
3681     ItclOption *ioptPtr;
3682     FOREACH_HASH_DECLS;
3683
3684     /* instead ::itcl::builtin::initoptions in ../library/itclHullCmds.tcl is used !! */
3685     ItclShowArgs(1, "Itcl_BiInitOptionsCmd", objc, objv);
3686     if (!infoPtr->itclHullCmdsInitted) {
3687         result =  Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
3688         if (result != TCL_OK) {
3689             return result;
3690         }
3691         infoPtr->itclHullCmdsInitted = 1;
3692     }
3693     result = Tcl_EvalObjv(interp, objc, objv, 0);
3694     iclsPtr = NULL;
3695     if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
3696         return TCL_ERROR;
3697     }
3698     /* first handle delegated options */
3699     FOREACH_HASH_VALUE(idoptPtr, &ioPtr->objectDelegatedOptions) {
3700 fprintf(stderr, "delopt!%s!\n", Tcl_GetString(idoptPtr->namePtr));
3701     }
3702     FOREACH_HASH_VALUE(ioptPtr, &ioPtr->objectOptions) {
3703 fprintf(stderr, "opt!%s!\n", Tcl_GetString(ioptPtr->namePtr));
3704     }
3705     return result;
3706 }
3707 \f
3708 /*
3709  * ------------------------------------------------------------------------
3710  *  Itcl_BiKeepComponentOptionCmd()
3711  *
3712  *  Invoked by Tcl during evaluating constructor whenever
3713  *  the "keepcomponentoption" command is invoked to list the options
3714  *  to be kept when and ::itcl::extendedclass component has been setup
3715  *  for an object.  Handles the following syntax:
3716  *
3717  *      keepcomponentoption <componentName> <optionName> ?<optionName> ...?
3718  *
3719  * ------------------------------------------------------------------------
3720  */
3721 static int
3722 Itcl_BiKeepComponentOptionCmd(
3723     void *clientData,   /* info for all known objects */
3724     Tcl_Interp *interp,      /* current interpreter */
3725     int objc,                /* number of arguments */
3726     Tcl_Obj *const objv[])   /* argument objects */
3727 {
3728     int result;
3729     ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
3730
3731     ItclShowArgs(1, "Itcl_BiKeepComponentOptionCmd", objc, objv);
3732     if (!infoPtr->itclHullCmdsInitted) {
3733         result =  Tcl_EvalEx(interp, initHullCmdsScript, -1, 0);
3734         if (result != TCL_OK) {
3735             return result;
3736         }
3737         infoPtr->itclHullCmdsInitted = 1;
3738     }
3739     result =  Tcl_EvalObjv(interp, objc, objv, 0);
3740     return result;
3741 }
3742 \f
3743 /*
3744  * ------------------------------------------------------------------------
3745  *  Itcl_BiIgnoreComponentOptionCmd()
3746  *
3747  *  Invoked by Tcl during evaluating constructor whenever
3748  *  the "keepcomponentoption" command is invoked to list the options
3749  *  to be kept when and ::itcl::extendedclass component has been setup
3750  *  for an object.  Handles the following syntax:
3751  *
3752  *      ignorecomponentoption <componentName> <optionName> ?<optionName> ...?
3753  *
3754  * ------------------------------------------------------------------------
3755  */
3756 static int
3757 Itcl_BiIgnoreComponentOptionCmd(
3758     void *clientData,   /* info for all known objects */
3759     Tcl_Interp *interp,      /* current interpreter */
3760     int objc,                /* number of arguments */
3761     Tcl_Obj *const objv[])   /* argument objects */
3762 {
3763     Tcl_HashEntry *hPtr;
3764     Tcl_HashEntry *hPtr2;
3765     Tcl_Obj *objPtr;
3766     ItclClass *iclsPtr;
3767     ItclObject *ioPtr;
3768     ItclDelegatedOption *idoPtr;
3769     ItclComponent *icPtr;
3770     const char *val;
3771     int idx;
3772     int isNew;
3773     int result;
3774     ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData;
3775
3776     ItclShowArgs(0, "Itcl_BiIgnoreComponentOptionCmd", objc, objv);
3777     if (!infoPtr->itclHullCmdsInitted) {
3778         result =  Tcl_Eval(interp, initHullCmdsScript);
3779         if (result != TCL_OK) {
3780             return result;
3781         }
3782         infoPtr->itclHullCmdsInitted = 1;
3783     }
3784     iclsPtr = NULL;
3785     if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
3786         return TCL_ERROR;
3787     }
3788     if (objc < 3) {
3789         Tcl_AppendResult(interp, "wrong # args, should be: ",
3790                 "ignorecomponentoption component option ?option ...?", NULL);
3791         return TCL_ERROR;
3792     }
3793     if (ioPtr != NULL) {
3794         hPtr = Tcl_FindHashEntry(&ioPtr->objectComponents, (char *)objv[1]);
3795         if (hPtr == NULL) {
3796             Tcl_AppendResult(interp,
3797                     "ignorecomponentoption cannot find component \"",
3798                     Tcl_GetString(objv[1]), "\"", NULL);
3799             return TCL_ERROR;
3800         }
3801         icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr);
3802         icPtr->haveKeptOptions = 1;
3803         for (idx = 2; idx < objc; idx++) {
3804             hPtr = Tcl_CreateHashEntry(&icPtr->keptOptions, (char *)objv[idx],
3805                     &isNew);
3806             if (isNew) {
3807                 Tcl_SetHashValue(hPtr, objv[idx]);
3808             }
3809             hPtr2 = Tcl_CreateHashEntry(&ioPtr->objectDelegatedOptions,
3810                     (char *)objv[idx], &isNew);
3811             if (isNew) {
3812                 idoPtr = (ItclDelegatedOption *)ckalloc(sizeof(
3813                         ItclDelegatedOption));
3814                 memset(idoPtr, 0, sizeof(ItclDelegatedOption));
3815                 Tcl_InitObjHashTable(&idoPtr->exceptions);
3816                 idoPtr->namePtr = objv[idx];
3817                 Tcl_IncrRefCount(idoPtr->namePtr);
3818                 idoPtr->resourceNamePtr = NULL;
3819                 if (idoPtr->resourceNamePtr != NULL) {
3820                     Tcl_IncrRefCount(idoPtr->resourceNamePtr);
3821                 }
3822                 idoPtr->classNamePtr = NULL;
3823                 if (idoPtr->classNamePtr != NULL) {
3824                     Tcl_IncrRefCount(idoPtr->classNamePtr);
3825                 }
3826                 idoPtr->icPtr = icPtr;
3827                 idoPtr->ioptPtr = NULL;
3828                 Tcl_SetHashValue(hPtr2, idoPtr);
3829                 val = ItclGetInstanceVar(interp, Tcl_GetString(icPtr->namePtr),
3830                         NULL, ioPtr, iclsPtr);
3831                 if (val != NULL) {
3832                     objPtr = Tcl_NewStringObj(val, -1);
3833                     Tcl_AppendToObj(objPtr, " cget ", -1);
3834                     Tcl_AppendToObj(objPtr, Tcl_GetString(objv[idx]), -1);
3835                     Tcl_IncrRefCount(objPtr);
3836                     result = Tcl_EvalObjEx(interp, objPtr, 0);
3837                     Tcl_DecrRefCount(objPtr);
3838                     if (result == TCL_OK) {
3839                         ItclSetInstanceVar(interp, "itcl_options",
3840                                 Tcl_GetString(objv[idx]),
3841                                 Tcl_GetString(Tcl_GetObjResult(interp)), ioPtr, iclsPtr);
3842                     }
3843                 }
3844             }
3845         }
3846         ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr);
3847     }
3848     return TCL_OK;
3849 }