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;
}
static int
Ta4r_CommonInit (Tcl_Interp *interp) {
if (Tcl_InitStubs (interp, MIN_TCL_VERSION, 0) == NULL) { return TCL_ERROR; }
if (Tcl_PkgRequire (interp, "Tcl", MIN_TCL_VERSION, 0) == NULL) { return TCL_ERROR; }
if (Tcl_CreateNamespace (interp, Ta4r, NULL, NULL) == NULL) { return TCL_ERROR; }
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;
}
int
Tclf_Init(Tcl_Interp *interp)
{ // Инициализация библиотеки
const char *version;
if ((version=Tcl_InitStubs(interp,TCL_VERSION,1))==NULL) {
fprintf(stderr,"Tcl_InitStubs failed for %s\n",TCL_VERSION);
return TCL_ERROR;
}
// создание namespace
packageNamespace=Tcl_CreateNamespace(interp,packageNsName,NULL,NULL);
if (packageNamespace==NULL) {
ERR("in Tcl_CreateNamespace");
return TCL_ERROR;
}
// создание типов, объектов и констант делается раз и навсегда
if (nrOfInstances==0) {
if (initTupleSubsys(interp)!=TCL_OK) {
ERR("on Tuple init");
return TCL_ERROR;
}
if (initFuncSubsys(interp)!=TCL_OK) {
ERR("on Func init");
return TCL_ERROR;
}
if (initLazySubsys(interp)!=TCL_OK) {
ERR("on Lazy init");
return TCL_ERROR;
}
nrOfInstances++;
if (resolveTypes(interp)!=TCL_OK) {
ERR("resolve types");
return TCL_ERROR;
}
if (installConsts(interp,constTable)!=TCL_OK) {
ERR("install consts");
return TCL_ERROR;
}
}
// а вот команды разные у каждого интерпретатора
if (resolveCommands(interp,resolveTable)!=TCL_OK) {
ERR("resolve commands");
return TCL_ERROR;
}
if (installCommands(interp,installTable)!=TCL_OK) {
ERR("install commands");
return TCL_ERROR;
}
if (initFuncInstance(interp,packageNamespace)!=TCL_OK)
return TCL_ERROR;
if (initLazyInstance(interp,packageNamespace)!=TCL_OK)
return TCL_ERROR;
return TCL_OK;
}
static int
NsPerl2InitInterp(Tcl_Interp *interp, void *context)
{
Tcl_Namespace *nsPtr;
nsPtr = Tcl_CreateNamespace(interp, "perl", NULL, NULL);
if(!nsPtr)
return TCL_ERROR;
Tcl_CreateObjCommand(interp,"perl::call",NsPerl2CallCmd, NULL, NULL);
Tcl_PkgProvide(interp, "nsperl2", "0.1");
return TCL_OK;
}
extern "C" int DLLEXPORT
Perft_Init(Tcl_Interp *interp)
{
int retval;
/*
* create namespace for our commands
*/
Tcl_Namespace *nameSpace = Tcl_CreateNamespace(interp, "perft", NULL, NULL);
/*
* tell Tcl to grab all subcommands on import
*/
retval=Tcl_Export(interp, nameSpace, "*", 0);
if(retval) {
cerr<<"Error exporting commands\n";
return 1;
}
/*
* create the subcommands
*/
Tcl_CreateObjCommand(interp, "perft::available_events",ListEventsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "perft::init", InitCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "perft::run_file", RunFileCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "perft::run_script", RunScriptCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "perft::select_events", SelectEventsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "perft::counters", HwInfoCmd, NULL, NULL);
/*
* create the ensemble
*/
Tcl_CreateEnsemble(interp, "perft", nameSpace, 0);
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
TclpSetVariables(
Tcl_Interp *interp)
{
#ifndef NO_UNAME
struct utsname name;
#endif
int unameOK;
Tcl_DString ds;
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
#if MAC_OS_X_VERSION_MAX_ALLOWED > 1020
/*
* Set msgcat fallback locale to current CFLocale identifier.
*/
CFLocaleRef localeRef;
if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL &&
(localeRef = CFLocaleCopyCurrent())) {
CFStringRef locale = CFLocaleGetIdentifier(localeRef);
if (locale) {
char loc[256];
if (CFStringGetCString(locale, loc, 256, kCFStringEncodingUTF8)) {
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY);
}
}
CFRelease(localeRef);
}
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED > 1020 */
if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
CONST char *str;
CFBundleRef bundleRef;
Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
if ((str != NULL) && (str[0] != '\0')) {
char *p = Tcl_DStringValue(&ds);
/*
* Convert DYLD_FRAMEWORK_PATH from colon to space separated.
*/
do {
if (*p == ':') {
*p = ' ';
}
} while (*p++);
Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_DStringFree(&ds);
}
bundleRef = CFBundleGetMainBundle();
if (bundleRef) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
}
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifndef NO_UNAME
if (uname(&name) >= 0) {
CONST char *native;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* The following code is a special hack to handle differences in the
* way version information is returned by uname. On most systems the
* full version number is available in name.release. However, under
* AIX the major version number is in name.version and the minor
* version number is in name.release.
*/
if ((strchr(name.release, '.') != NULL)
|| !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
} else {
#ifdef DJGPP
/*
* For some obscure reason DJGPP puts major version into
* name.release and minor into name.version. As of DJGPP 2.04 this
* is documented in djgpp libc.info file.
*/
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#else
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#endif /* DJGPP */
}
Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine,
TCL_GLOBAL_ONLY);
}
#endif /* !NO_UNAME */
if (!unameOK) {
Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
}
/*
* Copy the username of the real user (according to getuid()) into
* tcl_platform(user).
*/
{
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds);
}
Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
}
}
static int
Initialize (
Tcl_Interp *interp)
{
Tcl_Namespace *nsPtr;
ItclObjectInfo *infoPtr;
if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
return TCL_ERROR;
}
if (Tk_InitStubs(interp, "8.6", 0) == NULL) {
return TCL_ERROR;
}
if (Itcl_InitStubs(interp, "4.0.0", 0) == NULL) {
return TCL_ERROR;
}
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
nsPtr = Tcl_CreateNamespace(interp, "::itcl::widget", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", "::itcl::widget");
}
nsPtr = Tcl_CreateNamespace(interp, ITCL_WIDGETS_NAMESPACE, NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n",
"::itcl::widget::internal");
}
#if 0 /* This doesn't compile ???? */
infoPtr->windgetInfoPtr = (ItclWidgetInfo *)ckalloc(sizeof(ItclWidgetInfo));
infoPtr->windgetInfoPtr->initObjectOpts = ItclWidgetInitObjectOptions;
infoPtr->windgetInfoPtr->hullAndOptsInst = HullAndOptionsInstall;
infoPtr->windgetInfoPtr->delegationInst = DelegationInstall;
infoPtr->windgetInfoPtr->componentInst = InstallComponent;
#endif
/*
* Create "itcl::builtin" namespace for commands that
* are automatically built into class definitions.
*/
if (Itcl_WidgetBiInit(interp, infoPtr) != TCL_OK) {
return TCL_ERROR;
}
if (ItclWidgetInfoInit(interp, infoPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Set up the variables containing version info.
*/
Tcl_SetVar(interp, "::itcl::widget::version", ITCL_VERSION, TCL_NAMESPACE_ONLY);
Tcl_SetVar(interp, "::itcl::widget::patchLevel", ITCL_PATCH_LEVEL,
TCL_NAMESPACE_ONLY);
/*
* Package is now loaded.
*/
return Tcl_PkgProvide(interp, "itclwidget", ITCL_PATCH_LEVEL);
}
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);
}
int Twapi_base_Init(Tcl_Interp *interp)
{
TwapiInterpContext *ticP;
HRESULT hr;
/* IMPORTANT */
/* MUST BE FIRST CALL as it initializes Tcl stubs - should this be the
done for EVERY interp creation or move into one-time above ? TBD
*/
/* TBD dgp says this #ifdef USE_TCL_STUBS is not needed and indeed
that seems to be the case for Tcl_InitStubs. But Tcl_TomMath_InitStubs
crashes on a static build not using stubs
*/
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_TomMath_InitStubs(interp, 0) == NULL) {
return TCL_ERROR;
}
#endif
/* Init unless already done. */
if (! TwapiDoOneTimeInit(&gTwapiInitialized, TwapiOneTimeInit, interp))
return TCL_ERROR;
/* NOTE: no point setting Tcl_SetResult for errors as they are not
looked at when DLL is being loaded */
/*
* Per interp initialization
*/
if (TwapiTlsInit() != TCL_OK)
return TCL_ERROR;
/*
* Single-threaded COM model - note some Shell extensions
* require this if functions such as ShellExecute are
* invoked. TBD - should we do this lazily in com and mstask modules ?
*
* TBD - recent MSDN docs states:
* "Avoid the COM single-threaded apartment model, as it is incompatible
* with the thread pool. STA creates thread state which can affect the
* next work item for the thread. STA is generally long-lived and has
* thread affinity, which is the opposite of the thread pool."
* Since we use thread pools, does this mean we should not be
* using STA? Or does that only apply when making COM calls from
* a thread pool thread in which case it would not apply to us?
*/
hr = CoInitializeEx(
NULL, COINIT_APARTMENTTHREADED | COINIT_DISABLE_OLE1DDE);
if (hr != S_OK && hr != S_FALSE)
return TCL_ERROR;
/* Create the name space and some variables. Not sure if this is explicitly needed */
Tcl_CreateNamespace(interp, "::twapi", NULL, NULL);
Tcl_SetVar2(interp, "::twapi::version", MODULENAME, MODULEVERSION, 0);
Tcl_SetVar2(interp, "::twapi::settings", "log_limit", "100", 0);
Tcl_LinkVar(interp, "::twapi::settings(use_unicode_obj)", (char *)&gBaseSettings.use_unicode_obj, TCL_LINK_ULONG);
/* Allocate a context that will be passed around in all interpreters */
ticP = TwapiRegisterModule(interp, gTwapiModuleHandle, &gBaseModule, NEW_TIC);
if (ticP == NULL)
return TCL_ERROR;
ticP->module.data.pval = TwapiAlloc(sizeof(TwapiBaseSpecificContext));
/* Cache of commonly used objects */
Tcl_InitHashTable(&BASE_CONTEXT(ticP)->atoms, TCL_STRING_KEYS);
/* Pointer registration table */
Tcl_InitHashTable(&BASE_CONTEXT(ticP)->pointers, TCL_ONE_WORD_KEYS);
/* Trap stack */
BASE_CONTEXT(ticP)->trapstack = ObjNewList(0, NULL);
ObjIncrRefs(BASE_CONTEXT(ticP)->trapstack);
Tcl_CallWhenDeleted(interp, Twapi_InterpCleanup, NULL);
return TwapiLoadStaticModules(interp);
}
int Tkpath_Init(Tcl_Interp *interp) /* Tcl interpreter. */
{
#if defined(USE_TCL_STUBS)
if (Tcl_InitStubs(interp, TKPATH_REQUIRE, 0) == NULL) {
return TCL_ERROR;
}
#endif
if (Tcl_PkgRequire(interp, "Tcl", TKPATH_REQUIRE, 0) == NULL) {
return TCL_ERROR;
}
#if defined(USE_TK_STUBS)
if (Tk_InitStubs(interp, TKPATH_REQUIRE, 0) == NULL) {
return TCL_ERROR;
}
#endif
if (Tcl_PkgRequire(interp, "Tk", TKPATH_REQUIRE, 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_CreateNamespace(interp, "::tkp", NULL, NULL) == NULL) {
Tcl_ResetResult(interp);
}
Tcl_CreateObjCommand(interp, "::tkp::canvas", Tk_PathCanvasObjCmd,
(ClientData) Tk_MainWindow(interp), NULL);
gInterp = interp;
/*
* Link the ::tkp::antialias variable to control antialiasing.
*/
if (Tcl_LinkVar(interp, "::tkp::antialias",
(char *) &gAntiAlias, TCL_LINK_BOOLEAN) != TCL_OK) {
Tcl_ResetResult(interp);
}
/*
* With gSurfaceCopyPremultiplyAlpha true we ignore the "premultiply alpha"
* and use RGB as is. Else we need to divide each RGB with alpha
* to get "true" values.
*/
if (Tcl_LinkVar(interp, "::tkp::premultiplyalpha",
(char *) &gSurfaceCopyPremultiplyAlpha, TCL_LINK_BOOLEAN) != TCL_OK) {
Tcl_ResetResult(interp);
}
if (Tcl_LinkVar(interp, "::tkp::depixelize",
(char *) &gDepixelize, TCL_LINK_BOOLEAN) != TCL_OK) {
Tcl_ResetResult(interp);
}
Tcl_CreateObjCommand(interp, "::tkp::pixelalign",
PixelAlignObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
/*
* Make separate gradient objects, similar to SVG.
*/
PathGradientInit(interp);
SurfaceInit(interp);
/*
* Style object.
*/
PathStyleInit(interp);
return Tcl_PkgProvide(interp, "tkpath", TKPATH_PATCHLEVEL);
}
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);
}
