int Dbus_Init(Tcl_Interp *interp)
{
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgRequire(interp, "Tcl", "8.5", 0) == NULL) {
return TCL_ERROR;
}
Tcl_MutexLock(&dbusMutex);
if (!initialized) {
Tcl_InitObjHashTable(&bus);
Tcl_CreateEventSource(DBus_SetupProc, DBus_CheckProc, interp);
initialized = TRUE;
}
Tcl_MutexUnlock(&dbusMutex);
TclInitDBusCmd(interp);
/* Provide the historical name for compatibility */
Tcl_PkgProvide(interp, "dbus-tcl", PACKAGE_VERSION);
return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
}
void
TclSetupEnv(
Tcl_Interp *interp) /* Interpreter whose "env" array is to be
* managed. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj *varNamePtr;
Tcl_DString envString;
Tcl_HashTable namesHash;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* Synchronize the values in the environ array with the contents of the
* Tcl "env" variable. To do this:
* 1) Remove the trace that fires when the "env" var is updated.
* 2) Find the existing contents of the "env", storing in a hash table.
* 3) Create/update elements for each environ variable, removing
* elements from the hash table as we go.
* 4) Remove the elements for each remaining entry in the hash table,
* which must have existed before yet have no analog in the environ
* variable.
* 5) Add a trace that synchronizes the "env" array.
*/
Tcl_UntraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
/*
* Find out what elements are currently in the global env array.
*/
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
if (environ[0] != NULL) {
int i;
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
Tcl_Obj *obj1, *obj2;
char *p1, *p2;
p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
p2 = strchr(p1, '=');
if (p2 == NULL) {
/*
* This condition seem to happen occasionally under some
* versions of Solaris, or when encoding accidents swallow the
* '='; ignore the entry.
*/
continue;
}
p2++;
p2[-1] = '\0';
obj1 = Tcl_NewStringObj(p1, -1);
obj2 = Tcl_NewStringObj(p2, -1);
Tcl_DStringFree(&envString);
Tcl_IncrRefCount(obj1);
Tcl_IncrRefCount(obj2);
Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
hPtr = Tcl_FindHashEntry(&namesHash, obj1);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DecrRefCount(obj1);
Tcl_DecrRefCount(obj2);
}
Tcl_MutexUnlock(&envMutex);
}
/*
* Delete those elements that existed in the array but which had no
* counterparts in the environment array.
*/
for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
Tcl_Obj *elemName = Tcl_GetHashValue(hPtr);
TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
}
Tcl_DeleteHashTable(&namesHash);
Tcl_DecrRefCount(varNamePtr);
/*
* Re-establish the trace.
*/
Tcl_TraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
}
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);
}
