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

   1 /*
   2  * itclBase.c --
   3  *
   4  * This file contains the C-implemented startup part of an
   5  * Itcl implemenatation
   6  *
   7  * Copyright (c) 2007 by Arnulf P. Wiedemann
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #include <stdlib.h>
  14 #include "itclInt.h"
  15
  16 static Tcl_NamespaceDeleteProc FreeItclObjectInfo;
  17 static Tcl_ObjCmdProc ItclSetHullWindowName;
  18 static Tcl_ObjCmdProc ItclCheckSetItclHull;
  19
  20 MODULE_SCOPE const ItclStubs itclStubs;
  21
  22 static int Initialize(Tcl_Interp *interp);
  23
  24 static const char initScript[] =
  25 "namespace eval ::itcl {\n"
  26 "    proc _find_init {} {\n"
  27 "        global env tcl_library\n"
  28 "        variable library\n"
  29 "        variable patchLevel\n"
  30 "        rename _find_init {}\n"
  31 "        if {[info exists library]} {\n"
  32 "            lappend dirs $library\n"
  33 "        } else {\n"
  34 "            set dirs {}\n"
  35 "            if {[info exists env(ITCL_LIBRARY)]} {\n"
  36 "                lappend dirs $env(ITCL_LIBRARY)\n"
  37 "            }\n"
  38 "            lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n"
  39 "            set bindir [file dirname [info nameofexecutable]]\n"
  40 "            lappend dirs [file join . library]\n"
  41 "            lappend dirs [file join $bindir .. lib itcl$patchLevel]\n"
  42 "            lappend dirs [file join $bindir .. library]\n"
  43 "            lappend dirs [file join $bindir .. .. library]\n"
  44 "            lappend dirs [file join $bindir .. .. itcl library]\n"
  45 "            lappend dirs [file join $bindir .. .. .. itcl library]\n"
  46 "            lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n"
  47 "            # On *nix, check the directories in the tcl_pkgPath\n"
  48 "            # XXX JH - this looks unnecessary, maybe Darwin only?\n"
  49 "            if {[string equal $::tcl_platform(platform) \"unix\"]} {\n"
  50 "                foreach d $::tcl_pkgPath {\n"
  51 "                    lappend dirs $d\n"
  52 "                    lappend dirs [file join $d itcl$patchLevel]\n"
  53 "                }\n"
  54 "            }\n"
  55 "        }\n"
  56 "        foreach i $dirs {\n"
  57 "            set library $i\n"
  58 "            if {![catch {uplevel #0 [list source [file join $i itcl.tcl]]}]} {\n"
  59 "                set library $i\n"
  60 "                return\n"
  61 "            }\n"
  62 "        }\n"
  63 "        set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n"
  64 "        append msg \"    $dirs\n\"\n"
  65 "        append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n"
  66 "        append msg \"If you know where the Itcl library directory was installed,\n\"\n"
  67 "        append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n"
  68 "        append msg \"to the library directory.\n\"\n"
  69 "        error $msg\n"
  70 "    }\n"
  71 "    _find_init\n"
  72 "}";
  73 \f
  74 /*
  75  * The following script is used to initialize Itcl in a safe interpreter.
  76  */
  77
  78 static const char safeInitScript[] =
  79 "proc ::itcl::local {class name args} {\n"
  80 "    set ptr [uplevel [list $class $name] $args]\n"
  81 "    uplevel [list set itcl-local-$ptr $ptr]\n"
  82 "    set cmd [uplevel namespace which -command $ptr]\n"
  83 "    uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n"
  84 "    return $ptr\n"
  85 "}";
  86
  87 static const char *clazzClassScript =
  88 "::oo::class create ::itcl::clazz {\n"
  89 "  superclass ::oo::class\n"
  90 "  method unknown args {\n"
  91 "    ::tailcall ::itcl::parser::handleClass [::lindex [::info level 0] 0] [self] {*}$args\n"
  92 "  }\n"
  93 "  unexport create new unknown\n"
  94 "}";
  95
  96 #define ITCL_IS_ENSEMBLE 0x1
  97
  98 #ifdef ITCL_DEBUG_C_INTERFACE
  99 extern void RegisterDebugCFunctions( Tcl_Interp * interp);
 100 #endif
 101
 102 static Tcl_ObjectMetadataDeleteProc Demolition;
 103
 104 static const Tcl_ObjectMetadataType canary = {
 105     TCL_OO_METADATA_VERSION_CURRENT,
 106     "Itcl Foundations",
 107     Demolition,
 108     NULL
 109 };
 110
 111 void
 112 Demolition(
 113     void *clientData)
 114 {
 115     ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
 116
 117     infoPtr->clazzObjectPtr = NULL;
 118     infoPtr->clazzClassPtr = NULL;
 119 }
 120
 121 static const Tcl_ObjectMetadataType objMDT = {
 122     TCL_OO_METADATA_VERSION_CURRENT,
 123     "ItclObject",
 124     ItclDeleteObjectMetadata,   /* Not really used yet */
 125     NULL
 126 };
 127
 128 static Tcl_MethodCallProc RootCallProc;
 129
 130 const Tcl_MethodType itclRootMethodType = {
 131     TCL_OO_METHOD_VERSION_CURRENT,
 132     "itcl root method",
 133     RootCallProc,
 134     NULL,
 135     NULL
 136 };
 137
 138 static int
 139 RootCallProc(
 140     void *clientData,
 141     Tcl_Interp *interp,
 142     Tcl_ObjectContext context,
 143     int objc,
 144     Tcl_Obj *const *objv)
 145 {
 146     Tcl_Object oPtr = Tcl_ObjectContextObject(context);
 147     ItclObject *ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, &objMDT);
 148     ItclRootMethodProc *proc = (ItclRootMethodProc *)clientData;
 149
 150     return (*proc)(ioPtr, interp, objc, objv);
 151 }
 152 \f
 153 /*
 154  * ------------------------------------------------------------------------
 155  *  Initialize()
 156  *
 157  *      that is the starting point when loading the library
 158  *      it initializes all internal stuff
 159  *
 160  * ------------------------------------------------------------------------
 161  */
 162
 163 static int
 164 Initialize (
 165     Tcl_Interp *interp)
 166 {
 167     Tcl_Namespace *nsPtr;
 168     Tcl_Namespace *itclNs;
 169     Tcl_HashEntry *hPtr;
 170     ItclObjectInfo *infoPtr;
 171     const char * ret;
 172     char *res_option;
 173     int opt;
 174     int isNew;
 175     Tcl_Class tclCls;
 176     Tcl_Object clazzObjectPtr, root;
 177     Tcl_Obj *objPtr, *resPtr;
 178
 179     if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
 180         return TCL_ERROR;
 181     }
 182
 183     ret = TclOOInitializeStubs(interp, "1.0");
 184     if (ret == NULL) {
 185         return TCL_ERROR;
 186     }
 187
 188     objPtr = Tcl_NewStringObj("::oo::class", -1);
 189     Tcl_IncrRefCount(objPtr);
 190     clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
 191     if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
 192         Tcl_DecrRefCount(objPtr);
 193         return TCL_ERROR;
 194     }
 195     Tcl_DecrRefCount(objPtr);
 196
 197     infoPtr = (ItclObjectInfo*)Itcl_Alloc(sizeof(ItclObjectInfo));
 198
 199     nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
 200     if (nsPtr == NULL) {
 201         Itcl_Free(infoPtr);
 202         Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
 203     }
 204
 205     nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE,
 206             NULL, NULL);
 207     if (nsPtr == NULL) {
 208         Itcl_Free(infoPtr);
 209         Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
 210                 ITCL_NAMESPACE);
 211     }
 212
 213     /*
 214      *  Create the top-level data structure for tracking objects.
 215      *  Store this as "associated data" for easy access, but link
 216      *  it to the itcl namespace for ownership.
 217      */
 218     infoPtr->interp = interp;
 219     infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
 220             sizeof(Tcl_ObjectMetadataType));
 221     infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
 222     infoPtr->class_meta_type->name = "ItclClass";
 223     infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata;
 224     infoPtr->class_meta_type->cloneProc = NULL;
 225
 226     infoPtr->object_meta_type = &objMDT;
 227
 228     Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS);
 229     Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS);
 230     Tcl_InitHashTable(&infoPtr->classes, TCL_ONE_WORD_KEYS);
 231     Tcl_InitObjHashTable(&infoPtr->nameClasses);
 232     Tcl_InitHashTable(&infoPtr->namespaceClasses, TCL_ONE_WORD_KEYS);
 233     Tcl_InitHashTable(&infoPtr->procMethods, TCL_ONE_WORD_KEYS);
 234     Tcl_InitHashTable(&infoPtr->instances, TCL_STRING_KEYS);
 235     Tcl_InitHashTable(&infoPtr->frameContext, TCL_ONE_WORD_KEYS);
 236     Tcl_InitObjHashTable(&infoPtr->classTypes);
 237
 238     infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo));
 239     memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo));
 240     Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS);
 241     Tcl_InitHashTable(&infoPtr->ensembleInfo->subEnsembles, TCL_ONE_WORD_KEYS);
 242     infoPtr->ensembleInfo->numEnsembles = 0;
 243     infoPtr->protection = ITCL_DEFAULT_PROTECT;
 244     infoPtr->currClassFlags = 0;
 245     infoPtr->buildingWidget = 0;
 246     infoPtr->typeDestructorArgumentPtr = Tcl_NewStringObj("", -1);
 247     Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr);
 248     infoPtr->lastIoPtr = NULL;
 249
 250     Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classes", NULL, "", 0);
 251     Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::objects", NULL, "", 0);
 252     Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", NULL, "", 0);
 253     Tcl_SetVar2(interp,
 254             ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", NULL, "", 0);
 255     Tcl_SetVar2(interp,
 256             ITCL_NAMESPACE"::internal::dicts::classComponents", NULL, "", 0);
 257     Tcl_SetVar2(interp,
 258             ITCL_NAMESPACE"::internal::dicts::classVariables", NULL, "", 0);
 259     Tcl_SetVar2(interp,
 260             ITCL_NAMESPACE"::internal::dicts::classFunctions", NULL, "", 0);
 261     Tcl_SetVar2(interp,
 262             ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", NULL, "", 0);
 263
 264     hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
 265             (char *)Tcl_NewStringObj("class", -1), &isNew);
 266     Tcl_SetHashValue(hPtr, ITCL_CLASS);
 267     hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
 268             (char *)Tcl_NewStringObj("type", -1), &isNew);
 269     Tcl_SetHashValue(hPtr, ITCL_TYPE);
 270     hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
 271             (char *)Tcl_NewStringObj("widget", -1), &isNew);
 272     Tcl_SetHashValue(hPtr, ITCL_WIDGET);
 273     hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
 274             (char *)Tcl_NewStringObj("widgetadaptor", -1), &isNew);
 275     Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR);
 276     hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
 277             (char *)Tcl_NewStringObj("extendedclass", -1), &isNew);
 278     Tcl_SetHashValue(hPtr, ITCL_ECLASS);
 279
 280     res_option = getenv("ITCL_USE_OLD_RESOLVERS");
 281     if (res_option == NULL) {
 282         opt = 1;
 283     } else {
 284         opt = atoi(res_option);
 285     }
 286     infoPtr->useOldResolvers = opt;
 287     Itcl_InitStack(&infoPtr->clsStack);
 288
 289     Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, infoPtr);
 290
 291     Itcl_PreserveData(infoPtr);
 292
 293     root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root",
 294             NULL, 0, NULL, 0);
 295
 296     Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
 297             Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
 298             (void *)ItclUnknownGuts);
 299     Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
 300             Tcl_NewStringObj("ItclConstructBase", -1), 0,
 301             &itclRootMethodType, (void *)ItclConstructGuts);
 302     Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
 303             Tcl_NewStringObj("info", -1), 1,
 304             &itclRootMethodType, (void *)ItclInfoGuts);
 305
 306     /* first create the Itcl base class as root of itcl classes */
 307     if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) {
 308         Tcl_Panic("cannot create Itcl root class ::itcl::clazz");
 309     }
 310     resPtr = Tcl_GetObjResult(interp);
 311     /*
 312      * Tcl_GetObjectFromObject can call Tcl_SetObjResult, so increment the
 313      * refcount first.
 314      */
 315     Tcl_IncrRefCount(resPtr);
 316     clazzObjectPtr = Tcl_GetObjectFromObj(interp, resPtr);
 317     Tcl_DecrRefCount(resPtr);
 318
 319     if (clazzObjectPtr == NULL) {
 320         Tcl_AppendResult(interp,
 321                 "ITCL: cannot get Object for ::itcl::clazz for class \"",
 322                 "::itcl::clazz", "\"", NULL);
 323         return TCL_ERROR;
 324     }
 325
 326     Tcl_ObjectSetMetadata(clazzObjectPtr, &canary, infoPtr);
 327
 328     infoPtr->clazzObjectPtr = clazzObjectPtr;
 329     infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);
 330
 331     /*
 332      *  Initialize the ensemble package first, since we need this
 333      *  for other parts of [incr Tcl].
 334      */
 335
 336     if (Itcl_EnsembleInit(interp) != TCL_OK) {
 337         return TCL_ERROR;
 338     }
 339
 340     Itcl_ParseInit(interp, infoPtr);
 341
 342     /*
 343      *  Create "itcl::builtin" namespace for commands that
 344      *  are automatically built into class definitions.
 345      */
 346     if (Itcl_BiInit(interp, infoPtr) != TCL_OK) {
 347         return TCL_ERROR;
 348     }
 349
 350     /*
 351      *  Export all commands in the "itcl" namespace so that they
 352      *  can be imported with something like "namespace import itcl::*"
 353      */
 354     itclNs = Tcl_FindNamespace(interp, "::itcl", NULL,
 355         TCL_LEAVE_ERR_MSG);
 356
 357     /*
 358      *  This was changed from a glob export (itcl::*) to explicit
 359      *  command exports, so that the itcl::is command can *not* be
 360      *  exported. This is done for concern that the itcl::is command
 361      *  imported might be confusing ("is").
 362      */
 363     if (!itclNs ||
 364             (Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) ||
 365             (Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) ||
 366             (Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) ||
 367             (Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) ||
 368             (Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) ||
 369             (Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) ||
 370             (Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) ||
 371             (Tcl_Export(interp, itclNs, "filter", 0) != TCL_OK) ||
 372             (Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) ||
 373             (Tcl_Export(interp, itclNs, "forward", 0) != TCL_OK) ||
 374             (Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) ||
 375             (Tcl_Export(interp, itclNs, "mixin", 0) != TCL_OK) ||
 376             (Tcl_Export(interp, itclNs, "scope", 0) != TCL_OK)) {
 377         return TCL_ERROR;
 378     }
 379
 380     Tcl_CreateObjCommand(interp,
 381             ITCL_NAMESPACE"::internal::commands::sethullwindowname",
 382             ItclSetHullWindowName, infoPtr, NULL);
 383     Tcl_CreateObjCommand(interp,
 384             ITCL_NAMESPACE"::internal::commands::checksetitclhull",
 385             ItclCheckSetItclHull, infoPtr, NULL);
 386
 387     /*
 388      *  Set up the variables containing version info.
 389      */
 390
 391     Tcl_SetVar2(interp, "::itcl::version", NULL, ITCL_VERSION, TCL_NAMESPACE_ONLY);
 392     Tcl_SetVar2(interp, "::itcl::patchLevel", NULL, ITCL_PATCH_LEVEL,
 393             TCL_NAMESPACE_ONLY);
 394
 395
 396 #ifdef ITCL_DEBUG_C_INTERFACE
 397     RegisterDebugCFunctions(interp);
 398 #endif
 399     /*
 400      *  Package is now loaded.
 401      */
 402
 403     Tcl_PkgProvideEx(interp, "Itcl", ITCL_PATCH_LEVEL, &itclStubs);
 404     return Tcl_PkgProvideEx(interp, "itcl", ITCL_PATCH_LEVEL, &itclStubs);
 405 }
 406
 407 /*
 408  * ------------------------------------------------------------------------
 409  *  Itcl_Init()
 410  *
 411  *  Invoked whenever a new INTERPRETER is created to install the
 412  *  [incr Tcl] package.  Usually invoked within Tcl_AppInit() at
 413  *  the start of execution.
 414  *
 415  *  Creates the "::itcl" namespace and installs access commands for
 416  *  creating classes and querying info.
 417  *
 418  *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 419  *  message in the interpreter) if anything goes wrong.
 420  * ------------------------------------------------------------------------
 421  */
 422
 423 int
 424 Itcl_Init (
 425     Tcl_Interp *interp)
 426 {
 427     if (Initialize(interp) != TCL_OK) {
 428         return TCL_ERROR;
 429     }
 430
 431     return  Tcl_EvalEx(interp, initScript, -1, 0);
 432 }
 433
 434 /*
 435  * ------------------------------------------------------------------------
 436  *  Itcl_SafeInit()
 437  *
 438  *  Invoked whenever a new SAFE INTERPRETER is created to install
 439  *  the [incr Tcl] package.
 440  *
 441  *  Creates the "::itcl" namespace and installs access commands for
 442  *  creating classes and querying info.
 443  *
 444  *  Returns TCL_OK on success, or TCL_ERROR (along with an error
 445  *  message in the interpreter) if anything goes wrong.
 446  * ------------------------------------------------------------------------
 447  */
 448
 449 int
 450 Itcl_SafeInit (
 451     Tcl_Interp *interp)
 452 {
 453     if (Initialize(interp) != TCL_OK) {
 454         return TCL_ERROR;
 455     }
 456     return Tcl_EvalEx(interp, safeInitScript, -1, 0);
 457 }
 458 \f
 459 /*
 460  * ------------------------------------------------------------------------
 461  *  ItclSetHullWindowName()
 462  *
 463  *
 464  * ------------------------------------------------------------------------
 465  */
 466 static int
 467 ItclSetHullWindowName(
 468     void *clientData,   /* infoPtr */
 469     Tcl_Interp *dummy,      /* current interpreter */
 470     int objc,                /* number of arguments */
 471     Tcl_Obj *const objv[])   /* argument objects */
 472 {
 473     ItclObjectInfo *infoPtr;
 474     (void)dummy;
 475
 476     infoPtr = (ItclObjectInfo *)clientData;
 477     if ((infoPtr->currIoPtr != NULL) && (objc > 1)) {
 478         infoPtr->currIoPtr->hullWindowNamePtr = objv[1];
 479         Tcl_IncrRefCount(infoPtr->currIoPtr->hullWindowNamePtr);
 480     }
 481     return TCL_OK;
 482 }
 483 \f
 484 /*
 485  * ------------------------------------------------------------------------
 486  *  ItclCheckSetItclHull()
 487  *
 488  *
 489  * ------------------------------------------------------------------------
 490  */
 491 static int
 492 ItclCheckSetItclHull(
 493     void *clientData,   /* infoPtr */
 494     Tcl_Interp *interp,      /* current interpreter */
 495     int objc,                /* number of arguments */
 496     Tcl_Obj *const objv[])   /* argument objects */
 497 {
 498     Tcl_HashEntry *hPtr;
 499     Tcl_Obj *objPtr;
 500     ItclObject *ioPtr;
 501     ItclVariable *ivPtr;
 502     ItclObjectInfo *infoPtr;
 503     const char *valueStr;
 504
 505     if (objc < 3) {
 506         Tcl_AppendResult(interp, "ItclCheckSetItclHull wrong # args should be ",
 507                 "<objectName> <value>", NULL);
 508         return TCL_ERROR;
 509     }
 510
 511     /*
 512      * This is an internal command, and is never called with an
 513      * objectName value other than the empty list. Check that with
 514      * an assertion so alternative handling can be removed.
 515      */
 516     assert( strlen(Tcl_GetString(objv[1])) == 0);
 517     infoPtr = (ItclObjectInfo *)clientData;
 518     {
 519         ioPtr = infoPtr->currIoPtr;
 520         if (ioPtr == NULL) {
 521             Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find object",
 522                     NULL);
 523             return TCL_ERROR;
 524         }
 525     }
 526     objPtr = Tcl_NewStringObj("itcl_hull", -1);
 527     hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr);
 528     Tcl_DecrRefCount(objPtr);
 529     if (hPtr == NULL) {
 530         Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find itcl_hull",
 531                 " variable for object \"", Tcl_GetString(objv[1]), "\"", NULL);
 532         return TCL_ERROR;
 533     }
 534     ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr);
 535     valueStr = Tcl_GetString(objv[2]);
 536     if (strcmp(valueStr, "2") == 0) {
 537         ivPtr->initted = 2;
 538     } else {
 539         if (strcmp(valueStr, "0") == 0) {
 540             ivPtr->initted = 0;
 541         } else {
 542             Tcl_AppendResult(interp, "ItclCheckSetItclHull bad value \"",
 543                     valueStr, "\"", NULL);
 544             return TCL_ERROR;
 545         }
 546     }
 547     return TCL_OK;
 548 }
 549 \f
 550 /*
 551  * ------------------------------------------------------------------------
 552  *  FreeItclObjectInfo()
 553  *
 554  *  called when an interp is deleted to free up memory
 555  *
 556  * ------------------------------------------------------------------------
 557  */
 558 static void
 559 FreeItclObjectInfo(
 560     void *clientData)
 561 {
 562     ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
 563
 564     Tcl_DeleteHashTable(&infoPtr->instances);
 565     Tcl_DeleteHashTable(&infoPtr->classTypes);
 566     Tcl_DeleteHashTable(&infoPtr->procMethods);
 567     Tcl_DeleteHashTable(&infoPtr->objectCmds);
 568     Tcl_DeleteHashTable(&infoPtr->classes);
 569     Tcl_DeleteHashTable(&infoPtr->nameClasses);
 570     Tcl_DeleteHashTable(&infoPtr->namespaceClasses);
 571
 572     assert (infoPtr->infoVarsPtr == NULL);
 573     assert (infoPtr->infoVars4Ptr == NULL);
 574
 575     if (infoPtr->typeDestructorArgumentPtr) {
 576         Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
 577         infoPtr->typeDestructorArgumentPtr = NULL;
 578     }
 579
 580     /* cleanup ensemble info */
 581     if (infoPtr->ensembleInfo) {
 582         Tcl_DeleteHashTable(&infoPtr->ensembleInfo->ensembles);
 583         Tcl_DeleteHashTable(&infoPtr->ensembleInfo->subEnsembles);
 584         ItclFinishEnsemble(infoPtr);
 585         ckfree((char *)infoPtr->ensembleInfo);
 586         infoPtr->ensembleInfo = NULL;
 587     }
 588
 589     if (infoPtr->class_meta_type) {
 590         ckfree((char *)infoPtr->class_meta_type);
 591         infoPtr->class_meta_type = NULL;
 592     }
 593
 594     /* clean up list pool */
 595     Itcl_FinishList();
 596
 597     Itcl_ReleaseData(infoPtr);
 598 }