/* * 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 #include "itclInt.h" #include "itclUuid.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 -encoding utf-8 [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 add variable itcl-local-$ptr unset \"::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 * * ------------------------------------------------------------------------ */ #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif 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; Tcl_CmdInfo info; 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", TCL_INDEX_NONE); 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("", TCL_INDEX_NONE); 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", TCL_INDEX_NONE), &isNew); Tcl_SetHashValue(hPtr, ITCL_CLASS); hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, (char *)Tcl_NewStringObj("type", TCL_INDEX_NONE), &isNew); Tcl_SetHashValue(hPtr, ITCL_TYPE); hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, (char *)Tcl_NewStringObj("widget", TCL_INDEX_NONE), &isNew); Tcl_SetHashValue(hPtr, ITCL_WIDGET); hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, (char *)Tcl_NewStringObj("widgetadaptor", TCL_INDEX_NONE), &isNew); Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR); hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes, (char *)Tcl_NewStringObj("extendedclass", TCL_INDEX_NONE), &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", TCL_INDEX_NONE), 0, &itclRootMethodType, (void *)ItclUnknownGuts); Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), Tcl_NewStringObj("ItclConstructBase", TCL_INDEX_NONE), 0, &itclRootMethodType, (void *)ItclConstructGuts); Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root), Tcl_NewStringObj("info", TCL_INDEX_NONE), 1, &itclRootMethodType, (void *)ItclInfoGuts); /* first create the Itcl base class as root of itcl classes */ if (Tcl_EvalEx(interp, clazzClassScript, TCL_INDEX_NONE, 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. */ if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { Tcl_CreateObjCommand(interp, "::itcl::build-info", info.objProc, (void *)(PACKAGE_VERSION "+" STRINGIFY(ITCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) #if __clang_minor__ < 10 "0" #endif STRINGIFY(__clang_minor__) #endif #if defined(__cplusplus) && !defined(__OBJC__) ".cplusplus" #endif #ifndef NDEBUG ".debug" #endif #if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) ".gcc-" STRINGIFY(__GNUC__) #if __GNUC_MINOR__ < 10 "0" #endif STRINGIFY(__GNUC_MINOR__) #endif #ifdef __INTEL_COMPILER ".icc-" STRINGIFY(__INTEL_COMPILER) #endif #ifdef TCL_MEM_DEBUG ".memdebug" #endif #if defined(_MSC_VER) ".msvc-" STRINGIFY(_MSC_VER) #endif #ifdef USE_NMAKE ".nmake" #endif #ifndef TCL_CFG_OPTIMIZED ".no-optimize" #endif #ifdef __OBJC__ ".objective-c" #if defined(__cplusplus) "plusplus" #endif #endif #ifdef TCL_CFG_PROFILED ".profile" #endif #ifdef PURIFY ".purify" #endif #ifdef STATIC_BUILD ".static" #endif ), NULL); } 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, TCL_INDEX_NONE, 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, TCL_INDEX_NONE, 0); } /* * ------------------------------------------------------------------------ * ItclSetHullWindowName() * * * ------------------------------------------------------------------------ */ static int ItclSetHullWindowName( void *clientData, /* infoPtr */ TCL_UNUSED(Tcl_Interp *),/* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr; 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 ", " ", 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", TCL_INDEX_NONE); 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; } Itcl_ReleaseData(infoPtr); }