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);
}
ClientData
Itcl_RegisterClassCommand(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr,
const char *cmdName,
ClientData clientData)
{
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
ItclResolvingInfo *iriPtr;
int isNew;
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_CreateHashEntry(&iriPtr->resolveCmds, nsPtr->fullName, &isNew);
if (isNew) {
tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, tablePtr);
} else {
tablePtr = Tcl_GetHashValue(hPtr);
}
hPtr = Tcl_CreateHashEntry(tablePtr, cmdName, &isNew);
if (isNew) {
Tcl_SetHashValue(hPtr, clientData);
}
return Tcl_GetHashValue(hPtr);
}
int tcl_pmepot_writedx(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
pmepot_data *data;
Tcl_DString fstring;
char *fname;
if ( objc != 3 ) {
Tcl_SetResult(interp,"args: handle filename",TCL_VOLATILE);
return TCL_ERROR;
}
data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
return TCL_ERROR;
}
fname = Tcl_TranslateFileName(interp,Tcl_GetString(objv[2]),&fstring);
if ( 0 == fname ) {
return TCL_ERROR;
}
if ( pmepot_writedx(data,fname) ) {
Tcl_DStringFree(&fstring);
Tcl_SetResult(interp,"Pmepot bug: unable to write file.",TCL_VOLATILE);
return TCL_ERROR;
}
Tcl_DStringFree(&fstring);
return TCL_OK;
}
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;
}
/* 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;
}
int tcl_pmepot_add(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
int cell_count, atom_count, sub_count, i, j;
Tcl_Obj **cell_list, **atom_list, **sub_list;
float cell[12], *atoms;
double d;
pmepot_data *data;
if ( objc != 4 ) {
Tcl_SetResult(interp,"args: handle {{o...} {a...} {b...} {c...}} {{x y z q}...}",TCL_VOLATILE);
return TCL_ERROR;
}
data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_ListObjGetElements(interp,objv[2],&cell_count,&cell_list) != TCL_OK ) return TCL_ERROR;
if ( cell_count != 4 ) {
Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
return TCL_ERROR;
}
for ( i=0; i<4; ++i ) {
if ( Tcl_ListObjGetElements(interp,cell_list[i],&sub_count,&sub_list) != TCL_OK ) return TCL_ERROR;
if ( sub_count != 3 ) {
Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
return TCL_ERROR;
}
for ( j=0; j<3; ++j ) {
if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) return TCL_ERROR;
cell[3*i+j] = d;
}
}
if ( Tcl_ListObjGetElements(interp,objv[3],&atom_count,&atom_list) != TCL_OK ) return TCL_ERROR;
atoms = malloc(atom_count*4*sizeof(float));
for ( i=0; i<atom_count; ++i ) {
if ( Tcl_ListObjGetElements(interp,atom_list[i],&sub_count,&sub_list) != TCL_OK ) { free(atoms); return TCL_ERROR; }
if ( sub_count != 4 ) {
Tcl_SetResult(interp,"atoms format: {{x y z q}...}",TCL_VOLATILE);
free(atoms); return TCL_ERROR;
}
for ( j=0; j<4; ++j ) {
if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) { free(atoms); return TCL_ERROR; }
atoms[4*i+j] = d;
}
}
if ( pmepot_add(data,cell,atom_count,atoms) ) {
Tcl_SetResult(interp,"Pmepot bug: pmepot_add failed.",TCL_VOLATILE);
free(atoms);
return TCL_ERROR;
}
free(atoms);
return TCL_OK;
}
int
ItclCallCCommand(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_CmdProc *argProc;
Tcl_ObjCmdProc *objProc;
ClientData cData;
int result;
ItclShowArgs(2, "ItclCallCCommand", objc, objv);
if (!Itcl_FindC(interp, Tcl_GetString(objv[1])+1, &argProc,
&objProc, &cData)) {
Tcl_AppendResult(interp, "no such registered C command 1: \"",
Tcl_GetString(objv[1]), "\"", NULL);
return TCL_ERROR;
}
if ((argProc == NULL) && (objProc == NULL)) {
Tcl_AppendResult(interp, "no such registered C command 2: \"",
Tcl_GetString(objv[1]), "\"", NULL);
return TCL_ERROR;
}
result = TCL_ERROR;
if (argProc != NULL) {
const char **argv;
int i;
argv = (const char**)ckalloc((unsigned)((objc-1)*sizeof(char*)));
for (i=2;i<objc;i++) {
argv[i-2] = Tcl_GetString(objv[i]);
}
result = (*argProc)(cData, interp, objc-2, argv);
ckfree((char*)argv);
}
if (objProc != NULL) {
#ifdef FIXED_ITCL_CALL_CONTEXT
Tcl_Namespace *callerNsPtr;
ItclObjectInfo *infoPtr;
callerNsPtr = Itcl_GetUplevelNamespace(interp, 1);
ItclShowArgs(2, "CARGS", Itcl_GetCallFrameObjc(interp),
Itcl_GetCallFrameObjv(interp));
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
/* FIXME have to use ItclCallContext here !!! */
/* Itcl_PushStack(callerNsPtr, &infoPtr->namespaceStack); */
#endif
result = (*objProc)(cData, interp, Itcl_GetCallFrameObjc(interp)-1,
Itcl_GetCallFrameObjv(interp)+1);
#ifdef FIXED_ITCL_CALL_CONTEXT
/* Itcl_PopStack(&infoPtr->namespaceStack); */
#endif
}
return result;
}
int
Itcl_SetClassCommandProtectionCallback(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr,
ItclCheckClassProtection *fcnPtr)
{
ItclResolvingInfo *iriPtr;
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
iriPtr->cmdProtFcn = fcnPtr;
return TCL_OK;
}
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 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;
}
/* 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;
}
int tcl_pmepot_destroy(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
pmepot_data *data;
if ( objc != 2 ) {
Tcl_SetResult(interp,"args: handle",TCL_VOLATILE);
return TCL_ERROR;
}
data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
return TCL_ERROR;
}
pmepot_destroy(data);
Tcl_DeleteAssocData(interp, Tcl_GetString(objv[1]));
return TCL_OK;
}
Tcl_Command
Itcl_RegisterObjectCommand(
Tcl_Interp *interp,
ItclObject *ioPtr,
const char *cmdName,
ClientData clientData,
Tcl_Command cmdPtr,
Tcl_Namespace *nsPtr)
{
Tcl_HashEntry *hPtr;
ItclResolvingInfo *iriPtr;
ObjectCmdTableInfo *octiPtr;
ObjectCmdInfo *ociPtr;
int isNew;
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_CreateHashEntry(&iriPtr->objectCmdsTables,
(char *)ioPtr, &isNew);
if (isNew) {
octiPtr = (ObjectCmdTableInfo *)ckalloc(sizeof(ObjectCmdTableInfo));
Tcl_InitHashTable(&octiPtr->cmdInfos, TCL_ONE_WORD_KEYS);
octiPtr->tablePtr = &((Namespace *)nsPtr)->cmdTable;
Tcl_SetHashValue(hPtr, octiPtr);
} else {
octiPtr = Tcl_GetHashValue(hPtr);
}
hPtr = Tcl_CreateHashEntry(&octiPtr->cmdInfos, (char *)clientData, &isNew);
if (isNew) {
ociPtr = (ObjectCmdInfo *)ckalloc(sizeof(ObjectCmdInfo));
memset(ociPtr, 0, sizeof(ObjectCmdInfo));
Tcl_SetHashValue(hPtr, ociPtr);
} else {
ociPtr = Tcl_GetHashValue(hPtr);
}
ociPtr->clientData = clientData;
ociPtr->ioPtr = ioPtr;
if (cmdPtr == NULL) {
/*
cmdPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName);
*/
}
ociPtr->cmdPtr = cmdPtr;
return cmdPtr;
}
Tcl_Var
Itcl_RegisterObjectVariable(
Tcl_Interp *interp,
ItclObject *ioPtr,
const char *varName,
ClientData clientData,
Tcl_Var varPtr,
Tcl_Namespace *nsPtr)
{
Tcl_HashEntry *hPtr;
ItclResolvingInfo *iriPtr;
ObjectVarTableInfo *ovtiPtr;
ObjectVarInfo *oviPtr;
int isNew;
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_CreateHashEntry(&iriPtr->objectVarsTables,
(char *)ioPtr, &isNew);
if (isNew) {
ovtiPtr = (ObjectVarTableInfo *)ckalloc(sizeof(ObjectVarTableInfo));
Tcl_InitHashTable(&ovtiPtr->varInfos, TCL_ONE_WORD_KEYS);
ovtiPtr->tablePtr = &((Namespace *)nsPtr)->varTable;
Tcl_SetHashValue(hPtr, ovtiPtr);
} else {
ovtiPtr = Tcl_GetHashValue(hPtr);
}
hPtr = Tcl_CreateHashEntry(&ovtiPtr->varInfos, (char *)clientData, &isNew);
if (isNew) {
oviPtr = (ObjectVarInfo *)ckalloc(sizeof(ObjectVarInfo));
memset(oviPtr, 0, sizeof(ObjectVarInfo));
Tcl_SetHashValue(hPtr, oviPtr);
} else {
oviPtr = Tcl_GetHashValue(hPtr);
}
oviPtr->clientData = clientData;
oviPtr->ioPtr = ioPtr;
if (varPtr == NULL) {
varPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName);
}
oviPtr->varPtr = varPtr;
return varPtr;
}
/*
* ------------------------------------------------------------------------
* 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;
}
static void
UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp, /* Interpreter in which the accept callback
* record was registered. */
AcceptCallback *acceptCallbackPtr)
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
"tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
}
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;
}
static StylePackageData *GetStylePackageData(Tcl_Interp *interp)
{
return (StylePackageData*)Tcl_GetAssocData(interp, "StylePackage", NULL);
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCmdResolver()
*
* Used by the class namespaces to handle name resolution for all
* commands. This procedure looks for references to class methods
* and procs, and returns TCL_OK along with the appropriate Tcl
* command in the rPtr argument. If a particular command is private,
* this procedure returns TCL_ERROR and access to the command is
* denied. If a command is not recognized, this procedure returns
* TCL_CONTINUE, and lookup continues via the normal Tcl name
* resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCmdResolver2(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the command being accessed */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
int flags, /* TCL_LEAVE_ERR_MSG => leave error messages
* in interp if anything goes wrong */
Tcl_Command *rPtr) /* returns: resolved command */
{
ItclClass *iclsPtr;
ItclObjectInfo *infoPtr;
ItclObject *contextIoPtr;
Tcl_Command cmdPtr;
ItclResolvingInfo *iriPtr;
ObjectCmdTableInfo *octiPtr;
ObjectCmdInfo *ociPtr;
Tcl_HashEntry *hPtr;
if ((name[0] == 't') && (strcmp(name, "this") == 0)) {
return TCL_CONTINUE;
}
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = Tcl_GetHashValue(hPtr);
ItclCallContext *callContextPtr;
callContextPtr = Itcl_PeekStack(&infoPtr->contextStack);
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_FindHashEntry(&iriPtr->resolveCmds , nsPtr->fullName);
if (hPtr != NULL) {
Tcl_HashTable *tablePtr;
tablePtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(tablePtr, name);
if (hPtr != NULL) {
ItclClassCmdInfo *icciPtr = Tcl_GetHashValue(hPtr);
if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) {
contextIoPtr = callContextPtr->ioPtr;
hPtr = Tcl_FindHashEntry(&iriPtr->objectCmdsTables,
(char *)contextIoPtr);
if (hPtr != NULL) {
octiPtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(&octiPtr->cmdInfos,
(char *)icciPtr);
if (hPtr != NULL) {
int ret;
ociPtr = Tcl_GetHashValue(hPtr);
ret = (* iriPtr->cmdProtFcn)(interp,
Tcl_GetCurrentNamespace(interp), name,
(ClientData)icciPtr);
if (ret != TCL_OK) {
return ret;
}
cmdPtr = ociPtr->cmdPtr;
*rPtr = cmdPtr;
return TCL_OK;
}
}
}
}
}
return TCL_CONTINUE;
}
/*
* ------------------------------------------------------------------------
* ItclClassRuntimeVarResolver()
*
* Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc
* at runtime. Resolves data members identified earlier by
* Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation
* for the data member.
* ------------------------------------------------------------------------
*/
static Tcl_Var
ItclClassRuntimeVarResolver2(
Tcl_Interp *interp, /* current interpreter */
Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep
* for variable */
{
ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup;
ItclClass *iclsPtr;
ItclObject *contextIoPtr;
Tcl_HashEntry *hPtr;
Tcl_Var varPtr;
ItclResolvingInfo *iriPtr;
ObjectVarTableInfo *ovtiPtr;
ObjectVarInfo *oviPtr;
/*
* If this is a common data member, then the associated
* variable is known directly.
*/
if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) {
hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
(char *)vlookup->ivPtr);
if (hPtr != NULL) {
return Tcl_GetHashValue(hPtr);
}
}
iclsPtr = vlookup->ivPtr->iclsPtr;
/*
* Otherwise, get the current object context and find the
* variable in its data table.
*
* TRICKY NOTE: Get the index for this variable using the
* virtual table for the MOST-SPECIFIC class.
*/
ItclCallContext *callContextPtr;
callContextPtr = Itcl_PeekStack(&iclsPtr->infoPtr->contextStack);
if (callContextPtr == NULL) {
return NULL;
}
if (callContextPtr->ioPtr == NULL) {
return NULL;
}
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars,
Tcl_GetCurrentNamespace(interp)->fullName);
if (hPtr != NULL) {
Tcl_HashTable *tablePtr;
tablePtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(tablePtr,
Tcl_GetString(vlookup->ivPtr->namePtr));
if (hPtr != NULL) {
ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr);
int ret;
ret = (* iriPtr->varProtFcn)(interp,
Tcl_GetCurrentNamespace(interp),
Tcl_GetString(vlookup->ivPtr->namePtr),
(ClientData)icviPtr);
if (ret != TCL_OK) {
return NULL;
}
/*
* If this is an instance variable, then we have to
* find the object context,
*/
contextIoPtr = callContextPtr->ioPtr;
hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, (char *)contextIoPtr);
if (hPtr != NULL) {
ovtiPtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, (char *)icviPtr);
if (hPtr != NULL) {
oviPtr = Tcl_GetHashValue(hPtr);
varPtr = oviPtr->varPtr;
return varPtr;
}
}
}
}
return NULL;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCompiledVarResolver()
*
* Used by the class namespaces to handle name resolution for compile
* time variable accesses. This procedure looks for references to
* both common variables and instance variables at compile time. If
* the variables are found, they are characterized in a generic way
* by their ItclVarLookup record. At runtime, Tcl constructs the
* compiled local variables by calling ItclClassRuntimeVarResolver.
*
* If a variable is found, this procedure returns TCL_OK along with
* information about the variable in the rPtr argument. If a particular
* variable is private, this procedure returns TCL_ERROR and access
* to the variable is denied. If a variable is not recognized, this
* procedure returns TCL_CONTINUE, and lookup continues via the normal
* Tcl name resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCompiledVarResolver2(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the variable being accessed */
int length, /* number of characters in name */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to
* resolve the variable at runtime */
{
ItclClass *iclsPtr;
ItclObjectInfo *infoPtr;
Tcl_HashEntry *hPtr;
ItclVarLookup *vlookup;
char *buffer;
char storage[64];
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = Tcl_GetHashValue(hPtr);
/*
* Copy the name to local storage so we can NULL terminate it.
* If the name is long, allocate extra space for it.
*/
if (length < sizeof(storage)) {
buffer = storage;
} else {
buffer = (char*)ckalloc((unsigned)(length+1));
}
memcpy((void*)buffer, (void*)name, (size_t)length);
buffer[length] = '\0';
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer);
if (buffer != storage) {
ckfree(buffer);
}
/*
* If the name is not found, or if it is inaccessible,
* continue on with the normal Tcl name resolution rules.
*/
if (hPtr == NULL) {
return TCL_CONTINUE;
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
if (!vlookup->accessible) {
return TCL_CONTINUE;
}
/*
* Return the ItclVarLookup record. At runtime, Tcl will
* call ItclClassRuntimeVarResolver with this record, to
* plug in the appropriate variable for the current object
* context.
*/
(*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo));
(*rPtr)->fetchProc = ItclClassRuntimeVarResolver2;
(*rPtr)->deleteProc = NULL;
((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup;
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassVarResolver()
*
* Used by the class namespaces to handle name resolution for runtime
* variable accesses. This procedure looks for references to both
* common variables and instance variables at runtime. It is used as
* a second line of defense, to handle references that could not be
* resolved as compiled locals.
*
* If a variable is found, this procedure returns TCL_OK along with
* the appropriate Tcl variable in the rPtr argument. If a particular
* variable is private, this procedure returns TCL_ERROR and access
* to the variable is denied. If a variable is not recognized, this
* procedure returns TCL_CONTINUE, and lookup continues via the normal
* Tcl name resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassVarResolver2(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the variable being accessed */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
int flags, /* TCL_LEAVE_ERR_MSG => leave error messages
* in interp if anything goes wrong */
Tcl_Var *rPtr) /* returns: resolved variable */
{
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclObject *contextIoPtr;
Tcl_HashEntry *hPtr;
ItclVarLookup *vlookup;
Tcl_Var varPtr;
ItclResolvingInfo *iriPtr;
ObjectVarTableInfo *ovtiPtr;
ObjectVarInfo *oviPtr;
Tcl_Namespace *upNsPtr;
upNsPtr = Itcl_GetUplevelNamespace(interp, 1);
/*
* If this is a global variable, handle it in the usual
* Tcl manner.
*/
if (flags & TCL_GLOBAL_ONLY) {
return TCL_CONTINUE;
}
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = Tcl_GetHashValue(hPtr);
/*
* See if this is a formal parameter in the current proc scope.
* If so, that variable has precedence. Look it up and return
* it here. This duplicates some of the functionality of
* TclLookupVar, but we return it here (instead of returning
* TCL_CONTINUE) to avoid looking it up again later.
*/
ItclCallContext *callContextPtr;
callContextPtr = Itcl_PeekStack(&infoPtr->contextStack);
if ((strstr(name,"::") == NULL) &&
Itcl_IsCallFrameArgument(interp, name)) {
return TCL_CONTINUE;
}
iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars , nsPtr->fullName);
if (hPtr != NULL) {
Tcl_HashTable *tablePtr;
tablePtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(tablePtr , name);
if (hPtr != NULL) {
int ret;
ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr);
ret = (* iriPtr->varProtFcn)(interp,
Tcl_GetCurrentNamespace(interp), name,
(ClientData)icviPtr);
if (ret != TCL_OK) {
return ret;
}
/*
* If this is an instance variable, then we have to
* find the object context,
*/
if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) {
contextIoPtr = callContextPtr->ioPtr;
hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables,
(char *)contextIoPtr);
if (hPtr != NULL) {
ovtiPtr = Tcl_GetHashValue(hPtr);
hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos,
(char *)icviPtr);
if (hPtr != NULL) {
oviPtr = Tcl_GetHashValue(hPtr);
varPtr = oviPtr->varPtr;
*rPtr = varPtr;
return TCL_OK;
}
}
}
}
}
/*
* See if the variable is a known data member and accessible.
*/
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
if (!vlookup->accessible) {
return TCL_CONTINUE;
}
/*
* If this is a common data member, then its variable
* is easy to find. Return it directly.
*/
if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) {
hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
(char *)vlookup->ivPtr);
if (hPtr != NULL) {
*rPtr = Tcl_GetHashValue(hPtr);
return TCL_OK;
}
}
return TCL_CONTINUE;
}
HandleNameToRepMap *
HandleNameToRepMap::instance (Tcl_Interp *interp)
{
return static_cast<HandleNameToRepMap *>(
Tcl_GetAssocData(interp, ASSOC_KEY, 0));
}
MkView::MkView(Tcl_Interp *ip_, const char *name): Tcl(ip_), work(*
(MkWorkspace*)Tcl_GetAssocData(interp, "mk4tcl", 0)) {
Register(name);
}
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);
}
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 */
}
static int vmdinfo_tcl(ClientData, Tcl_Interp *interp,
int argc, const char *argv[]) {
VMDApp *app = (VMDApp *)Tcl_GetAssocData(interp, "VMDApp", NULL);
if (argc == 2) {
SIMPLE_TCL_OPT("version", VMDVERSION);
SIMPLE_TCL_OPT("versionmsg", VERSION_MSG);
SIMPLE_TCL_OPT("authors", VMD_AUTHORS);
SIMPLE_TCL_OPT("arch", VMD_ARCH);
SIMPLE_TCL_OPT("options", VMD_OPTIONS);
SIMPLE_TCL_OPT("www", VMD_HOMEPAGE);
SIMPLE_TCL_OPT("wwwhelp", VMD_HELPPAGE);
// return the estimated amount of available physical memory
if (!strcmp(argv[1], "freemem")) {
long vmdcorefree = vmd_get_avail_physmem_mb();
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(vmdcorefree));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
// return the number of available CPU cores
if (!strcmp(argv[1], "numcpus")) {
#if defined(VMDTHREADS)
int numcpus = wkf_thread_numprocessors();
#else
int numcpus = 1;
#endif
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(numcpus));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
// return the CPU affinity list for the VMD process
if (!strcmp(argv[1], "cpuaffinity")) {
int numcpus = -1;
int *cpuaffinitylist = NULL;
#if defined(VMDTHREADS)
cpuaffinitylist = wkf_cpu_affinitylist(&numcpus);
#endif
if (numcpus > 0 && cpuaffinitylist != NULL) {
int i;
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
for (i=0; i<numcpus; i++)
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(cpuaffinitylist[i]));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
if (cpuaffinitylist != NULL)
free(cpuaffinitylist);
Tcl_AppendResult(interp, "CPU affinity query unavailable on this platform", NULL);
return TCL_ERROR;
}
// return the number of available CUDA devices
if (!strcmp(argv[1], "numcudadevices")) {
int numdevices;
#if defined(VMDCUDA)
vmd_cuda_num_devices(&numdevices);
#else
numdevices = 0;
#endif
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(numdevices));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
// return the active display device (e.g. "text", "win", "cave", ...)
if (!strcmp(argv[1], "dispdev")) {
const char *disp = VMDgetDisplayTypeName();
Tcl_AppendResult(interp, disp, NULL);
return TCL_OK;
}
// return the MPI node name
if (!strcmp(argv[1], "nodename")) {
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewStringObj(app->par_name(), strlen(app->par_name())));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
// return the MPI node rank
if (!strcmp(argv[1], "noderank")) {
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_rank()));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
// return the MPI node count
if (!strcmp(argv[1], "nodecount")) {
Tcl_Obj *tcl_result = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, tcl_result, Tcl_NewIntObj(app->par_size()));
Tcl_SetObjResult(interp, tcl_result);
return TCL_OK;
}
}
Tcl_AppendResult(interp,
"vmdinfo: version | versionmsg | authors | arch | \n"
"freemem | numcpus | cpuaffinity | numcudadevices | \n"
"dispdev | nodename | noderank | nodecount | \n"
"options | www | wwwhelp", NULL);
return TCL_ERROR;
}
/* 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;
}
int Vmd_Init(Tcl_Interp *interp) {
VMDApp *app = (VMDApp *)Tcl_GetAssocData(interp, "VMDApp", NULL);
Tcl_CreateCommand(interp, "vmdinfo", vmdinfo_tcl,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "vmdbench", text_cmd_vmdbench,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "animate", text_cmd_animate,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "color", text_cmd_color,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "axes", text_cmd_axes,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "display", text_cmd_display,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "imd", text_cmd_imd,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "vmdcollab", text_cmd_collab,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "vmd_label", text_cmd_label,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "light", text_cmd_light,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "pointlight", text_cmd_point_light,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "material", text_cmd_material,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "vmd_menu", text_cmd_menu,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "stage", text_cmd_stage,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "light", text_cmd_light,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "user", text_cmd_user,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "mol", text_cmd_mol,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "molecule", text_cmd_mol,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "mouse", text_cmd_mouse,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "mobile", text_cmd_mobile,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "spaceball", text_cmd_spaceball,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "plugin", text_cmd_plugin,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "render", text_cmd_render,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#if defined(VMDTK) && !defined(_MSC_VER)
Tcl_CreateCommand(interp, "tkrender", text_cmd_tkrender,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#endif
Tcl_CreateCommand(interp, "rock", text_cmd_rock,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "rotate", text_cmd_rotate,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "rotmat", text_cmd_rotmat,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "vmd_scale", text_cmd_scale,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "translate", text_cmd_translate,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "sleep", text_cmd_sleep,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#if 1
Tcl_CreateObjCommand(interp, "mdffi", obj_mdff_cc,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#endif
#if 0
Tcl_CreateObjCommand(interp, "volgradient", obj_volgradient,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#endif
Tcl_CreateCommand(interp, "tool", text_cmd_tool,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "measure", obj_measure,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "rawtimestep", cmd_rawtimestep,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "gettimestep", cmd_gettimestep,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#ifdef VMDPYTHON
Tcl_CreateCommand(interp, "gopython", text_cmd_gopython,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
#endif
#if defined(VMDTKCON)
Tcl_CreateObjCommand(interp,"vmdcon",tcl_vmdcon,
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
#endif
#if defined(VMDCOLVARS)
Tcl_CreateCommand (interp, "colvars", tcl_colvars, (ClientData) app, (Tcl_CmdDeleteProc*) NULL);
Tcl_CreateCommand (interp, "cv", tcl_colvars, (ClientData) app, (Tcl_CmdDeleteProc*) NULL);
Tcl_PkgProvide (interp, "colvars", COLVARS_VERSION);
#endif
Tcl_CreateObjCommand(interp, "volmap", obj_volmap,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "parallel", text_cmd_parallel,
(ClientData) app, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
