int Sdlmix_Init(Tcl_Interp *interp) { if (SDL_Init(SDL_INIT_AUDIO) < 0) { return TCL_ERROR; } if (Mix_OpenAudio(44100, MIX_DEFAULT_FORMAT, 2, BUFFER) < 0) { SDL_Quit(); return TCL_ERROR; } // deallocate default channels Mix_AllocateChannels(0); Tcl_Namespace *ns = Tcl_FindNamespace(interp, "sdl", NULL, 0); if (!ns) { ns = Tcl_CreateNamespace(interp, "sdl", NULL, NULL); } ns = Tcl_CreateNamespace(interp, "sdl::mix", NULL, NULL); Tcl_Export(interp, ns, "*", 0); TclData *self = new TclData; Tcl_CreateObjCommand(interp, "sdl::mix::music", musicCmd, self, destructor); Tcl_CreateObjCommand(interp, "sdl::mix::channels", chnCmd, self, NULL); Tcl_CreateObjCommand(interp, "sdl::mix::sound", sndCmd, self, NULL); return TCL_OK; }
/* * Tclduktape_Init -- Called when Tcl loads the extension. */ int DLLEXPORT Tclduktape_Init(Tcl_Interp *interp) { Tcl_Namespace *nsPtr; struct DuktapeData *duktape_data; #ifdef USE_TCL_STUBS if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { return TCL_ERROR; } #endif duktape_data = (struct DuktapeData *) ckalloc(sizeof(struct DuktapeData)); /* Create the namespace. */ if (Tcl_FindNamespace(interp, NS, NULL, 0) == NULL) { nsPtr = Tcl_CreateNamespace(interp, NS, NULL, NULL); if (nsPtr == NULL) { return TCL_ERROR; } } duktape_data->counter = 0; Tcl_InitHashTable(&duktape_data->table, TCL_STRING_KEYS); Tcl_CreateObjCommand(interp, NS INIT, Init_Cmd, duktape_data, NULL); Tcl_CreateObjCommand(interp, NS CLOSE, Close_Cmd, duktape_data, NULL); Tcl_CreateObjCommand(interp, NS EVAL, Eval_Cmd, duktape_data, NULL); Tcl_CreateObjCommand(interp, NS CALL_METHOD, CallMethod_Cmd, duktape_data, NULL); Tcl_CallWhenDeleted(interp, cleanup_interp, duktape_data); Tcl_PkgProvide(interp, PACKAGE, VERSION); return TCL_OK; }
/*LINTLIBRARY*/ int Blt_x_Init(Tcl_Interp *interp) /* Interpreter to add extra commands */ { Tcl_Namespace *nsPtr; Tcl_AppInitProc **p; const int isExact = 1; #ifdef USE_TCL_STUBS if (Tcl_InitStubs(interp, TCL_VERSION_LOADED, isExact) == NULL) { return TCL_ERROR; }; #endif if (Tcl_PkgRequire(interp, "blt_core", BLT_VERSION, isExact) == NULL) { return TCL_ERROR; } #if (_TCL_VERSION >= _VERSION(8,1,0)) #ifdef USE_TK_STUBS if (Tk_InitStubs(interp, TK_VERSION_LOADED, isExact) == NULL) { return TCL_ERROR; }; #endif if (Tcl_PkgPresent(interp, "Tk", TK_VERSION_LOADED, isExact) == NULL) { return TCL_OK; } #else if (Tcl_PkgRequire(interp, "Tk", TK_VERSION_LOADED, isExact) == NULL) { Tcl_ResetResult(interp); return TCL_OK; } #endif nsPtr = Tcl_CreateNamespace(interp, "::blt::tk", NULL, NULL); if (nsPtr == NULL) { return TCL_ERROR; } nsPtr = Tcl_FindNamespace(interp, "::blt", NULL, TCL_LEAVE_ERR_MSG); if (nsPtr == NULL) { return TCL_ERROR; } Blt_RegisterPictureImageType(interp); Blt_RegisterEpsCanvasItem(); Blt_InitXRandrConfig(interp); /* Initialize the BLT commands that only use Tk. */ for (p = cmdProcs; *p != NULL; p++) { if ((**p) (interp) != TCL_OK) { Tcl_DeleteNamespace(nsPtr); return TCL_ERROR; } } if (Tcl_PkgProvide(interp, "blt_extra", BLT_VERSION) != TCL_OK) { return TCL_ERROR; } return TCL_OK; }
Tcl_Command TclInitPrefixCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap prefixImplMap[] = { {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0}, {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0}, {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command prefixCmd; prefixCmd = TclMakeEnsemble(interp, "::tcl::prefix", prefixImplMap); Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), "prefix", 0); return prefixCmd; }
int DLLEXPORT Tclrun_Init(Tcl_Interp *interp) { if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) return TCL_ERROR; if (Tcl_PkgProvide(interp, "run", "0.0.1") == TCL_ERROR) return TCL_ERROR; Tcl_CreateObjCommand(interp, "run::c::c_run", C_Run_Cmd, NULL, NULL); Tcl_Namespace* ns = Tcl_FindNamespace(interp, "run", NULL, 0); Tcl_Export(interp, ns, "*", 0); return TCL_OK; }
void Ttk_StylePkgInit(Tcl_Interp *interp) { Tcl_Namespace *nsPtr; StylePackageData *pkgPtr = ckalloc(sizeof(StylePackageData)); pkgPtr->interp = interp; Tcl_InitHashTable(&pkgPtr->themeTable, TCL_STRING_KEYS); Tcl_InitHashTable(&pkgPtr->factoryTable, TCL_STRING_KEYS); pkgPtr->cleanupList = NULL; pkgPtr->cache = Ttk_CreateResourceCache(interp); pkgPtr->themeChangePending = 0; Tcl_SetAssocData(interp, PKG_ASSOC_KEY, Ttk_StylePkgFree, pkgPtr); /* * Create the default system theme: * * pkgPtr->defaultTheme must be initialized to 0 before * calling Ttk_CreateTheme for the first time, since it's used * as the parent theme. */ pkgPtr->defaultTheme = 0; pkgPtr->defaultTheme = pkgPtr->currentTheme = Ttk_CreateTheme(interp, "default", NULL); /* * Register null element, used as a last-resort fallback: */ Ttk_RegisterElement(interp, pkgPtr->defaultTheme, "", &ttkNullElementSpec, 0); /* * Register commands: */ Tcl_CreateObjCommand(interp, "::ttk::style", StyleObjCmd, pkgPtr, 0); nsPtr = Tcl_FindNamespace(interp, "::ttk", NULL, TCL_LEAVE_ERR_MSG); Tcl_Export(interp, nsPtr, "style", 0 /* dontResetList */); Ttk_RegisterElementFactory(interp, "from", Ttk_CloneElement, 0); }
static int Ta4r_PackageInit (Tcl_Interp *interp) { Tcl_Namespace *ns; Ta4r_Cmd *c; Tcl_Obj *o; Tcl_Obj *m; Tcl_Obj *f; if ((ns = Tcl_FindNamespace(interp, Ta4r, NULL, TCL_LEAVE_ERR_MSG)) == NULL) { return TCL_ERROR; } m = Tcl_NewDictObj(); for (c = &Ta4r_Cmds[0]; c->name != NULL; c++) { /* Put commands into sub-namespace so as not to conflict with ensemble name */ /* This will also create the sub-namespace. Slightly cheap? */ o = Tcl_ObjPrintf("%s::commands::%s", Ta4r, c->name); Tcl_IncrRefCount(o); f = Tcl_ObjPrintf("::tcl::mathfunc::%s", c->name); Tcl_IncrRefCount(f); if (Tcl_CreateObjCommand(interp, Tcl_GetString(o), c->proc, NULL, NULL) == NULL) { Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); return TCL_ERROR; } if (Tcl_CreateAlias(interp, Tcl_GetString(f), interp, Tcl_GetString(o), 0, NULL) != TCL_OK) { Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); return TCL_ERROR; } Tcl_DictObjPut(interp, m, Tcl_NewStringObj(c->name+4, -1), o); Tcl_DecrRefCount(o); Tcl_DecrRefCount(f); } if (Tcl_SetEnsembleMappingDict(interp, Tcl_CreateEnsemble(interp, (Ta4r+2), ns, TCL_ENSEMBLE_PREFIX), m) != TCL_OK) { return TCL_ERROR; }; if (Tcl_Export(interp, ns, (Ta4r+2), 0) != TCL_OK) { return TCL_ERROR; } return TCL_OK; }
/* * ------------------------------------------------------------------------ * Itk_ArchetypeInit() * * Invoked by Itk_Init() whenever a new interpreter is created to * declare the procedures used in the itk::Archetype base class. * ------------------------------------------------------------------------ */ int Itk_ArchetypeInit( Tcl_Interp *interp) /* interpreter to be updated */ { ArchMergeInfo *mergeInfo; Tcl_Namespace *parserNs; Tcl_Namespace *nsPtr; Tcl_Command cmd; int i; /* * Declare all of the C routines that are integrated into * the Archetype base class. */ if (Itcl_RegisterObjC(interp, "Archetype-init", Itk_ArchInitOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-delete", Itk_ArchDeleteOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_component", Itk_ArchComponentCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_option", Itk_ArchOptionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_initialize", Itk_ArchInitCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-component", Itk_ArchCompAccessCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-configure",Itk_ArchConfigureCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-cget",Itk_ArchCgetCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { return TCL_ERROR; } /* * Build the ensemble used to implement [_archetype]. */ nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Archetype", NULL, NULL); if (nsPtr == NULL) { nsPtr = Tcl_FindNamespace(interp, "::itcl::builtin::Archetype", NULL, 0); } if (nsPtr == NULL) { fprintf(stderr, "error in creating namespace: ::itcl::builtin::Archetype \n"); } cmd = Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr, TCL_ENSEMBLE_PREFIX); Tcl_Export(interp, nsPtr, "[a-z]*", 1); for (i=0 ; archetypeCmds[i].name!=NULL ; i++) { Tcl_CreateObjCommand(interp, archetypeCmds[i].name, archetypeCmds[i].proc, NULL, NULL); } /* * Create the namespace containing the option parser commands. */ mergeInfo = (ArchMergeInfo*)ckalloc(sizeof(ArchMergeInfo)); Tcl_InitHashTable(&mergeInfo->usualCode, TCL_STRING_KEYS); mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; mergeInfo->optionTable = NULL; parserNs = Tcl_CreateNamespace(interp, "::itk::option-parser", (ClientData)mergeInfo, Itcl_ReleaseData); if (!parserNs) { Itk_DelMergeInfo((char*)mergeInfo); Tcl_AddErrorInfo(interp, "\n (while initializing itk)"); return TCL_ERROR; } Itcl_PreserveData((ClientData)mergeInfo); Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo); Tcl_CreateObjCommand(interp, "::itk::option-parser::keep", Itk_ArchOptKeepCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore", Itk_ArchOptIgnoreCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::rename", Itk_ArchOptRenameCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::usual", Itk_ArchOptUsualCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); /* * Add the "itk::usual" command to register option handling code. */ Tcl_CreateObjCommand(interp, "::itk::usual", Itk_UsualCmd, (ClientData)mergeInfo, Itcl_ReleaseData); Itcl_PreserveData((ClientData)mergeInfo); return TCL_OK; }
void Tcl_RegisterConfig( Tcl_Interp *interp, /* Interpreter the configuration command is * registered in. */ const char *pkgName, /* Name of the package registering the * embedded configuration. ASCII, thus in * UTF-8 too. */ const Tcl_Config *configuration, /* Embedded configuration. */ const char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; QCCD *cdPtr = ckalloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { cdPtr->encoding = ckalloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); /* * Phase I: Adding the provided information to the internal database of * package meta data. * * Phase II: Create a command for querying this database, specific to the * package registering its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as * follow-up to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. * * Note, the created command will have a reference through its clientdata. */ Tcl_IncrRefCount(cdPtr->pkg); /* * For venc == NULL aka bogus encoding we skip the step setting up the * dictionaries visible at Tcl level. I.e. they are not filled */ pDB = GetConfigDict(interp); /* * Retrieve package specific configuration... */ if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK || (pkgDict == NULL)) { pkgDict = Tcl_NewDictObj(); } else if (Tcl_IsShared(pkgDict)) { pkgDict = Tcl_DuplicateObj(pkgDict); } /* * Extend the package configuration... * We cannot assume that the encodings are initialized, therefore * store the value as-is in a byte array. See Bug [9b2e636361]. */ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value))); } /* * Write the changes back into the overall database. */ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); /* * Now create the interface command for retrieval of the package * information. */ Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "::"); Tcl_DStringAppend(&cmdName, pkgName, -1); /* * The incomplete command name is the name of the namespace to place it * in. */ if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL, TCL_GLOBAL_ONLY) == NULL) { if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName), NULL, NULL) == NULL) { Tcl_Panic("%s.\n%s: %s", Tcl_GetStringResult(interp), "Tcl_RegisterConfig", "Unable to create namespace for package configuration."); } } TclDStringAppendLiteral(&cmdName, "::pkgconfig"); if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName), QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) { Tcl_Panic("%s: %s", "Tcl_RegisterConfig", "Unable to create query command for package configuration"); } Tcl_DStringFree(&cmdName); }
/* * Initialize mged, configure the path, set up the tcl interpreter. */ void mged_setup(Tcl_Interp **interpreter) { int try_auto_path = 0; int init_tcl = 1; int init_itcl = 1; struct bu_vls str = BU_VLS_INIT_ZERO; const char *name = bu_argv0_full_path(); /* locate our run-time binary (must be called before Tcl_CreateInterp()) */ if (name) { Tcl_FindExecutable(name); } else { Tcl_FindExecutable("mged"); } if (!interpreter ) { bu_log("mged_setup Error - interpreter is NULL!\n"); return; } if (*interpreter != NULL) Tcl_DeleteInterp(*interpreter); /* Create the interpreter */ *interpreter = Tcl_CreateInterp(); /* a two-pass init loop. the first pass just tries default init * routines while the second calls tclcad_auto_path() to help it * find other, potentially uninstalled, resources. */ while (1) { /* not called first time through, give Tcl_Init() a chance */ if (try_auto_path) { /* Locate the BRL-CAD-specific Tcl scripts, set the auto_path */ tclcad_auto_path(*interpreter); } /* Initialize Tcl */ Tcl_ResetResult(*interpreter); if (init_tcl && Tcl_Init(*interpreter) == TCL_ERROR) { if (!try_auto_path) { try_auto_path = 1; continue; } bu_log("Tcl_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); break; } init_tcl = 0; /* Initialize [incr Tcl] */ Tcl_ResetResult(*interpreter); /* NOTE: Calling "package require Itcl" here is apparently * insufficient without other changes elsewhere. The * Combination Editor in mged fails with an iwidgets class * already loaded error if we don't perform Itcl_Init() here. */ if (init_itcl && Itcl_Init(*interpreter) == TCL_ERROR) { if (!try_auto_path) { Tcl_Namespace *nsp; try_auto_path = 1; /* Itcl_Init() leaves initialization in a bad state * and can cause retry failures. cleanup manually. */ Tcl_DeleteCommand(*interpreter, "::itcl::class"); nsp = Tcl_FindNamespace(*interpreter, "::itcl", NULL, 0); if (nsp) Tcl_DeleteNamespace(nsp); continue; } bu_log("Itcl_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); break; } init_itcl = 0; /* don't actually want to loop forever */ break; } /* end iteration over Init() routines that need auto_path */ Tcl_ResetResult(*interpreter); /* if we haven't loaded by now, load auto_path so we find our tclscripts */ if (!try_auto_path) { /* Locate the BRL-CAD-specific Tcl scripts */ tclcad_auto_path(*interpreter); } /*XXX FIXME: Should not be importing Itcl into the global namespace */ /* Import [incr Tcl] commands into the global namespace. */ if (Tcl_Import(*interpreter, Tcl_GetGlobalNamespace(*interpreter), "::itcl::*", /* allowOverwrite */ 1) != TCL_OK) { bu_log("Tcl_Import ERROR: %s\n", Tcl_GetStringResult(*interpreter)); Tcl_ResetResult(*interpreter); } /* Initialize libbu */ if (Bu_Init(*interpreter) == TCL_ERROR) { bu_log("Bu_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); Tcl_ResetResult(*interpreter); } /* Initialize libbn */ if (Bn_Init(*interpreter) == TCL_ERROR) { bu_log("Bn_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); Tcl_ResetResult(*interpreter); } /* Initialize librt */ if (Rt_Init(*interpreter) == TCL_ERROR) { bu_log("Rt_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); Tcl_ResetResult(*interpreter); } /* Initialize libged */ if (Go_Init(*interpreter) == TCL_ERROR) { bu_log("Ged_Init ERROR:\n%s\n", Tcl_GetStringResult(*interpreter)); Tcl_ResetResult(*interpreter); } BU_ALLOC(view_state->vs_gvp, struct ged_view); ged_view_init(view_state->vs_gvp); view_state->vs_gvp->gv_callback = mged_view_callback; view_state->vs_gvp->gv_clientData = (void *)view_state; MAT_DELTAS_GET_NEG(view_state->vs_orig_pos, view_state->vs_gvp->gv_center); if (gedp) { /* release any allocated memory */ ged_free(gedp); } else { BU_ALLOC(gedp, struct ged); } GED_INIT(gedp, NULL); /* register commands */ cmd_setup(); history_setup(); mged_global_variable_setup(*interpreter); mged_variable_setup(*interpreter); /* Tcl needs to write nulls onto subscripted variable names */ bu_vls_printf(&str, "%s(state)", MGED_DISPLAY_VAR); Tcl_SetVar(*interpreter, bu_vls_addr(&str), state_str[STATE], TCL_GLOBAL_ONLY); /* Set defaults for view status variables */ bu_vls_trunc(&str, 0); bu_vls_printf(&str, "set mged_display(.topid_0.ur,ang) {ang=(0.00 0.00 0.00)};\ set mged_display(.topid_0.ur,aet) {az=35.00 el=25.00 tw=0.00};\ set mged_display(.topid_0.ur,size) sz=1000.000;\ set mged_display(.topid_0.ur,center) {cent=(0.000 0.000 0.000)};\ set mged_display(units) mm"); Tcl_Eval(*interpreter, bu_vls_addr(&str)); Tcl_ResetResult(*interpreter); bu_vls_free(&str); }
/* * ------------------------------------------------------------------------ * ItclFinishCmd() * * called when an interp is deleted to free up memory or called explicitly * to check memory leaks * * ------------------------------------------------------------------------ */ static int ItclFinishCmd( ClientData clientData, /* unused */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Namespace *nsPtr; Tcl_Obj **newObjv; Tcl_Obj *objPtr; Tcl_Obj *ensObjPtr; Tcl_Command cmdPtr; Tcl_Obj *mapDict; ItclObjectInfo *infoPtr; ItclCmdsInfo *iciPtr; int checkMemoryLeaks; int i; int result; ItclShowArgs(1, "ItclFinishCmd", objc, objv); result = TCL_OK; infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); if (infoPtr == NULL) { infoPtr = (ItclObjectInfo *)clientData; } checkMemoryLeaks = 0; if (objc > 1) { if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) { /* if we have that option, the namespace of the Tcl ensembles * is not teared down, so we have to simulate it here to * have the correct reference counts for infoPtr->infoVars2Ptr * infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr */ checkMemoryLeaks = 1; } } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2); newObjv[0] = Tcl_NewStringObj("my", -1);; for (i = 0; ;i++) { iciPtr = &itclCmds[i]; if (iciPtr->name == NULL) { break; } if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) { result = Itcl_RenameCommand(interp, iciPtr->name, ""); } else { objPtr = Tcl_NewStringObj(iciPtr->name, -1); newObjv[1] = objPtr; Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv); Tcl_DecrRefCount(objPtr); } iciPtr++; } Tcl_DecrRefCount(newObjv[0]); ckfree((char *)newObjv); /* remove the unknow handler, to free the reference to the * Tcl_Obj with the name of it */ ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1); cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG); if (cmdPtr != NULL) { Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL); } Tcl_DecrRefCount(ensObjPtr); while (1) { hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place); if (hPtr == NULL) { break; } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&infoPtr->instances); while (1) { hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place); if (hPtr == NULL) { break; } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&infoPtr->classTypes); nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } mapDict = NULL; ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1); if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) { Tcl_SetEnsembleUnknownHandler(NULL, Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG), NULL); } Tcl_DecrRefCount(ensObjPtr); /* remove the itclinfo and vars entry from the info dict */ /* and replace it by the original one */ cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) { Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict); if (mapDict != NULL) { objPtr = Tcl_NewStringObj("vars", -1); Tcl_DictObjRemove(interp, mapDict, objPtr); Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr); Tcl_DecrRefCount(objPtr); objPtr = Tcl_NewStringObj("itclinfo", -1); Tcl_DictObjRemove(interp, mapDict, objPtr); Tcl_DecrRefCount(objPtr); Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict); } } /* FIXME have to figure out why the refCount of * ::itcl::builtin::Info * and ::itcl::builtin::Info::vars and vars is 2 here !! */ /* seems to be as the tclOO commands are not yet deleted ?? */ Tcl_DecrRefCount(infoPtr->infoVars2Ptr); Tcl_DecrRefCount(infoPtr->infoVars3Ptr); Tcl_DecrRefCount(infoPtr->infoVars4Ptr); if (checkMemoryLeaks) { Tcl_DecrRefCount(infoPtr->infoVars2Ptr); Tcl_DecrRefCount(infoPtr->infoVars3Ptr); Tcl_DecrRefCount(infoPtr->infoVars4Ptr); /* see comment above */ } Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr); Tcl_EvalEx(infoPtr->interp, "::oo::define ::itcl::clazz deletemethod unknown", -1, 0); /* first have to look for the remaining memory leaks, then remove the next ifdef */ #ifdef LATER Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", ""); /* tear down ::itcl namespace (this includes ::itcl::parser namespace) */ nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::methodset", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } #endif /* remove the unknown method from top class */ if (infoPtr->unknownNamePtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownNamePtr); } if (infoPtr->unknownArgumentPtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownArgumentPtr); } if (infoPtr->unknownBodyPtr != NULL) { Tcl_DecrRefCount(infoPtr->unknownBodyPtr); } /* cleanup ensemble info */ ItclFinishEnsemble(infoPtr); ckfree((char *)infoPtr->object_meta_type); ckfree((char *)infoPtr->class_meta_type); Itcl_DeleteStack(&infoPtr->clsStack); Itcl_DeleteStack(&infoPtr->contextStack); Itcl_DeleteStack(&infoPtr->constructorStack); /* clean up list pool */ Itcl_FinishList(); Itcl_ReleaseData((ClientData)infoPtr); return result; }
static int Initialize ( Tcl_Interp *interp) { Tcl_Namespace *nsPtr; Tcl_Namespace *itclNs; Tcl_HashEntry *hPtr; Tcl_Obj *objPtr; ItclObjectInfo *infoPtr; const char * ret; char *res_option; int opt; int isNew; if (Tcl_InitStubs(interp, "8.6", 0) == NULL) { return TCL_ERROR; } ret = TclOOInitializeStubs(interp, "1.0"); if (ret == NULL) { return TCL_ERROR; } nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, NULL, NULL); if (nsPtr == NULL) { Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE); } nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::methodset", NULL, NULL); if (nsPtr == NULL) { Tcl_Panic("Itcl: cannot create namespace: \"%s::methodset\" \n", ITCL_NAMESPACE); } nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE"::internal::dicts", NULL, NULL); if (nsPtr == NULL) { Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n", ITCL_NAMESPACE); } Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::finish", ItclFinishCmd, NULL, NULL); /* for debugging only !!! */ #ifdef OBJ_REF_COUNT_DEBUG Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::dumprefcountinfo", ItclDumpRefCountInfo, NULL, NULL); #endif #ifdef ITCL_PRESERVE_DEBUG Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::dumppreserveinfo", ItclDumpPreserveInfo, NULL, NULL); #endif /* END for debugging only !!! */ Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::methodset::callCCommand", ItclCallCCommand, NULL, NULL); Tcl_CreateObjCommand(interp, ITCL_NAMESPACE"::methodset::objectUnknownCommand", ItclObjectUnknownCommand, NULL, NULL); /* * 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 = (ItclObjectInfo*)ckalloc(sizeof(ItclObjectInfo)); memset(infoPtr, 0, sizeof(ItclObjectInfo)); 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 = (Tcl_ObjectMetadataType *)ckalloc( sizeof(Tcl_ObjectMetadataType)); infoPtr->object_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT; infoPtr->object_meta_type->name = "ItclObject"; infoPtr->object_meta_type->deleteProc = ItclDeleteObjectMetadata; infoPtr->object_meta_type->cloneProc = NULL; Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS); Tcl_InitObjHashTable(&infoPtr->objectNames); 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_InitObjHashTable(&infoPtr->instances); Tcl_InitHashTable(&infoPtr->objectInstances, 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_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classes", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::objects", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classComponents", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classVariables", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classFunctions", "", 0); Tcl_SetVar(interp, ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", "", 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); Itcl_InitStack(&infoPtr->contextStack); Itcl_InitStack(&infoPtr->constructorStack); Tcl_SetAssocData(interp, ITCL_INTERP_DATA, (Tcl_InterpDeleteProc*)FreeItclObjectInfo, (ClientData)infoPtr); Itcl_PreserveData((ClientData)infoPtr); #ifdef NEW_PROTO_RESOLVER ItclVarsAndCommandResolveInit(interp); #endif /* 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"); } objPtr = Tcl_NewStringObj("::itcl::clazz", -1); infoPtr->clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr); /* work around for SF bug #254 needed because of problem in TclOO 1.0.2 !! */ if (Tcl_PkgPresent(interp, "TclOO", "1.0.2", 1) != NULL) { Itcl_IncrObjectRefCount(infoPtr->clazzObjectPtr); } Tcl_DecrRefCount(objPtr); if (infoPtr->clazzObjectPtr == NULL) { Tcl_AppendResult(interp, "ITCL: cannot get Object for ::itcl::clazz for class \"", "::itcl::clazz", "\"", NULL); return TCL_ERROR; } infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(infoPtr->clazzObjectPtr); AddClassUnknowMethod(interp, infoPtr, infoPtr->clazzClassPtr); /* * 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", (Tcl_Namespace*)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_SetVar(interp, "::itcl::version", ITCL_VERSION, TCL_NAMESPACE_ONLY); Tcl_SetVar(interp, "::itcl::patchLevel", 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); }