599 lines
19 KiB
C
599 lines
19 KiB
C
/*
|
||
* itclBase.c --
|
||
*
|
||
* This file contains the C-implemented startup part of an
|
||
* Itcl implemenatation
|
||
*
|
||
* Copyright (c) 2007 by Arnulf P. Wiedemann
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution of
|
||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*/
|
||
|
||
#include <stdlib.h>
|
||
#include "itclInt.h"
|
||
|
||
static Tcl_NamespaceDeleteProc FreeItclObjectInfo;
|
||
static Tcl_ObjCmdProc ItclSetHullWindowName;
|
||
static Tcl_ObjCmdProc ItclCheckSetItclHull;
|
||
|
||
MODULE_SCOPE const ItclStubs itclStubs;
|
||
|
||
static int Initialize(Tcl_Interp *interp);
|
||
|
||
static const char initScript[] =
|
||
"namespace eval ::itcl {\n"
|
||
" proc _find_init {} {\n"
|
||
" global env tcl_library\n"
|
||
" variable library\n"
|
||
" variable patchLevel\n"
|
||
" rename _find_init {}\n"
|
||
" if {[info exists library]} {\n"
|
||
" lappend dirs $library\n"
|
||
" } else {\n"
|
||
" set dirs {}\n"
|
||
" if {[info exists env(ITCL_LIBRARY)]} {\n"
|
||
" lappend dirs $env(ITCL_LIBRARY)\n"
|
||
" }\n"
|
||
" lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n"
|
||
" set bindir [file dirname [info nameofexecutable]]\n"
|
||
" lappend dirs [file join . library]\n"
|
||
" lappend dirs [file join $bindir .. lib itcl$patchLevel]\n"
|
||
" lappend dirs [file join $bindir .. library]\n"
|
||
" lappend dirs [file join $bindir .. .. library]\n"
|
||
" lappend dirs [file join $bindir .. .. itcl library]\n"
|
||
" lappend dirs [file join $bindir .. .. .. itcl library]\n"
|
||
" lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n"
|
||
" # On *nix, check the directories in the tcl_pkgPath\n"
|
||
" # XXX JH - this looks unnecessary, maybe Darwin only?\n"
|
||
" if {[string equal $::tcl_platform(platform) \"unix\"]} {\n"
|
||
" foreach d $::tcl_pkgPath {\n"
|
||
" lappend dirs $d\n"
|
||
" lappend dirs [file join $d itcl$patchLevel]\n"
|
||
" }\n"
|
||
" }\n"
|
||
" }\n"
|
||
" foreach i $dirs {\n"
|
||
" set library $i\n"
|
||
" if {![catch {uplevel #0 [list source [file join $i itcl.tcl]]}]} {\n"
|
||
" set library $i\n"
|
||
" return\n"
|
||
" }\n"
|
||
" }\n"
|
||
" set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n"
|
||
" append msg \" $dirs\n\"\n"
|
||
" append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n"
|
||
" append msg \"If you know where the Itcl library directory was installed,\n\"\n"
|
||
" append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n"
|
||
" append msg \"to the library directory.\n\"\n"
|
||
" error $msg\n"
|
||
" }\n"
|
||
" _find_init\n"
|
||
"}";
|
||
|
||
/*
|
||
* The following script is used to initialize Itcl in a safe interpreter.
|
||
*/
|
||
|
||
static const char safeInitScript[] =
|
||
"proc ::itcl::local {class name args} {\n"
|
||
" set ptr [uplevel [list $class $name] $args]\n"
|
||
" uplevel [list set itcl-local-$ptr $ptr]\n"
|
||
" set cmd [uplevel namespace which -command $ptr]\n"
|
||
" uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n"
|
||
" return $ptr\n"
|
||
"}";
|
||
|
||
static const char *clazzClassScript =
|
||
"::oo::class create ::itcl::clazz {\n"
|
||
" superclass ::oo::class\n"
|
||
" method unknown args {\n"
|
||
" ::tailcall ::itcl::parser::handleClass [::lindex [::info level 0] 0] [self] {*}$args\n"
|
||
" }\n"
|
||
" unexport create new unknown\n"
|
||
"}";
|
||
|
||
#define ITCL_IS_ENSEMBLE 0x1
|
||
|
||
#ifdef ITCL_DEBUG_C_INTERFACE
|
||
extern void RegisterDebugCFunctions( Tcl_Interp * interp);
|
||
#endif
|
||
|
||
static Tcl_ObjectMetadataDeleteProc Demolition;
|
||
|
||
static const Tcl_ObjectMetadataType canary = {
|
||
TCL_OO_METADATA_VERSION_CURRENT,
|
||
"Itcl Foundations",
|
||
Demolition,
|
||
NULL
|
||
};
|
||
|
||
void
|
||
Demolition(
|
||
void *clientData)
|
||
{
|
||
ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
|
||
|
||
infoPtr->clazzObjectPtr = NULL;
|
||
infoPtr->clazzClassPtr = NULL;
|
||
}
|
||
|
||
static const Tcl_ObjectMetadataType objMDT = {
|
||
TCL_OO_METADATA_VERSION_CURRENT,
|
||
"ItclObject",
|
||
ItclDeleteObjectMetadata, /* Not really used yet */
|
||
NULL
|
||
};
|
||
|
||
static Tcl_MethodCallProc RootCallProc;
|
||
|
||
const Tcl_MethodType itclRootMethodType = {
|
||
TCL_OO_METHOD_VERSION_CURRENT,
|
||
"itcl root method",
|
||
RootCallProc,
|
||
NULL,
|
||
NULL
|
||
};
|
||
|
||
static int
|
||
RootCallProc(
|
||
void *clientData,
|
||
Tcl_Interp *interp,
|
||
Tcl_ObjectContext context,
|
||
int objc,
|
||
Tcl_Obj *const *objv)
|
||
{
|
||
Tcl_Object oPtr = Tcl_ObjectContextObject(context);
|
||
ItclObject *ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, &objMDT);
|
||
ItclRootMethodProc *proc = (ItclRootMethodProc *)clientData;
|
||
|
||
return (*proc)(ioPtr, interp, objc, objv);
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Initialize()
|
||
*
|
||
* that is the starting point when loading the library
|
||
* it initializes all internal stuff
|
||
*
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
Initialize (
|
||
Tcl_Interp *interp)
|
||
{
|
||
Tcl_Namespace *nsPtr;
|
||
Tcl_Namespace *itclNs;
|
||
Tcl_HashEntry *hPtr;
|
||
ItclObjectInfo *infoPtr;
|
||
const char * ret;
|
||
char *res_option;
|
||
int opt;
|
||
int isNew;
|
||
Tcl_Class tclCls;
|
||
Tcl_Object clazzObjectPtr, root;
|
||
Tcl_Obj *objPtr, *resPtr;
|
||
|
||
if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
ret = TclOOInitializeStubs(interp, "1.0");
|
||
if (ret == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
objPtr = Tcl_NewStringObj("::oo::class", -1);
|
||
Tcl_IncrRefCount(objPtr);
|
||
clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
|
||
if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
|
||
Tcl_DecrRefCount(objPtr);
|
||
return TCL_ERROR;
|
||
}
|
||
Tcl_DecrRefCount(objPtr);
|
||
|
||
infoPtr = (ItclObjectInfo*)Itcl_Alloc(sizeof(ItclObjectInfo));
|
||
|
||
nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
|
||
if (nsPtr == NULL) {
|
||
Itcl_Free(infoPtr);
|
||
Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
|
||
}
|
||
|
||
nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE,
|
||
NULL, NULL);
|
||
if (nsPtr == NULL) {
|
||
Itcl_Free(infoPtr);
|
||
Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
|
||
ITCL_NAMESPACE);
|
||
}
|
||
|
||
/*
|
||
* Create the top-level data structure for tracking objects.
|
||
* Store this as "associated data" for easy access, but link
|
||
* it to the itcl namespace for ownership.
|
||
*/
|
||
infoPtr->interp = interp;
|
||
infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
|
||
sizeof(Tcl_ObjectMetadataType));
|
||
infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
|
||
infoPtr->class_meta_type->name = "ItclClass";
|
||
infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata;
|
||
infoPtr->class_meta_type->cloneProc = NULL;
|
||
|
||
infoPtr->object_meta_type = &objMDT;
|
||
|
||
Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->classes, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitObjHashTable(&infoPtr->nameClasses);
|
||
Tcl_InitHashTable(&infoPtr->namespaceClasses, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->procMethods, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->instances, TCL_STRING_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->frameContext, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitObjHashTable(&infoPtr->classTypes);
|
||
|
||
infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo));
|
||
memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo));
|
||
Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS);
|
||
Tcl_InitHashTable(&infoPtr->ensembleInfo->subEnsembles, TCL_ONE_WORD_KEYS);
|
||
infoPtr->ensembleInfo->numEnsembles = 0;
|
||
infoPtr->protection = ITCL_DEFAULT_PROTECT;
|
||
infoPtr->currClassFlags = 0;
|
||
infoPtr->buildingWidget = 0;
|
||
infoPtr->typeDestructorArgumentPtr = Tcl_NewStringObj("", -1);
|
||
Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr);
|
||
infoPtr->lastIoPtr = NULL;
|
||
|
||
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classes", NULL, "", 0);
|
||
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::objects", NULL, "", 0);
|
||
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", NULL, "", 0);
|
||
Tcl_SetVar2(interp,
|
||
ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", NULL, "", 0);
|
||
Tcl_SetVar2(interp,
|
||
ITCL_NAMESPACE"::internal::dicts::classComponents", NULL, "", 0);
|
||
Tcl_SetVar2(interp,
|
||
ITCL_NAMESPACE"::internal::dicts::classVariables", NULL, "", 0);
|
||
Tcl_SetVar2(interp,
|
||
ITCL_NAMESPACE"::internal::dicts::classFunctions", NULL, "", 0);
|
||
Tcl_SetVar2(interp,
|
||
ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", NULL, "", 0);
|
||
|
||
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
|
||
(char *)Tcl_NewStringObj("class", -1), &isNew);
|
||
Tcl_SetHashValue(hPtr, ITCL_CLASS);
|
||
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
|
||
(char *)Tcl_NewStringObj("type", -1), &isNew);
|
||
Tcl_SetHashValue(hPtr, ITCL_TYPE);
|
||
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
|
||
(char *)Tcl_NewStringObj("widget", -1), &isNew);
|
||
Tcl_SetHashValue(hPtr, ITCL_WIDGET);
|
||
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
|
||
(char *)Tcl_NewStringObj("widgetadaptor", -1), &isNew);
|
||
Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR);
|
||
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
|
||
(char *)Tcl_NewStringObj("extendedclass", -1), &isNew);
|
||
Tcl_SetHashValue(hPtr, ITCL_ECLASS);
|
||
|
||
res_option = getenv("ITCL_USE_OLD_RESOLVERS");
|
||
if (res_option == NULL) {
|
||
opt = 1;
|
||
} else {
|
||
opt = atoi(res_option);
|
||
}
|
||
infoPtr->useOldResolvers = opt;
|
||
Itcl_InitStack(&infoPtr->clsStack);
|
||
|
||
Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, infoPtr);
|
||
|
||
Itcl_PreserveData(infoPtr);
|
||
|
||
root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root",
|
||
NULL, 0, NULL, 0);
|
||
|
||
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
|
||
Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
|
||
(void *)ItclUnknownGuts);
|
||
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
|
||
Tcl_NewStringObj("ItclConstructBase", -1), 0,
|
||
&itclRootMethodType, (void *)ItclConstructGuts);
|
||
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
|
||
Tcl_NewStringObj("info", -1), 1,
|
||
&itclRootMethodType, (void *)ItclInfoGuts);
|
||
|
||
/* first create the Itcl base class as root of itcl classes */
|
||
if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) {
|
||
Tcl_Panic("cannot create Itcl root class ::itcl::clazz");
|
||
}
|
||
resPtr = Tcl_GetObjResult(interp);
|
||
/*
|
||
* Tcl_GetObjectFromObject can call Tcl_SetObjResult, so increment the
|
||
* refcount first.
|
||
*/
|
||
Tcl_IncrRefCount(resPtr);
|
||
clazzObjectPtr = Tcl_GetObjectFromObj(interp, resPtr);
|
||
Tcl_DecrRefCount(resPtr);
|
||
|
||
if (clazzObjectPtr == NULL) {
|
||
Tcl_AppendResult(interp,
|
||
"ITCL: cannot get Object for ::itcl::clazz for class \"",
|
||
"::itcl::clazz", "\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_ObjectSetMetadata(clazzObjectPtr, &canary, infoPtr);
|
||
|
||
infoPtr->clazzObjectPtr = clazzObjectPtr;
|
||
infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);
|
||
|
||
/*
|
||
* Initialize the ensemble package first, since we need this
|
||
* for other parts of [incr Tcl].
|
||
*/
|
||
|
||
if (Itcl_EnsembleInit(interp) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Itcl_ParseInit(interp, infoPtr);
|
||
|
||
/*
|
||
* Create "itcl::builtin" namespace for commands that
|
||
* are automatically built into class definitions.
|
||
*/
|
||
if (Itcl_BiInit(interp, infoPtr) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* Export all commands in the "itcl" namespace so that they
|
||
* can be imported with something like "namespace import itcl::*"
|
||
*/
|
||
itclNs = Tcl_FindNamespace(interp, "::itcl", NULL,
|
||
TCL_LEAVE_ERR_MSG);
|
||
|
||
/*
|
||
* This was changed from a glob export (itcl::*) to explicit
|
||
* command exports, so that the itcl::is command can *not* be
|
||
* exported. This is done for concern that the itcl::is command
|
||
* imported might be confusing ("is").
|
||
*/
|
||
if (!itclNs ||
|
||
(Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "filter", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "forward", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "mixin", 0) != TCL_OK) ||
|
||
(Tcl_Export(interp, itclNs, "scope", 0) != TCL_OK)) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_CreateObjCommand(interp,
|
||
ITCL_NAMESPACE"::internal::commands::sethullwindowname",
|
||
ItclSetHullWindowName, infoPtr, NULL);
|
||
Tcl_CreateObjCommand(interp,
|
||
ITCL_NAMESPACE"::internal::commands::checksetitclhull",
|
||
ItclCheckSetItclHull, infoPtr, NULL);
|
||
|
||
/*
|
||
* Set up the variables containing version info.
|
||
*/
|
||
|
||
Tcl_SetVar2(interp, "::itcl::version", NULL, ITCL_VERSION, TCL_NAMESPACE_ONLY);
|
||
Tcl_SetVar2(interp, "::itcl::patchLevel", NULL, ITCL_PATCH_LEVEL,
|
||
TCL_NAMESPACE_ONLY);
|
||
|
||
|
||
#ifdef ITCL_DEBUG_C_INTERFACE
|
||
RegisterDebugCFunctions(interp);
|
||
#endif
|
||
/*
|
||
* Package is now loaded.
|
||
*/
|
||
|
||
Tcl_PkgProvideEx(interp, "Itcl", ITCL_PATCH_LEVEL, &itclStubs);
|
||
return Tcl_PkgProvideEx(interp, "itcl", ITCL_PATCH_LEVEL, &itclStubs);
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_Init()
|
||
*
|
||
* Invoked whenever a new INTERPRETER is created to install the
|
||
* [incr Tcl] package. Usually invoked within Tcl_AppInit() at
|
||
* the start of execution.
|
||
*
|
||
* Creates the "::itcl" namespace and installs access commands for
|
||
* creating classes and querying info.
|
||
*
|
||
* Returns TCL_OK on success, or TCL_ERROR (along with an error
|
||
* message in the interpreter) if anything goes wrong.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Itcl_Init (
|
||
Tcl_Interp *interp)
|
||
{
|
||
if (Initialize(interp) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
return Tcl_EvalEx(interp, initScript, -1, 0);
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* Itcl_SafeInit()
|
||
*
|
||
* Invoked whenever a new SAFE INTERPRETER is created to install
|
||
* the [incr Tcl] package.
|
||
*
|
||
* Creates the "::itcl" namespace and installs access commands for
|
||
* creating classes and querying info.
|
||
*
|
||
* Returns TCL_OK on success, or TCL_ERROR (along with an error
|
||
* message in the interpreter) if anything goes wrong.
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
Itcl_SafeInit (
|
||
Tcl_Interp *interp)
|
||
{
|
||
if (Initialize(interp) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
return Tcl_EvalEx(interp, safeInitScript, -1, 0);
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclSetHullWindowName()
|
||
*
|
||
*
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static int
|
||
ItclSetHullWindowName(
|
||
void *clientData, /* infoPtr */
|
||
Tcl_Interp *dummy, /* current interpreter */
|
||
int objc, /* number of arguments */
|
||
Tcl_Obj *const objv[]) /* argument objects */
|
||
{
|
||
ItclObjectInfo *infoPtr;
|
||
(void)dummy;
|
||
|
||
infoPtr = (ItclObjectInfo *)clientData;
|
||
if ((infoPtr->currIoPtr != NULL) && (objc > 1)) {
|
||
infoPtr->currIoPtr->hullWindowNamePtr = objv[1];
|
||
Tcl_IncrRefCount(infoPtr->currIoPtr->hullWindowNamePtr);
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* ItclCheckSetItclHull()
|
||
*
|
||
*
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static int
|
||
ItclCheckSetItclHull(
|
||
void *clientData, /* infoPtr */
|
||
Tcl_Interp *interp, /* current interpreter */
|
||
int objc, /* number of arguments */
|
||
Tcl_Obj *const objv[]) /* argument objects */
|
||
{
|
||
Tcl_HashEntry *hPtr;
|
||
Tcl_Obj *objPtr;
|
||
ItclObject *ioPtr;
|
||
ItclVariable *ivPtr;
|
||
ItclObjectInfo *infoPtr;
|
||
const char *valueStr;
|
||
|
||
if (objc < 3) {
|
||
Tcl_AppendResult(interp, "ItclCheckSetItclHull wrong # args should be ",
|
||
"<objectName> <value>", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/*
|
||
* This is an internal command, and is never called with an
|
||
* objectName value other than the empty list. Check that with
|
||
* an assertion so alternative handling can be removed.
|
||
*/
|
||
assert( strlen(Tcl_GetString(objv[1])) == 0);
|
||
infoPtr = (ItclObjectInfo *)clientData;
|
||
{
|
||
ioPtr = infoPtr->currIoPtr;
|
||
if (ioPtr == NULL) {
|
||
Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find object",
|
||
NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
objPtr = Tcl_NewStringObj("itcl_hull", -1);
|
||
hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr);
|
||
Tcl_DecrRefCount(objPtr);
|
||
if (hPtr == NULL) {
|
||
Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find itcl_hull",
|
||
" variable for object \"", Tcl_GetString(objv[1]), "\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr);
|
||
valueStr = Tcl_GetString(objv[2]);
|
||
if (strcmp(valueStr, "2") == 0) {
|
||
ivPtr->initted = 2;
|
||
} else {
|
||
if (strcmp(valueStr, "0") == 0) {
|
||
ivPtr->initted = 0;
|
||
} else {
|
||
Tcl_AppendResult(interp, "ItclCheckSetItclHull bad value \"",
|
||
valueStr, "\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* ------------------------------------------------------------------------
|
||
* FreeItclObjectInfo()
|
||
*
|
||
* called when an interp is deleted to free up memory
|
||
*
|
||
* ------------------------------------------------------------------------
|
||
*/
|
||
static void
|
||
FreeItclObjectInfo(
|
||
void *clientData)
|
||
{
|
||
ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
|
||
|
||
Tcl_DeleteHashTable(&infoPtr->instances);
|
||
Tcl_DeleteHashTable(&infoPtr->classTypes);
|
||
Tcl_DeleteHashTable(&infoPtr->procMethods);
|
||
Tcl_DeleteHashTable(&infoPtr->objectCmds);
|
||
Tcl_DeleteHashTable(&infoPtr->classes);
|
||
Tcl_DeleteHashTable(&infoPtr->nameClasses);
|
||
Tcl_DeleteHashTable(&infoPtr->namespaceClasses);
|
||
|
||
assert (infoPtr->infoVarsPtr == NULL);
|
||
assert (infoPtr->infoVars4Ptr == NULL);
|
||
|
||
if (infoPtr->typeDestructorArgumentPtr) {
|
||
Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
|
||
infoPtr->typeDestructorArgumentPtr = NULL;
|
||
}
|
||
|
||
/* cleanup ensemble info */
|
||
if (infoPtr->ensembleInfo) {
|
||
Tcl_DeleteHashTable(&infoPtr->ensembleInfo->ensembles);
|
||
Tcl_DeleteHashTable(&infoPtr->ensembleInfo->subEnsembles);
|
||
ItclFinishEnsemble(infoPtr);
|
||
ckfree((char *)infoPtr->ensembleInfo);
|
||
infoPtr->ensembleInfo = NULL;
|
||
}
|
||
|
||
if (infoPtr->class_meta_type) {
|
||
ckfree((char *)infoPtr->class_meta_type);
|
||
infoPtr->class_meta_type = NULL;
|
||
}
|
||
|
||
/* clean up list pool */
|
||
Itcl_FinishList();
|
||
|
||
Itcl_ReleaseData(infoPtr);
|
||
}
|