int
Tk_ImageObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
static const char *const imageOptions[] = {
"create", "delete", "height", "inuse", "names", "type", "types",
"width", NULL
};
enum options {
IMAGE_CREATE, IMAGE_DELETE, IMAGE_HEIGHT, IMAGE_INUSE, IMAGE_NAMES,
IMAGE_TYPE, IMAGE_TYPES, IMAGE_WIDTH
};
TkWindow *winPtr = clientData;
int i, isNew, firstOption, index;
Tk_ImageType *typePtr;
ImageMaster *masterPtr;
Image *imagePtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
char idString[16 + TCL_INTEGER_SPACE];
TkDisplay *dispPtr = winPtr->dispPtr;
const char *arg, *name;
Tcl_Obj *resultObj;
ThreadSpecificData *tsdPtr =
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObjStruct(interp, objv[1], imageOptions,
sizeof(char *), "option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case IMAGE_CREATE: {
Tcl_Obj **args;
int oldimage = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"type ?name? ?-option value ...?");
return TCL_ERROR;
}
/*
* Look up the image type.
*/
arg = Tcl_GetString(objv[2]);
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
if (typePtr == NULL) {
oldimage = 1;
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
if ((*arg == typePtr->name[0])
&& (strcmp(arg, typePtr->name) == 0)) {
break;
}
}
}
if (typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"image type \"%s\" doesn't exist", arg));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE_TYPE", arg, NULL);
return TCL_ERROR;
}
/*
* Figure out a name to use for the new image.
*/
if ((objc == 3) || (*(arg = Tcl_GetString(objv[3])) == '-')) {
do {
dispPtr->imageId++;
sprintf(idString, "image%d", dispPtr->imageId);
name = idString;
} while (Tcl_FindCommand(interp, name, NULL, 0) != NULL);
firstOption = 3;
} else {
TkWindow *topWin;
name = arg;
firstOption = 4;
/*
* Need to check if the _command_ that we are about to create is
* the name of the current master widget command (normally "." but
* could have been renamed) and fail in that case before a really
* nasty and hard to stop crash happens.
*/
topWin = (TkWindow *) TkToplevelWindowForCommand(interp, name);
if (topWin != NULL && winPtr->mainPtr->winPtr == topWin) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"images may not be named the same as the main window",
-1));
Tcl_SetErrorCode(interp, "TK", "IMAGE", "SMASH_MAIN", NULL);
return TCL_ERROR;
}
}
/*
* Create the data structure for the new image.
*/
hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->imageTable, name, &isNew);
if (isNew) {
masterPtr = ckalloc(sizeof(ImageMaster));
masterPtr->typePtr = NULL;
masterPtr->masterData = NULL;
masterPtr->width = masterPtr->height = 1;
masterPtr->tablePtr = &winPtr->mainPtr->imageTable;
masterPtr->hPtr = hPtr;
masterPtr->instancePtr = NULL;
masterPtr->deleted = 0;
masterPtr->winPtr = winPtr->mainPtr->winPtr;
Tcl_Preserve(masterPtr->winPtr);
Tcl_SetHashValue(hPtr, masterPtr);
} else {
/*
* An image already exists by this name. Disconnect the instances
* from the master.
*/
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->typePtr != NULL) {
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
masterPtr->typePtr->freeProc(imagePtr->instanceData,
imagePtr->display);
imagePtr->changeProc(imagePtr->widgetClientData, 0, 0,
masterPtr->width, masterPtr->height,
masterPtr->width, masterPtr->height);
}
masterPtr->typePtr->deleteProc(masterPtr->masterData);
masterPtr->typePtr = NULL;
}
masterPtr->deleted = 0;
}
/*
* Call the image type manager so that it can perform its own
* initialization, then re-"get" for any existing instances of the
* image.
*/
objv += firstOption;
objc -= firstOption;
args = (Tcl_Obj **) objv;
if (oldimage) {
int i;
args = ckalloc((objc+1) * sizeof(char *));
for (i = 0; i < objc; i++) {
args[i] = (Tcl_Obj *) Tcl_GetString(objv[i]);
}
args[objc] = NULL;
}
Tcl_Preserve(masterPtr);
if (typePtr->createProc(interp, name, objc, args, typePtr,
(Tk_ImageMaster)masterPtr, &masterPtr->masterData) != TCL_OK){
EventuallyDeleteImage(masterPtr, 0);
Tcl_Release(masterPtr);
if (oldimage) {
ckfree(args);
}
return TCL_ERROR;
}
Tcl_Release(masterPtr);
if (oldimage) {
ckfree(args);
}
masterPtr->typePtr = typePtr;
for (imagePtr = masterPtr->instancePtr; imagePtr != NULL;
imagePtr = imagePtr->nextPtr) {
imagePtr->instanceData = typePtr->getProc(imagePtr->tkwin,
masterPtr->masterData);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(
Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr), -1));
break;
}
case IMAGE_DELETE:
for (i = 2; i < objc; i++) {
arg = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
DeleteImage(masterPtr);
}
break;
case IMAGE_NAMES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search);
resultObj = Tcl_NewObj();
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
continue;
}
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr), -1));
}
Tcl_SetObjResult(interp, resultObj);
break;
case IMAGE_TYPES:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
for (typePtr = tsdPtr->imageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
typePtr->name, -1));
}
for (typePtr = tsdPtr->oldImageTypeList; typePtr != NULL;
typePtr = typePtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
typePtr->name, -1));
}
Tcl_SetObjResult(interp, resultObj);
break;
case IMAGE_HEIGHT:
case IMAGE_INUSE:
case IMAGE_TYPE:
case IMAGE_WIDTH:
/*
* These operations all parse virtually identically. First check to
* see if three args are given. Then get a non-deleted master from the
* third arg.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
arg = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg);
if (hPtr == NULL) {
goto alreadyDeleted;
}
masterPtr = Tcl_GetHashValue(hPtr);
if (masterPtr->deleted) {
goto alreadyDeleted;
}
/*
* Now we read off the specific piece of data we were asked for.
*/
switch ((enum options) index) {
case IMAGE_HEIGHT:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(masterPtr->height));
break;
case IMAGE_INUSE:
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
masterPtr->typePtr && masterPtr->instancePtr));
break;
case IMAGE_TYPE:
if (masterPtr->typePtr != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(masterPtr->typePtr->name, -1));
}
break;
case IMAGE_WIDTH:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(masterPtr->width));
break;
default:
Tcl_Panic("can't happen");
}
break;
}
return TCL_OK;
alreadyDeleted:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("image \"%s\" doesn't exist",arg));
Tcl_SetErrorCode(interp, "TK", "LOOKUP", "IMAGE", arg, NULL);
return TCL_ERROR;
}
colvarproxy_namd::colvarproxy_namd()
{
version_int = get_version_from_string(COLVARPROXY_VERSION);
first_timestep = true;
total_force_requested = false;
requestTotalForce(total_force_requested);
// initialize pointers to NAMD configuration data
simparams = Node::Object()->simParameters;
if (cvm::debug())
iout << "Info: initializing the colvars proxy object.\n" << endi;
// find the configuration file, if provided
StringList *config = Node::Object()->configList->find("colvarsConfig");
// find the input state file
StringList *input_restart = Node::Object()->configList->find("colvarsInput");
input_prefix_str = std::string(input_restart ? input_restart->data : "");
if (input_prefix_str.rfind(".colvars.state") != std::string::npos) {
// strip the extension, if present
input_prefix_str.erase(input_prefix_str.rfind(".colvars.state"),
std::string(".colvars.state").size());
}
// get the thermostat temperature
if (simparams->rescaleFreq > 0)
thermostat_temperature = simparams->rescaleTemp;
else if (simparams->reassignFreq > 0)
thermostat_temperature = simparams->reassignTemp;
else if (simparams->langevinOn)
thermostat_temperature = simparams->langevinTemp;
else if (simparams->tCoupleOn)
thermostat_temperature = simparams->tCoupleTemp;
//else if (simparams->loweAndersenOn)
// thermostat_temperature = simparams->loweAndersenTemp;
else
thermostat_temperature = 0.0;
random = Random(simparams->randomSeed);
// take the output prefixes from the namd input
output_prefix_str = std::string(simparams->outputFilename);
restart_output_prefix_str = std::string(simparams->restartFilename);
restart_frequency_s = simparams->restartFrequency;
// check if it is possible to save output configuration
if ((!output_prefix_str.size()) && (!restart_output_prefix_str.size())) {
fatal_error("Error: neither the final output state file or "
"the output restart file could be defined, exiting.\n");
}
#ifdef NAMD_TCL
have_scripts = true;
init_tcl_pointers();
// See is user-scripted forces are defined
if (Tcl_FindCommand(reinterpret_cast<Tcl_Interp *>(_tcl_interp),
"calc_colvar_forces", NULL, 0) == NULL) {
force_script_defined = false;
} else {
force_script_defined = true;
}
#else
force_script_defined = false;
have_scripts = false;
#endif
// initiate module: this object will be the communication proxy
colvars = new colvarmodule(this);
log("Using NAMD interface, version "+
cvm::to_str(COLVARPROXY_VERSION)+".\n");
if (config) {
colvars->read_config_file(config->data);
}
colvars->setup();
colvars->setup_input();
colvars->setup_output();
// save to Node for Tcl script access
Node::Object()->colvars = colvars;
#ifdef NAMD_TCL
// Construct instance of colvars scripting interface
script = new colvarscript(this);
#endif
if (simparams->firstTimestep != 0) {
log("Initializing step number as firstTimestep.\n");
colvars->it = colvars->it_restart = simparams->firstTimestep;
}
reduction = ReductionMgr::Object()->willSubmit(REDUCTIONS_BASIC);
if (cvm::debug())
iout << "Info: done initializing the colvars proxy object.\n" << endi;
}
/*
* ------------------------------------------------------------------------
* ItclFinishCmd()
*
* called when an interp is deleted to free up memory or called explicitly
* to check memory leaks
*
* ------------------------------------------------------------------------
*/
static int
ItclFinishCmd(
ClientData clientData, /* unused */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch place;
Tcl_Namespace *nsPtr;
Tcl_Obj **newObjv;
Tcl_Obj *objPtr;
Tcl_Obj *ensObjPtr;
Tcl_Command cmdPtr;
Tcl_Obj *mapDict;
ItclObjectInfo *infoPtr;
ItclCmdsInfo *iciPtr;
int checkMemoryLeaks;
int i;
int result;
ItclShowArgs(1, "ItclFinishCmd", objc, objv);
result = TCL_OK;
infoPtr = Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
if (infoPtr == NULL) {
infoPtr = (ItclObjectInfo *)clientData;
}
checkMemoryLeaks = 0;
if (objc > 1) {
if (strcmp(Tcl_GetString(objv[1]), "checkmemoryleaks") == 0) {
/* if we have that option, the namespace of the Tcl ensembles
* is not teared down, so we have to simulate it here to
* have the correct reference counts for infoPtr->infoVars2Ptr
* infoPtr->infoVars3Ptr and infoPtr->infoVars4Ptr
*/
checkMemoryLeaks = 1;
}
}
newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * 2);
newObjv[0] = Tcl_NewStringObj("my", -1);;
for (i = 0; ;i++) {
iciPtr = &itclCmds[i];
if (iciPtr->name == NULL) {
break;
}
if ((iciPtr->flags & ITCL_IS_ENSEMBLE) == 0) {
result = Itcl_RenameCommand(interp, iciPtr->name, "");
} else {
objPtr = Tcl_NewStringObj(iciPtr->name, -1);
newObjv[1] = objPtr;
Itcl_EnsembleDeleteCmd(infoPtr, infoPtr->interp, 2, newObjv);
Tcl_DecrRefCount(objPtr);
}
iciPtr++;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *)newObjv);
/* remove the unknow handler, to free the reference to the
* Tcl_Obj with the name of it */
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info::delegated", -1);
cmdPtr = Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG);
if (cmdPtr != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL, cmdPtr, NULL);
}
Tcl_DecrRefCount(ensObjPtr);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->instances, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->instances);
while (1) {
hPtr = Tcl_FirstHashEntry(&infoPtr->classTypes, &place);
if (hPtr == NULL) {
break;
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&infoPtr->classTypes);
nsPtr = Tcl_FindNamespace(interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
mapDict = NULL;
ensObjPtr = Tcl_NewStringObj("::itcl::builtin::Info", -1);
if (Tcl_FindNamespace(interp, Tcl_GetString(ensObjPtr), NULL, 0) != NULL) {
Tcl_SetEnsembleUnknownHandler(NULL,
Tcl_FindEnsemble(interp, ensObjPtr, TCL_LEAVE_ERR_MSG),
NULL);
}
Tcl_DecrRefCount(ensObjPtr);
/* remove the itclinfo and vars entry from the info dict */
/* and replace it by the original one */
cmdPtr = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY);
if (cmdPtr != NULL && Tcl_IsEnsemble(cmdPtr)) {
Tcl_GetEnsembleMappingDict(NULL, cmdPtr, &mapDict);
if (mapDict != NULL) {
objPtr = Tcl_NewStringObj("vars", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DictObjPut(interp, mapDict, objPtr, infoPtr->infoVars4Ptr);
Tcl_DecrRefCount(objPtr);
objPtr = Tcl_NewStringObj("itclinfo", -1);
Tcl_DictObjRemove(interp, mapDict, objPtr);
Tcl_DecrRefCount(objPtr);
Tcl_SetEnsembleMappingDict(interp, cmdPtr, mapDict);
}
}
/* FIXME have to figure out why the refCount of
* ::itcl::builtin::Info
* and ::itcl::builtin::Info::vars and vars is 2 here !! */
/* seems to be as the tclOO commands are not yet deleted ?? */
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
if (checkMemoryLeaks) {
Tcl_DecrRefCount(infoPtr->infoVars2Ptr);
Tcl_DecrRefCount(infoPtr->infoVars3Ptr);
Tcl_DecrRefCount(infoPtr->infoVars4Ptr);
/* see comment above */
}
Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
Tcl_EvalEx(infoPtr->interp,
"::oo::define ::itcl::clazz deletemethod unknown", -1, 0);
/* first have to look for the remaining memory leaks, then remove the next ifdef */
#ifdef LATER
Itcl_RenameCommand(infoPtr->interp, "::itcl::clazz", "");
/* tear down ::itcl namespace (this includes ::itcl::parser namespace) */
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::parser", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::import", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::methodset", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::internal", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
nsPtr = Tcl_FindNamespace(infoPtr->interp, "::itcl::builtin", NULL, 0);
if (nsPtr != NULL) {
Tcl_DeleteNamespace(nsPtr);
}
#endif
/* remove the unknown method from top class */
if (infoPtr->unknownNamePtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownNamePtr);
}
if (infoPtr->unknownArgumentPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownArgumentPtr);
}
if (infoPtr->unknownBodyPtr != NULL) {
Tcl_DecrRefCount(infoPtr->unknownBodyPtr);
}
/* cleanup ensemble info */
ItclFinishEnsemble(infoPtr);
ckfree((char *)infoPtr->object_meta_type);
ckfree((char *)infoPtr->class_meta_type);
Itcl_DeleteStack(&infoPtr->clsStack);
Itcl_DeleteStack(&infoPtr->contextStack);
Itcl_DeleteStack(&infoPtr->constructorStack);
/* clean up list pool */
Itcl_FinishList();
Itcl_ReleaseData((ClientData)infoPtr);
return result;
}