static void
RegisterTcpServerInterpCleanup(
Tcl_Interp *interp, /* Interpreter for which we want to be
* informed of deletion. */
AcceptCallback *acceptCallbackPtr)
/* The accept callback record whose interp
* field we want set to NULL when the
* interpreter is deleted. */
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to
* smash when the interpreter will be
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
hTblPtr = (Tcl_HashTable *)
Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
}
hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew);
if (!isNew) {
Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table");
}
Tcl_SetHashValue(hPtr, acceptCallbackPtr);
}
TkScrollbar *
TkpCreateScrollbar(
Tk_Window tkwin) /* New Tk Window. */
{
MacScrollbar * macScrollPtr;
TkWindow *winPtr = (TkWindow *)tkwin;
if (scrollActionProc == NULL) {
scrollActionProc = NewControlActionProc(ScrollbarActionProc);
thumbActionProc = NewThumbActionProc(ThumbActionProc);
}
macScrollPtr = (MacScrollbar *) ckalloc(sizeof(MacScrollbar));
macScrollPtr->sbHandle = NULL;
macScrollPtr->macFlags = 0;
Tk_CreateEventHandler(tkwin, ActivateMask|ExposureMask|
StructureNotifyMask|FocusChangeMask,
ScrollbarEventProc, (ClientData) macScrollPtr);
if (!Tcl_GetAssocData(winPtr->mainPtr->interp, "TkScrollbar", NULL)) {
Tcl_SetAssocData(winPtr->mainPtr->interp, "TkScrollbar", NULL,
(ClientData)1);
TkCreateBindingProcedure(winPtr->mainPtr->interp,
winPtr->mainPtr->bindingTable,
(ClientData)Tk_GetUid("Scrollbar"), "<ButtonPress>",
ScrollbarBindProc, NULL, NULL);
}
return (TkScrollbar *) macScrollPtr;
}
int
ItclVarsAndCommandResolveInit(
Tcl_Interp *interp)
{
#ifdef NEW_PROTO_RESOLVER
ItclResolvingInfo *iriPtr;
/*
* 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.
*/
iriPtr = (ItclResolvingInfo*)ckalloc(sizeof(ItclResolvingInfo));
memset(iriPtr, 0, sizeof(ItclResolvingInfo));
iriPtr->interp = interp;
Tcl_InitHashTable(&iriPtr->resolveVars, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->resolveCmds, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->objectVarsTables, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->objectCmdsTables, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, ITCL_RESOLVE_DATA,
(Tcl_InterpDeleteProc*)ItclDeleteResolveInfo, (ClientData)iriPtr);
Tcl_Preserve((ClientData)iriPtr);
Itcl_SetClassCommandProtectionCallback(interp, NULL,
Itcl_CheckClassCommandProtection);
Itcl_SetClassVariableProtectionCallback(interp, NULL,
Itcl_CheckClassVariableProtection);
#endif
return TCL_OK;
}
EXTERN int Pmepot_Init(Tcl_Interp *interp) {
#else
int Pmepot_Init(Tcl_Interp *interp) {
#endif
int *countptr;
countptr = (int *)malloc(sizeof(int));
Tcl_SetAssocData(interp, "Pmepot_count", count_delete_proc,
(ClientData)countptr);
*countptr = 0;
Tcl_CreateObjCommand(interp,"pmepot_create",tcl_pmepot_create,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_CreateObjCommand(interp,"pmepot_add",tcl_pmepot_add,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_CreateObjCommand(interp,"pmepot_writedx",tcl_pmepot_writedx,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_CreateObjCommand(interp,"pmepot_destroy",tcl_pmepot_destroy,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
Tcl_PkgProvide(interp, "pmepot_core", "1.0.0");
return TCL_OK;
}
/* lazily maintain 1:1 mapping between tcl and perl interpreters */
perl_context *nsperl2_get_assoc_perl_context (Tcl_Interp *interp)
{
extern perl_master_context *nsperl2_master_context;
assert (nsperl2_master_context);
perl_context *context = Tcl_GetAssocData (interp, "nsperl2:perl_context", NULL);
PerlInterpreter *perl_interp;
if(context)
return context;
Ns_Log (Notice, "cloning perl interpreter for tcl interp");
PERL_SET_CONTEXT (nsperl2_master_context->perl_master_interp);
if ((perl_interp = perl_clone (nsperl2_master_context->perl_master_interp, CLONEf_KEEP_PTR_TABLE)) == NULL) {
Ns_Log (Error, "Couldn't clone perl interp");
return NULL;
}
/* save the perl interp */
context = ns_malloc (sizeof(perl_context));
context->perl_interp = perl_interp;
Tcl_SetAssocData(interp, "nsperl2:perl_context", nsperl2_delete_assoc_perl, context);
return context;
}
int tcl_pmepot_create(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
int dims_count, dims[3], i;
Tcl_Obj **dims_list;
double ewald_factor;
char namebuf[128];
int *countptr;
pmepot_data *data;
if ( objc != 3 ) {
Tcl_SetResult(interp,"args: {na nb nc} ewald_factor",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_ListObjGetElements(interp,objv[1],&dims_count,&dims_list) != TCL_OK ) return TCL_ERROR;
if ( dims_count != 3 ) {
Tcl_SetResult(interp,"args: {na nb nc} ewald_factor",TCL_VOLATILE);
return TCL_ERROR;
}
for ( i=0; i<3; ++i ) {
if ( Tcl_GetIntFromObj(interp,dims_list[i],&dims[i]) != TCL_OK ) return TCL_ERROR;
if ( dims[i] < 8 ) {
Tcl_SetResult(interp,"each grid dimension must be at least 8",TCL_VOLATILE);
return TCL_ERROR;
}
}
if ( dims[2] % 2 ) {
Tcl_SetResult(interp,"third grid dimension must be even",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_GetDoubleFromObj(interp,objv[2],&ewald_factor) != TCL_OK ) {
return TCL_ERROR;
}
if ( ewald_factor <= 0. ) {
Tcl_SetResult(interp,"ewald factor must be positive",TCL_VOLATILE);
return TCL_ERROR;
}
countptr = Tcl_GetAssocData(interp, "Pmepot_count", 0);
if ( ! countptr ) {
Tcl_SetResult(interp,"Pmepot bug: Pmepot_count not initialized.",TCL_VOLATILE);
return TCL_ERROR;
}
data = pmepot_create(dims, ewald_factor);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: pmepot_create failed.",TCL_VOLATILE);
return TCL_ERROR;
}
sprintf(namebuf,"Pmepot_%d",*countptr);
Tcl_SetAssocData(interp,namebuf,pmepot_deleteproc,(ClientData)data);
*countptr += 1;
Tcl_SetResult(interp,namebuf,TCL_VOLATILE);
return TCL_OK;
}
HandleNameToRepMap::HandleNameToRepMap (Tcl_Interp *interp):
m_interp(interp)
{
Tcl_InitHashTable(&m_handleMap, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, ASSOC_KEY, deleteInterpProc, this);
Tcl_CreateExitHandler(exitProc, this);
}
static NSVGcache *
GetCachePtr(
Tcl_Interp *interp
) {
NSVGcache *cachePtr = Tcl_GetAssocData(interp, "tksvgnano", NULL);
if (cachePtr == NULL) {
cachePtr = ckalloc(sizeof(NSVGcache));
cachePtr->dataOrChan = NULL;
Tcl_DStringInit(&cachePtr->formatString);
cachePtr->nsvgImage = NULL;
Tcl_SetAssocData(interp, "tksvgnano", FreeCache, cachePtr);
}
return cachePtr;
}
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
Tcl_Obj *pDB = Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
Tcl_IncrRefCount(pDB);
Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
}
return pDB;
}
static int
NsThread_Init (Tcl_Interp *interp, void *cd)
{
struct mydata *md = (struct mydata*)cd;
int ret = Thread_Init(interp);
if (ret != TCL_OK) {
Ns_Log(Warning, "can't load module %s: %s", md->modname,
Tcl_GetStringResult(interp));
return TCL_ERROR;
}
Tcl_SetAssocData(interp, "thread:nsd", NULL, (ClientData)md);
return TCL_OK;
}
/* GetCursorManager --
* Look up and create if necessary the interp's cursor manager.
*/
static CursorManager *GetCursorManager(Tcl_Interp *interp)
{
static const char *cm_key = "ttk::CursorManager";
CursorManager *cm = (CursorManager *) Tcl_GetAssocData(interp, cm_key,0);
if (!cm) {
cm = (CursorManager*)ckalloc(sizeof(*cm));
cm->timer = 0;
cm->owner = 0;
cm->onTime = DEF_CURSOR_ON_TIME;
cm->offTime = DEF_CURSOR_OFF_TIME;
Tcl_SetAssocData(interp,cm_key,CursorManagerDeleteProc,(ClientData)cm);
}
return cm;
}
/*
* ------------------------------------------------------------------------
* ItkGetObjsWithArchInfo()
*
* Returns a pointer to a hash table containing the list of registered
* objects in the specified interpreter. If the hash table does not
* already exist, it is created.
* ------------------------------------------------------------------------
*/
Tcl_HashTable*
ItkGetObjsWithArchInfo(
Tcl_Interp *interp) /* interpreter handling this registration */
{
Tcl_HashTable* objTable;
/*
* If the registration table does not yet exist, then create it.
*/
objTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
"itk_objsWithArchInfo", (Tcl_InterpDeleteProc**)NULL);
if (!objTable) {
objTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(objTable, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "itk_objsWithArchInfo",
ItkFreeObjsWithArchInfo, (ClientData)objTable);
}
return objTable;
}
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);
}
int
TclObjTest_Init(
Tcl_Interp *interp)
{
register int i;
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
* Tcl_Obj *.
*/
Tcl_Obj **varPtr;
varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
if (!varPtr) {
return TCL_ERROR;
}
Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
Tcl_CreateObjCommand(interp, "testbignumobj", TestbignumobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
NULL, NULL);
return TCL_OK;
}
int
Tcl_RecordAndEvalObj(
Tcl_Interp *interp, /* Token for interpreter in which command will
* be executed. */
Tcl_Obj *cmdPtr, /* Points to object holding the command to
* record and execute. */
int flags) /* Additional flags. TCL_NO_EVAL means record
* only: don't execute the command.
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = Tcl_Alloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
Tcl_IncrRefCount(histObjsPtr->addObj);
Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
histObjsPtr);
}
/*
* Do not call [history] if it has been replaced by an empty proc
*/
result = Tcl_GetCommandInfo(interp, "::history", &info);
if (result && (info.deleteProc == TclProcDeleteProc)) {
Proc *procPtr = (Proc *) info.objClientData;
call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
}
if (call) {
Tcl_Obj *list[3];
/*
* Do recording by eval'ing a tcl history command: history add $cmd.
*/
list[0] = histObjsPtr->historyObj;
list[1] = histObjsPtr->addObj;
list[2] = cmdPtr;
Tcl_IncrRefCount(cmdPtr);
(void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
/*
* One possible failure mode above: exceeding a resource limit.
*/
if (Tcl_LimitExceeded(interp)) {
return TCL_ERROR;
}
}
/*
* Execute the command.
*/
result = TCL_OK;
if (!(flags & TCL_NO_EVAL)) {
result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
}
return result;
}
TclTextInterp::TclTextInterp(VMDApp *vmdapp, int guienabled, int mpienabled)
: app(vmdapp) {
interp = Tcl_CreateInterp();
#if 0
Tcl_InitMemory(interp); // enable Tcl memory debugging features
// when compiled with TCL_MEM_DEBUG
#endif
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
consoleisatty = vmd_isatty(0); // whether we're interactive or not
ignorestdin = 0;
gotPartial = 0;
needPrompt = 1;
callLevel = 0;
starttime = delay = 0;
#if defined(VMDMPI)
//
// MPI builds of VMD cannot try to read any command input from the
// console because it creates shutdown problems, at least with MPICH.
// File-based command input is fine however.
//
// don't check for interactive console input if running in parallel
if (mpienabled)
ignorestdin = 1;
#endif
#if defined(ANDROIDARMV7A)
//
// For the time being, the Android builds won't attempt to get any
// console input. Any input we're going to get is going to come via
// some means other than stdin, such as a network socket, text box, etc.
//
// Don't check for interactive console input if compiled for Android
ignorestdin = 1;
#endif
// set tcl_interactive, lets us run unix commands as from a shell
#if !defined(VMD_NANOHUB)
Tcl_SetVar(interp, "tcl_interactive", "1", 0);
#else
Tcl_SetVar(interp, "tcl_interactive", "0", 0);
Tcl_Channel channel;
#define CLIENT_READ (3)
#define CLIENT_WRITE (4)
channel = Tcl_MakeFileChannel((ClientData)CLIENT_READ, TCL_READABLE);
if (channel != NULL) {
const char *result;
Tcl_RegisterChannel(interp, channel);
result = Tcl_SetVar2(interp, "vmd_client", "read",
Tcl_GetChannelName(channel),
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
if (result == NULL) {
fprintf(stderr, "can't create variable for client read channel\n");
}
}
channel = Tcl_MakeFileChannel((ClientData)CLIENT_WRITE, TCL_WRITABLE);
if (channel != NULL) {
const char *result;
Tcl_RegisterChannel(interp, channel);
result = Tcl_SetVar2(interp, "vmd_client", "write",
Tcl_GetChannelName(channel),
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
if (result == NULL) {
fprintf(stderr, "can't create variable for client write channel\n");
}
}
write(CLIENT_WRITE, "vmd 1.0\n", 8);
#endif
// pass our instance of VMDApp to a hash table assoc. with the interpreter
Tcl_SetAssocData(interp, "VMDApp", NULL, app);
// Set up argc, argv0, and argv variables
{
char argcbuf[20];
sprintf(argcbuf, "%d", app->argc_m);
Tcl_SetVar(interp, "argc", argcbuf, TCL_GLOBAL_ONLY);
// it might be better to use the same thing that was passed to
// Tcl_FindExecutable, but this is now
Tcl_SetVar(interp, "argv0", app->argv_m[0], TCL_GLOBAL_ONLY);
char *args = Tcl_Merge(app->argc_m-1, app->argv_m+1);
Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
}
#if defined(_MSC_VER) && TCL_MINOR_VERSION >= 4
// The Windows versions of Tcl 8.5.x have trouble finding
// the Tcl library subdirectory for unknown reasons.
// We force the appropriate env variables to be set in Tcl,
// despite Windows.
{
char vmdinitscript[4096];
char * tcl_library = getenv("TCL_LIBRARY");
char * tk_library = getenv("TK_LIBRARY");
if (tcl_library) {
sprintf(vmdinitscript, "set env(TCL_LIBRARY) {%s}", tcl_library);
if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) {
msgErr << Tcl_GetStringResult(interp) << sendmsg;
}
}
if (tk_library) {
sprintf(vmdinitscript, "set env(TK_LIBRARY) {%s}", tk_library);
if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) {
msgErr << Tcl_GetStringResult(interp) << sendmsg;
}
}
}
#endif
if (Tcl_Init(interp) == TCL_ERROR) { // new with 7.6
msgErr << "Tcl startup error: " << Tcl_GetStringResult(interp) << sendmsg;
}
#ifdef VMDTK
// and the Tk commands (but only if a GUI is available!)
if (guienabled) {
if (Tk_Init(interp) == TCL_ERROR) {
msgErr << "Tk startup error: " << Tcl_GetStringResult(interp) << sendmsg;
} else {
Tcl_StaticPackage(interp, "Tk",
(Tcl_PackageInitProc *) Tk_Init,
(Tcl_PackageInitProc *) NULL);
}
} // end of check that GUI is allowed
#endif
add_commands();
}
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);
}
const char *
Tk_SetAppName(
Tk_Window tkwin, /* Token for any window in the application to
* be named: it is just used to identify the
* application and the display. */
const char *name) /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
{
#ifndef TK_SEND_ENABLED_ON_WINDOWS
/*
* Temporarily disabled for bug #858822
*/
return name;
#else /* TK_SEND_ENABLED_ON_WINDOWS */
ThreadSpecificData *tsdPtr = NULL;
TkWindow *winPtr = (TkWindow *) tkwin;
RegisteredInterp *riPtr = NULL;
Tcl_Interp *interp;
HRESULT hr = S_OK;
interp = winPtr->mainPtr->interp;
tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
/*
* Initialise the COM library for this interpreter just once.
*/
if (tsdPtr->initialized == 0) {
hr = CoInitialize(0);
if (FAILED(hr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"failed to initialize the COM library", -1));
Tcl_SetErrorCode(interp, "TK", "SEND", "COM", NULL);
return "";
}
tsdPtr->initialized = 1;
TRACE("Initialized COM library for interp 0x%08X\n", (long)interp);
}
/*
* If the interp hasn't been registered before then we need to create the
* registration structure and the COM object. If it has been registered
* already then we can reuse all and just register the new name.
*/
riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL);
if (riPtr == NULL) {
LPUNKNOWN *objPtr;
riPtr = ckalloc(sizeof(RegisteredInterp));
memset(riPtr, 0, sizeof(RegisteredInterp));
riPtr->interp = interp;
objPtr = &riPtr->obj;
hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
(void **) objPtr);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr,
CmdDeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr);
} else {
RevokeObjectRegistration(riPtr);
}
RegisterInterp(name, riPtr);
return (const char *) riPtr->name;
#endif /* TK_SEND_ENABLED_ON_WINDOWS */
}
/* ARGSUSED */
int
Tcl_AfterObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType
#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
|| (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
&index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
}
}
/*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
*/
switch (index) {
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
/*
* The variable below is used to generate unique identifiers for after
* commands. This id can wrap around, which can potentially cause
* problems. However, there are not likely to be problems in practice,
* because after commands can only be requested to about a month in
* the future, and wrap-around is unlikely to occur in less than about
* 1-10 years. Thus it's unlikely that any old ids will still be
* around when wrap-around occurs.
*/
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
Tcl_GetTime(&wakeup);
wakeup.sec += (long)(ms / 1000);
wakeup.usec += ((long)(ms % 1000)) * 1000;
if (wakeup.usec > 1000000) {
wakeup.sec++;
wakeup.usec -= 1000000;
}
afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
AfterProc, afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, (unsigned) length)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
Tcl_DecrRefCount(commandPtr);
}
if (afterPtr != NULL) {
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
FreeAfterPtr(afterPtr);
}
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
case AFTER_INFO:
if (objc == 2) {
Tcl_Obj *resultObj = Tcl_NewObj();
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
static Tk_ConfigSpec *
GetCachedSpecs(
Tcl_Interp *interp, /* Interpreter in which to store the cache. */
const Tk_ConfigSpec *staticSpecs)
/* Value to cache a copy of; it is also used
* as a key into the cache. */
{
Tk_ConfigSpec *cachedSpecs;
Tcl_HashTable *specCacheTablePtr;
Tcl_HashEntry *entryPtr;
int isNew;
/*
* Get (or allocate if it doesn't exist) the hash table that the writable
* copies of the widget specs are stored in. In effect, this is
* self-initializing code.
*/
specCacheTablePtr = (Tcl_HashTable *)
Tcl_GetAssocData(interp, "tkConfigSpec.threadTable", NULL);
if (specCacheTablePtr == NULL) {
specCacheTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(specCacheTablePtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tkConfigSpec.threadTable",
DeleteSpecCacheTable, (ClientData) specCacheTablePtr);
}
/*
* Look up or create the hash entry that the constant specs are mapped to,
* which will have the writable specs as its associated value.
*/
entryPtr = Tcl_CreateHashEntry(specCacheTablePtr, (char *) staticSpecs,
&isNew);
if (isNew) {
unsigned int entrySpace = sizeof(Tk_ConfigSpec);
const Tk_ConfigSpec *staticSpecPtr;
Tk_ConfigSpec *specPtr;
/*
* OK, no working copy in this interpreter so copy. Need to work out
* how much space to allocate first.
*/
for (staticSpecPtr=staticSpecs; staticSpecPtr->type!=TK_CONFIG_END;
staticSpecPtr++) {
entrySpace += sizeof(Tk_ConfigSpec);
}
/*
* Now allocate our working copy's space and copy over the contents
* from the master copy.
*/
cachedSpecs = (Tk_ConfigSpec *) ckalloc(entrySpace);
memcpy(cachedSpecs, staticSpecs, entrySpace);
Tcl_SetHashValue(entryPtr, (ClientData) cachedSpecs);
/*
* Finally, go through and replace database names, database classes
* and default values with Tk_Uids. This is the bit that has to be
* per-thread.
*/
for (specPtr=cachedSpecs; specPtr->type!=TK_CONFIG_END; specPtr++) {
if (specPtr->argvName != NULL) {
if (specPtr->dbName != NULL) {
specPtr->dbName = Tk_GetUid(specPtr->dbName);
}
if (specPtr->dbClass != NULL) {
specPtr->dbClass = Tk_GetUid(specPtr->dbClass);
}
if (specPtr->defValue != NULL) {
specPtr->defValue = Tk_GetUid(specPtr->defValue);
}
}
specPtr->specFlags &= ~TK_CONFIG_OPTION_SPECIFIED;
}
} else {
cachedSpecs = (Tk_ConfigSpec *) Tcl_GetHashValue(entryPtr);
}
return cachedSpecs;
}