/****
* implementation of Tcl shape_create routine
****/
int tclShapeCreate(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
int slot, i, j, k, len, shft;
char expr[2048];
double a, p;
Tcl_Obj *tclres;
if ( (argc < 2) || (argc > 6) )
return TclError(interp,"usage: shape_create <num of lems> | -ampl <ampl expr> | -phase <phase expr>");
if (Tcl_GetInt(interp,argv[1],&len) == TCL_ERROR)
return TclError(interp,"shape_create: argument 1 must be integer <num of elems>");
/* get a new slot and allocate */
slot = RFshapes_slot();
if (slot == -1) {
return TclError(interp,"shape_create error: no more free slots available, free some shape first!");
}
RFshapes[slot] = RFshapes_alloc(len);
for (i=1; i<=len; i++) {
RFshapes[slot][i].ampl = 0.0;
RFshapes[slot][i].phase = 0.0;
}
for (i=2; i<argc; i++) {
if (!strcmp(argv[i],"-ampl")) {
i++;
/* evaluate expression in Tcl */
for (j=1; j<=len; j++) {
sprintf(expr,"\n set i %d\n expr %s\n", j, argv[i]);
if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK )
return TclError(interp,"error in shape_create: can not evaluate %s for index %d",argv[i], j);
tclres = Tcl_GetObjResult(interp);
if ( Tcl_GetDoubleFromObj(interp,tclres,&a) != TCL_OK )
return TclError(interp,"error in shape_create: can not get amplitude result for index %d",j);
RFshapes[slot][j].ampl = a;
}
} else if (!strcmp(argv[i],"-phase")) {
i++;
/* evaluate expression in Tcl */
for (j=1; j<=len; j++) {
sprintf(expr,"\n set i %d\n expr %s\n", j, argv[i]);
if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK )
return TclError(interp,"error in shape_create: can not evaluate %s for index %d",argv[i], j);
tclres = Tcl_GetObjResult(interp);
if ( Tcl_GetDoubleFromObj(interp,tclres,&p) != TCL_OK )
return TclError(interp,"error in shape_create: can not get amplitude result for index %d",j);
RFshapes[slot][j].phase = p;
}
}
}
sprintf(interp->result,"%d",slot);
return TCL_OK;
}
bool init_surfit_lib(Tcl_Interp * interp) {
char * lib = NULL;
lib = getenv("SURFIT_LIB");
char libsurfit[] = "libsurfit[info sharedlibextension]";
bool libs_loaded = false;
char * surfit;
if (lib) {
surfit = (char *) malloc(strlen(lib)+strlen(libsurfit)+7);
strcpy(surfit, "load ");
strcat(surfit, lib);
strcat(surfit, "/");
strcat(surfit, libsurfit);
libs_loaded = true;
// trying to open libsurfit
Tcl_SetErrno(0);
int res = Tcl_EvalEx(interp, surfit, -1, TCL_EVAL_DIRECT);
if (res != TCL_OK)
libs_loaded = false;
free(surfit);
}
if (!libs_loaded) {
// searching in current directory
surfit = (char *) malloc(strlen(libsurfit)+6);
strcpy(surfit, "load ");
strcat(surfit, libsurfit);
bool local_libs_loaded = true;
int res = Tcl_EvalEx(interp, surfit, -1, TCL_EVAL_DIRECT);
if (res != TCL_OK)
local_libs_loaded = false;
free(surfit);
return local_libs_loaded;
}
return libs_loaded;
};
int NS(ProcCheck) (
Tcl_Interp * interp,
struct Tcl_Obj * cmdObj,
char const * const wrongNrStr
)
{
int ret,len;
Tcl_DString cmd;
if (!Tcl_GetCommandFromObj (interp, cmdObj)) {
Tcl_WrongNumArgs (interp, 0, NULL, wrongNrStr);
return TCL_ERROR;
}
Tcl_DStringInit(&cmd);
Tcl_DStringAppendElement(&cmd,"info");
Tcl_DStringAppendElement(&cmd,"args");
Tcl_DStringAppendElement(&cmd,Tcl_GetString(cmdObj));
ret = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&cmd);
TclErrorCheck(ret);
TclErrorCheck(Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &len));
if (len != 1) {
Tcl_DString msg;
Tcl_DStringInit(&msg);
Tcl_DStringAppend(&msg,"wrong # args: ", -1);
if (len > 1) Tcl_DStringAppend(&msg,"only ", -1);
Tcl_DStringAppend(&msg,"one argument for procedure \"", -1);
Tcl_DStringAppend(&msg,Tcl_GetString(cmdObj), -1);
Tcl_DStringAppend(&msg,"\" is required", -1);
Tcl_DStringResult(interp, &msg);
Tcl_DStringFree(&msg);
return TCL_ERROR;
}
return TCL_OK;
}
int
ui_info(Tcl_Interp *interp, char *mesg)
{
const char ui_proc_start[] = "ui_info [subst -nocommands -novariables {";
const char ui_proc_end[] = "}]";
char *script, *string;
size_t scriptlen, len, remaining;
int rval;
string = ui_escape(mesg);
if (string == NULL)
return TCL_ERROR;
len = strlen(string);
scriptlen = sizeof(ui_proc_start) + len + sizeof(ui_proc_end) - 1;
script = malloc(scriptlen);
if (script == NULL)
return TCL_ERROR;
memcpy(script, ui_proc_start, sizeof(ui_proc_start));
remaining = scriptlen - sizeof(ui_proc_start);
strncat(script, string, remaining);
remaining -= len;
strncat(script, ui_proc_end, remaining);
free(string);
rval = Tcl_EvalEx(interp, script, -1, 0);
free(script);
return rval;
}
/*
Function to hook the TkImageDisplayProc of the photo image type.
As we can copy frame only when we need to display it
*/
int PlaceHook(Tcl_Interp *interp) {
char buf[255];
strcpy(buf, "image create photo");
if (Tcl_EvalEx(interp,buf,-1,TCL_EVAL_GLOBAL) != TCL_OK) {
LOG("Error creating photo for hook creation ");
APPENDLOG( Tcl_GetStringResult(interp) );
return TCL_ERROR;
}
const char *name = Tcl_GetStringResult(interp);
const Tk_ImageType *ctypePhotoPtr = NULL;
Tk_ImageType *typePhotoPtr = NULL;
#if TK_MINOR_VERSION >= 6
Tk_GetImageMasterData(interp, name, &ctypePhotoPtr);
typePhotoPtr = (Tk_ImageType *) ctypePhotoPtr;
#else
Tk_GetImageMasterData(interp, name, &typePhotoPtr);
#endif
if (PhotoDisplayOriginal == NULL) {
PhotoDisplayOriginal = typePhotoPtr->displayProc;
typePhotoPtr->displayProc = (Tk_ImageDisplayProc *) PhotoDisplayProcHook;
} // else we already put the hook
Tk_DeleteImage(interp, name);
Tcl_ResetResult(interp);
return TCL_OK;
}
/* Draw the icon */
static void
DrawIcon (ClientData clientData)
{
TrayIcon *icon=clientData;
int x,y;
unsigned int w,h,b,d;
int widthImg, heightImg;
Window r;
char cmdBuffer[1024];
XSizeHints *hints = NULL;
long supplied = 0;
if( icon->win == NULL ) {
return;
}
XGetGeometry(display, Tk_WindowId(icon->win), &r, &x, &y, &w, &h, &b, &d);
XClearWindow(display, Tk_WindowId(icon->win));
/*
* Here we get the window hints because in some cases the XGetGeometry
* function returns the wrong width/height. We only check that
* min_width <= width <= max_width and min_height <= height <= max_height
*/
hints = XAllocSizeHints();
XGetWMNormalHints(display, Tk_WindowId(icon->win), hints, &supplied);
if( supplied & PMaxSize ) {
w = (hints->max_width < w) ? hints->max_width : w;
h = (hints->max_height < h) ? hints->max_height : h;
}
if( supplied & PMinSize ) {
w = (hints->min_width > w) ? hints->min_width : w;
h = (hints->min_height > h) ? hints->min_height : h;
}
if(hints) {
XFree(hints);
hints = NULL;
}
if (((icon->width != w) || (icon->height != h) || (icon->mustUpdate)) && (icon->cmdCallback[0] != '\0')) {
snprintf(cmdBuffer,sizeof(cmdBuffer),"%s %u %u",icon->cmdCallback,w,h);
Tcl_EvalEx(globalinterp,cmdBuffer,-1,TCL_EVAL_GLOBAL);
icon->mustUpdate = False;
icon->width = w;
icon->height = h;
}
Tk_SizeOfImage(icon->pixmap, &widthImg, &heightImg);
if (widthImg > w)
widthImg = w;
if (heightImg > h)
heightImg = h;
if( !Tk_IsMapped(icon->win) )
Tk_MapWindow(icon->win);
Tk_RedrawImage(icon->pixmap, 0, 0, widthImg, heightImg, Tk_WindowId(icon->win), (w-widthImg)/2 , (h-heightImg)/2 );
}
int
Itcl_SafeInit (
Tcl_Interp *interp)
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, safeInitScript, -1, 0);
}
int ScriptTcl::eval(const char *script, const char **resultPtr) {
#ifdef NAMD_TCL
int code = Tcl_EvalEx(interp,script,-1,TCL_EVAL_GLOBAL);
*resultPtr = Tcl_GetStringResult(interp);
return code;
#else
NAMD_bug("ScriptTcl::eval called without Tcl.");
return -1; // appease compiler
#endif
}
DLLEXPORT int
Pkge_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
static const char script[] = "if 44 {open non_existent}";
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, script, -1, 0);
}
static gboolean doCommand( gpointer data )
{
GnoclCommandData *cs = (GnoclCommandData *)data;
int ret = Tcl_EvalEx( cs->interp, cs->command, -1,
TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT );
if( ret == TCL_ERROR )
Tcl_BackgroundError( cs->interp );
if( ret != TCL_OK )
return 0;
return 1;
}
static int ThreadEventProc(Tcl_Event *event, int mask)
{
int code;
ThreadEvent *data = (ThreadEvent *)event; /* event is really a ThreadEvent */
Tcl_Preserve(data->interpreter);
code = Tcl_EvalEx(data->interpreter, data->script, -1, TCL_EVAL_GLOBAL);
Tcl_Free(data->script);
if (code != TCL_OK) {
ThreadErrorProc(data->interpreter);
}
Tcl_Release(data->interpreter);
return 1;
}
void
TkWmProtocolEventProc(
TkWindow *winPtr, /* Window to which the event was sent. */
XEvent *eventPtr) /* X event. */
{
WmInfo *wmPtr;
ProtocolHandler *protPtr;
Tcl_Interp *interp;
Atom protocol;
int result;
wmPtr = winPtr->wmInfoPtr;
if (wmPtr == NULL) {
return;
}
protocol = (Atom) eventPtr->xclient.data.l[0];
for (protPtr = wmPtr->protPtr; protPtr != NULL;
protPtr = protPtr->nextPtr) {
if (protocol == protPtr->protocol) {
Tcl_Preserve(protPtr);
interp = protPtr->interp;
Tcl_Preserve(interp);
result = Tcl_EvalEx(interp, protPtr->command, -1, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (command for \"");
Tcl_AddErrorInfo(interp,
Tk_GetAtomName((Tk_Window) winPtr, protocol));
Tcl_AddErrorInfo(interp, "\" window manager protocol)");
Tcl_BackgroundError(interp);
}
Tcl_Release(interp);
Tcl_Release(protPtr);
return;
}
}
/*
* No handler was present for this protocol. If this is a WM_DELETE_WINDOW
* message then just destroy the window.
*/
if (protocol == Tk_InternAtom((Tk_Window) winPtr, "WM_DELETE_WINDOW")) {
Tk_DestroyWindow((Tk_Window) winPtr);
}
}
static void
ConsoleEventProc(
ClientData clientData,
XEvent *eventPtr)
{
if (eventPtr->type == DestroyNotify) {
ConsoleInfo *info = clientData;
Tcl_Interp *consoleInterp = info->consoleInterp;
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_EvalEx(consoleInterp, "tk::ConsoleExit", -1, TCL_EVAL_GLOBAL);
}
if (info->refCount-- <= 1) {
ckfree(info);
}
}
}
static int setup_atomid_map(NLEnergy *p, Tcl_Interp *interp, int32 natoms) {
char script[64];
Tcl_Obj *obj;
Tcl_Obj **objv;
int32 *atomid, *extatomid;
int32 atomidlen;
int objc, i, s;
INT(natoms);
if (natoms <= 0) return ERROR(ERR_EXPECT);
if ((s=Array_resize(&(p->extatomid),natoms)) != OK) return ERROR(s);
extatomid = Array_data(&(p->extatomid));
snprintf(script, sizeof(script), "%s list", p->aselname);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0) ||
NULL==(obj = Tcl_GetObjResult(interp)) ||
TCL_OK != Tcl_ListObjGetElements(interp, obj, &objc, &objv) ||
objc != natoms) {
return ERROR(ERR_EXPECT);
}
for (i = 0; i < objc; i++) {
long n;
if (TCL_OK != Tcl_GetLongFromObj(interp, objv[i], &n)) {
return ERROR(ERR_EXPECT);
}
extatomid[i] = (int32) n;
ASSERT(0==i || extatomid[i-1] < extatomid[i]);
}
ASSERT(i == natoms);
p->firstid = extatomid[0];
p->lastid = extatomid[natoms-1];
INT(p->firstid);
INT(p->lastid);
atomidlen = p->lastid - p->firstid + 1;
ASSERT(atomidlen >= natoms);
if ((s=Array_resize(&(p->atomid),atomidlen)) != OK) return ERROR(s);
atomid = Array_data(&(p->atomid));
for (i = 0; i < atomidlen; i++) { /* initialize */
atomid[i] = FAIL;
}
for (i = 0; i < natoms; i++) {
atomid[ extatomid[i] - p->firstid ] = i;
}
return OK;
}
TDBCAPI int
Tdbc_Init(
Tcl_Interp* interp /* Tcl interpreter */
) {
int i;
/* Require Tcl and Tcl_OO */
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return TCL_ERROR;
}
/* Create the provided commands */
for (i = 0; commandTable[i].name != NULL; ++i) {
Tcl_CreateObjCommand(interp, commandTable[i].name, commandTable[i].proc,
(ClientData) NULL, (Tcl_CmdDeleteProc*) NULL);
}
/* Evaluate the initialization script */
if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) != TCL_OK) {
return TCL_ERROR;
}
/* Provide the TDBC package */
if (Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION,
(ClientData) &tdbcStubs) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* TODO - need (a) to export a Stubs table for (among others)
* the parser entry point, and (b) to create the parse command at
* Tcl level.
*/
return TCL_OK;
}
static void ui_message(Tcl_Interp *interp, const char *severity, const char *format, va_list va) {
char *tclcmd;
char *buf;
if (vasprintf(&buf, format, va) < 0) {
perror("vasprintf");
return;
}
if (asprintf(&tclcmd, "ui_%s $warn", severity) < 0) {
perror("asprintf");
free(buf);
return;
}
Tcl_SetVar(interp, "warn", buf, 0);
if (TCL_OK != Tcl_EvalEx(interp, tclcmd, -1, 0)) {
fprintf(stderr, "Error evaluating Tcl statement '%s': %s (message: '%s')\n", tclcmd, Tcl_GetStringResult(interp), buf);
}
Tcl_UnsetVar(interp, "warn", 0);
free(buf);
free(tclcmd);
}
int ScriptTcl::Tcl_replicaEval(ClientData, Tcl_Interp *interp, int argc, char **argv) {
if ( argc != 3 ) {
Tcl_SetResult(interp,"args: dest script",TCL_VOLATILE);
return TCL_ERROR;
}
int dest = atoi(argv[1]);
CHECK_REPLICA(dest);
#if CMK_HAS_PARTITION
Tcl_DString recvstr;
Tcl_DStringInit(&recvstr);
DataMessage *recvMsg = NULL;
replica_eval(argv[2], dest, CkMyPe(), &recvMsg);
CmiAssert(recvMsg != NULL);
int code = recvMsg->code;
Tcl_DStringAppend(&recvstr, recvMsg->data, recvMsg->size);
Tcl_DStringResult(interp, &recvstr);
Tcl_DStringFree(&recvstr);
CmiFree(recvMsg);
return code;
#else
return Tcl_EvalEx(interp,argv[2],-1,TCL_EVAL_GLOBAL);
#endif
}
static OSErr
PrintHandler(
const AppleEvent * event,
AppleEvent * reply,
long handlerRefcon)
{
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
AEDescList fileSpecList;
FSRef file;
DescType type;
Size actual;
long count, index;
AEKeyword keyword;
Tcl_DString command, pathName;
Tcl_CmdInfo dummy;
/*
* Don't bother if we don't have an interp or the print document procedure
* doesn't exist.
*/
if (!interp ||
!Tcl_GetCommandInfo(interp, "::tk::mac::PrintDocument", &dummy)) {
return noErr;
}
/*
* If we get any errors while retrieving our parameters we just return with
* no error.
*/
if (ChkErr(AEGetParamDesc, event, keyDirectObject, typeAEList,
&fileSpecList) != noErr) {
return noErr;
}
if (ChkErr(MissedAnyParameters, event) != noErr) {
return noErr;
}
if (ChkErr(AECountItems, &fileSpecList, &count) != noErr) {
return noErr;
}
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, "::tk::mac::PrintDocument", -1);
for (index = 1; index <= count; index++) {
if (ChkErr(AEGetNthPtr, &fileSpecList, index, typeFSRef, &keyword,
&type, (Ptr) &file, sizeof(FSRef), &actual) != noErr) {
continue;
}
if (ChkErr(FSRefToDString, &file, &pathName) == noErr) {
Tcl_DStringAppendElement(&command, Tcl_DStringValue(&pathName));
Tcl_DStringFree(&pathName);
}
}
/*
* Now handle the event by evaluating a script.
*/
if (Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_BackgroundError(interp);
}
Tcl_DStringFree(&command);
return noErr;
}
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);
}
/****
* implementation of Tcl shape_manipulate routine
****/
int tclShapeManipulate(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
int slot, i, j, k, len, shft;
char expr[2048];
double a, p;
Tcl_Obj *tclres;
if ( (argc < 3) || (argc > 10) )
return TclError(interp,"usage: shape_manipulate <RFshape> -ampl <ampl expr> | -phase <phase expr> | -time_reversal | -phase_invert | -cyclic_shift N");
if (Tcl_GetInt(interp,argv[1],&slot) == TCL_ERROR)
return TclError(interp,"save_manipulate: argument 1 must be integer <RFshape>");
/* check for RFshape existence */
if (!RFshapes[slot])
return TclError(interp,"shape_manipulate: trying to acces non-existing RFshape");
len = RFshapes_len(slot);
for (i=2; i<argc; i++) {
if (!strcmp(argv[i],"-time_reversal")) {
for (j=1; j<= len/2; j++) {
k = len+1-j;
a = RFshapes[slot][k].ampl;
p = RFshapes[slot][k].phase;
RFshapes[slot][k].ampl = RFshapes[slot][j].ampl;
RFshapes[slot][k].phase = RFshapes[slot][j].phase;
RFshapes[slot][j].ampl = a;
RFshapes[slot][j].phase = p;
}
} else if (!strcmp(argv[i],"-phase_invert")) {
for (j=1; j<=len; j++) {
RFshapes[slot][j].phase = -RFshapes[slot][j].phase;
}
} else if (!strcmp(argv[i],"-cyclic_shift")) {
RFelem* v;
i++;
if (Tcl_GetInt(interp,argv[i],&shft) == TCL_ERROR)
return TclError(interp,"shape_manipulate: argument following -cyclic_shift must be integer");
v = (RFelem*)malloc((len+1)*sizeof(RFelem));
if (!v) {
fprintf(stderr,"error in shape_manipulate: unable to alocate temporary RFshape");
exit(-1);
}
/* store its length to the first element */
*(int*)v=len;
for (j=1; j<=len; j++) {
v[j].ampl = RFshapes[slot][j].ampl;
v[j].phase = RFshapes[slot][j].phase;
}
shft = shft % len;
for (j=1; j<= len; j++) {
k = (len + shft + j) % len;
if (k <= 0) k += len;
RFshapes[slot][k].ampl = v[j].ampl;
RFshapes[slot][k].phase = v[j].phase;
}
free((char *)v);
} else if (!strcmp(argv[i],"-ampl")) {
i++;
/* evaluate expression in Tcl */
for (j=1; j<=len; j++) {
sprintf(expr,"\n set i %d\n set ampl %f\n set phase %f\n expr %s\n", j, RFshapes[slot][j].ampl, RFshapes[slot][j].phase, argv[i]);
if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK )
return TclError(interp,"error in shape_manipulate: can not evaluate %s for index %d",argv[i], j);
tclres = Tcl_GetObjResult(interp);
if ( Tcl_GetDoubleFromObj(interp,tclres,&a) != TCL_OK )
return TclError(interp,"error in shape_manipulate: can not get amplitude result for index %d",j);
RFshapes[slot][j].ampl = a;
}
} else if (!strcmp(argv[i],"-phase")) {
i++;
/* evaluate expression in Tcl */
for (j=1; j<=len; j++) {
sprintf(expr,"\n set i %d\n set ampl %f\n set phase %f\n expr %s\n", j, RFshapes[slot][j].ampl, RFshapes[slot][j].phase, argv[i]);
if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK )
return TclError(interp,"error in shape_manipulate: can not evaluate %s for index %d",argv[i], j);
tclres = Tcl_GetObjResult(interp);
if ( Tcl_GetDoubleFromObj(interp,tclres,&p) != TCL_OK )
return TclError(interp,"error in shape_manipulate: can not get amplitude result for index %d",j);
RFshapes[slot][j].phase = p;
}
}
}
return TCL_OK;
}
/*
* Loads the initialization script from image file resource
*/
TCL_RESULT Twapi_SourceResource(Tcl_Interp *interp, HANDLE dllH, const char *name, int try_file)
{
HRSRC hres = NULL;
unsigned char *dataP;
DWORD sz;
HGLOBAL hglob;
int result;
int compressed;
Tcl_Obj *pathObj;
/*
* Locate the twapi resource and load it if found. First check for
* compressed type. Then uncompressed.
*/
compressed = 1;
hres = FindResourceA(dllH,
name,
TWAPI_SCRIPT_RESOURCE_TYPE_LZMA);
if (!hres) {
hres = FindResourceA(dllH,
name,
TWAPI_SCRIPT_RESOURCE_TYPE);
compressed = 0;
}
if (hres) {
sz = SizeofResource(dllH, hres);
hglob = LoadResource(dllH, hres);
if (sz && hglob) {
dataP = LockResource(hglob);
if (dataP) {
/* If compressed, we need to uncompress it first */
if (compressed) {
dataP = TwapiLzmaUncompressBuffer(interp, dataP, sz, &sz);
if (dataP == NULL)
return TCL_ERROR; /* interp already has error */
}
/* The resource is expected to be UTF-8 (actually strict ASCII) */
/* TBD - double check use of GLOBAL and DIRECT */
result = Tcl_EvalEx(interp, (char *)dataP, sz, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
if (compressed)
TwapiLzmaFreeBuffer(dataP);
if (result == TCL_OK)
Tcl_ResetResult(interp);
return result;
}
}
return Twapi_AppendSystemError(interp, GetLastError());
}
if (!try_file) {
Tcl_AppendResult(interp, "Resource ", name, " not found.", NULL);
return TCL_ERROR;
}
/*
* No resource found. Try loading from twapi script directory if defined
* or from the twapi dll install directory
*/
pathObj = Tcl_GetVar2Ex(interp, "::" TWAPI_TCL_NAMESPACE "::scriptdir",
NULL, 0);
if (pathObj != NULL) {
pathObj = Tcl_DuplicateObj(pathObj);
Tcl_AppendToObj(pathObj, "/", 1);
} else {
Tcl_ResetResult(interp); /* Since the GetVar may have store error */
pathObj = TwapiGetInstallDir(interp, dllH);
}
if (pathObj == NULL)
return TCL_ERROR;
ObjIncrRefs(pathObj); /* Must before calling any Tcl_FS functions */
/* This bit of shenanigans is to allow MingW based builds to load
* twapi modules from files without requiring a resource */
#if defined(__GNUC__)
if (lstrlenA(name) > 6 && _strnicmp(name, "twapi_", 6) == 0)
name += 6;
#endif
Tcl_AppendStringsToObj(pathObj, name, ".tcl", NULL);
result = Tcl_FSEvalFile(interp, pathObj);
ObjDecrRefs(pathObj);
return result;
#if 0
/* Caller should be doing PkgProvide as appropriate. This function
is not only called for packages.
*/
if (result != TCL_OK)
return result;
return Tcl_PkgProvide(interp, MODULENAME, MODULEVERSION);
#endif
}
int NLEnergy_setup(NLEnergy *p, Tcl_Interp *interp, int idnum, int molid,
const char *aselname) {
char script[64];
Tcl_Obj *obj;
int objc;
Tcl_Obj **objv;
int natoms, i;
NonbPrm nonbprm;
ForcePrm *fprm = &(p->fprm);
Topology *topo = &(p->topo);
Coord *coord = &(p->coord);
int s;
int nbonds, cnt;
double alpha, beta, gamma, A, B, C;
double epsalpha, epsbeta, epsgamma, cosAB, sinAB, cosAC, cosBC;
dvec bv1, bv2, bv3, orig; /* basis vectors and origin */
dvec *pos;
p->idnum = idnum;
p->molid = molid;
/* duplicate atom selection name before returning,
* use atom selection to init topology and coordinates */
if (NULL==(p->aselname = NL_strdup(aselname))) return ERROR(ERR_MEMALLOC);
STR(p->aselname);
/* set reasonable default nonbonded parameters */
nonbprm.cutoff = 12;
nonbprm.switchdist = 10;
nonbprm.dielectric = 1;
nonbprm.scaling14 = 1;
nonbprm.switching = TRUE;
nonbprm.exclude = EXCL_SCALED14;
nonbprm.charge_model = CHARGE_FIXED;
nonbprm.water_model = WATER_TIP3;
if ((s=ForcePrm_set_nonbprm(fprm, &nonbprm)) != OK) return ERROR(s);
p->fulldirect = FALSE;
p->fulldirectvdw = FALSE;
/* determine number of atoms for this selection */
snprintf(script, sizeof(script), "%s num", p->aselname);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0)) return ERROR(ERR_EXPECT);
if (NULL==(obj = Tcl_GetObjResult(interp))) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_GetIntFromObj(interp, obj, &natoms)) {
return ERROR(ERR_EXPECT);
}
INT(natoms);
/* setup map for external atom numbering */
if ((s=setup_atomid_map(p,interp,natoms)) != OK) return ERROR(ERR_EXPECT);
/* read Atom data from our VMD atom selection */
if ((s=Topology_setmaxnum_atom(topo, natoms)) != OK) return ERROR(s);
snprintf(script, sizeof(script),
"%s get { mass charge name type residue resname }", p->aselname);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0)) return ERROR(ERR_EXPECT);
if (NULL==(obj = Tcl_GetObjResult(interp))) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_ListObjGetElements(interp, obj, &objc, &objv)) {
return ERROR(ERR_EXPECT);
}
if (objc != natoms) return ERROR(ERR_EXPECT);
for (i = 0; i < natoms; i++) {
Atom a;
int aobjc;
Tcl_Obj **aobjv;
int n;
double d;
char *str;
memset(&a, 0, sizeof(Atom));
if (TCL_OK != Tcl_ListObjGetElements(interp, objv[i], &aobjc, &aobjv)) {
return ERROR(ERR_EXPECT);
}
if (aobjc != 6) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_GetDoubleFromObj(interp, aobjv[0], &d)) {
return ERROR(ERR_EXPECT);
}
a.m = d; /* atom mass */
if (TCL_OK != Tcl_GetDoubleFromObj(interp, aobjv[1], &d)) {
return ERROR(ERR_EXPECT);
}
a.q = d; /* atom charge */
str = Tcl_GetStringFromObj(aobjv[2], NULL);
snprintf(a.atomName, sizeof(AtomName), "%s", str);
str = Tcl_GetStringFromObj(aobjv[3], NULL);
snprintf(a.atomType, sizeof(AtomType), "%s", str);
if (TCL_OK != Tcl_GetIntFromObj(interp, aobjv[4], &n)) {
return ERROR(ERR_EXPECT);
}
a.residue = n;
str = Tcl_GetStringFromObj(aobjv[5], NULL);
snprintf(a.resName, sizeof(ResName), "%s", str);
if ((s=Topology_add_atom(topo, &a)) != i) return ERROR(s);
}
TEXT("successfully initialized atoms");
/*
* read Bond data from VMD atom selection
* this is stored in adjacency list format where each atom
* has a list of atoms to which it is bonded
*/
snprintf(script, sizeof(script), "%s getbonds", p->aselname);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0)) return ERROR(ERR_EXPECT);
if (NULL==(obj = Tcl_GetObjResult(interp))) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_ListObjGetElements(interp, obj, &objc, &objv)) {
return ERROR(ERR_EXPECT);
}
if (objc != natoms) return ERROR(ERR_EXPECT);
/* first determine number of bonds */
nbonds = 0;
for (i = 0; i < natoms; i++) {
int bobjc, j, k;
Tcl_Obj **bobjv;
if (TCL_OK != Tcl_ListObjGetElements(interp, objv[i], &bobjc, &bobjv)) {
return ERROR(ERR_EXPECT);
}
/* count only bonds to atoms within this atom selection */
for (k = 0; k < bobjc; k++) {
if ((j=atomid_from_obj(p,interp,bobjv[k])) >= 0) nbonds++;
else if (j < FAIL) return ERROR(j);
}
}
nbonds >>= 1; /* double counted, divide nbonds by 2 */
INT(nbonds);
if ((s=Topology_setmaxnum_bond(topo, nbonds)) != OK) return ERROR(s);
cnt = 0;
for (i = 0; i < natoms; i++) {
int bobjc, j, k;
Tcl_Obj **bobjv;
if (TCL_OK != Tcl_ListObjGetElements(interp, objv[i], &bobjc, &bobjv)) {
return ERROR(ERR_EXPECT);
}
for (k = 0; k < bobjc; k++) {
if ((j=atomid_from_obj(p,interp,bobjv[k])) < FAIL) return ERROR(j);
if (i < j) {
Bond b;
b.atomID[0] = i;
b.atomID[1] = j;
if ((s=Topology_add_bond(topo, &b)) < OK) return ERROR(s);
cnt++;
}
}
}
if (cnt != nbonds) return ERROR(ERR_EXPECT);
TEXT("successfully initialized bonds");
if ((s=Topology_setup_atom_cluster(topo)) != OK) return ERROR(s);
if ((s=Topology_setup_atom_parent(topo)) != OK) return ERROR(s);
Topology_reset_status(topo, TOPO_ATOM_ADD | TOPO_BOND_ADD);
/* get periodic cell information */
snprintf(script, sizeof(script),
"molinfo %d get { alpha beta gamma a b c }", p->molid);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0)) return ERROR(ERR_EXPECT);
if (NULL==(obj = Tcl_GetObjResult(interp))) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_ListObjGetElements(interp, obj, &objc, &objv)) {
return ERROR(ERR_EXPECT);
}
if (objc != 6) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[0], &alpha)) {
return ERROR(ERR_EXPECT);
}
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[1], &beta)) {
return ERROR(ERR_EXPECT);
}
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[2], &gamma)) {
return ERROR(ERR_EXPECT);
}
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[3], &A)) {
return ERROR(ERR_EXPECT);
}
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[4], &B)) {
return ERROR(ERR_EXPECT);
}
if (TCL_OK != Tcl_GetDoubleFromObj(interp, objv[5], &C)) {
return ERROR(ERR_EXPECT);
}
/* convert from VMD (crystallographic-style cell) to NAMD basis vectors */
epsalpha = (alpha - 90.0) * RADIANS;
epsbeta = (beta - 90.0) * RADIANS;
epsgamma = (gamma - 90.0) * RADIANS;
cosAB = -sin(epsgamma);
sinAB = cos(epsgamma);
cosAC = -sin(epsbeta);
cosBC = -sin(epsalpha);
bv1.x = A;
bv1.y = 0;
bv1.z = 0;
bv2.x = B * cosAB;
bv2.y = B * sinAB;
bv2.z = 0;
if (bv2.y != 0) {
bv3.x = C * cosAC;
bv3.y = (B * C * cosBC - bv2.x * bv3.x) / bv2.y;
bv3.z = sqrt(C * C - bv3.x * bv3.x - bv3.y * bv3.y);
}
else {
VECZERO(bv3);
}
VECZERO(orig);
if ((s=Coord_setup(coord, &orig, &bv1, &bv2, &bv3, topo)) != OK) {
return ERROR(s);
}
pos = Coord_pos(coord);
memset(Coord_vel(coord), 0, natoms*sizeof(dvec));
memset(Coord_force(coord), 0, natoms*sizeof(dvec));
TEXT("initialized coordinate domain");
VEC(bv1);
VEC(bv2);
VEC(bv3);
VEC(orig);
INT(Coord_domain(coord)->periodic_x);
INT(Coord_domain(coord)->periodic_y);
INT(Coord_domain(coord)->periodic_z);
/* read coordinate data from our VMD atom selection */
snprintf(script, sizeof(script), "%s get { x y z }", p->aselname);
if (TCL_OK != Tcl_EvalEx(interp, script, -1, 0)) return ERROR(ERR_EXPECT);
if (NULL==(obj = Tcl_GetObjResult(interp))) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_ListObjGetElements(interp, obj, &objc, &objv)) {
return ERROR(ERR_EXPECT);
}
if (objc != natoms) return ERROR(ERR_EXPECT);
for (i = 0; i < natoms; i++) {
double d;
int cobjc;
Tcl_Obj **cobjv;
if (TCL_OK != Tcl_ListObjGetElements(interp, objv[i], &cobjc, &cobjv)) {
return ERROR(ERR_EXPECT);
}
if (cobjc != 3) return ERROR(ERR_EXPECT);
if (TCL_OK != Tcl_GetDoubleFromObj(interp, cobjv[0], &d)) {
return ERROR(ERR_EXPECT);
}
pos[i].x = d;
if (TCL_OK != Tcl_GetDoubleFromObj(interp, cobjv[1], &d)) {
return ERROR(ERR_EXPECT);
}
pos[i].y = d;
if (TCL_OK != Tcl_GetDoubleFromObj(interp, cobjv[2], &d)) {
return ERROR(ERR_EXPECT);
}
pos[i].z = d;
}
if ((s=Coord_update_pos(coord, UPDATE_ALL)) != OK) return ERROR(s);
TEXT("initialized coordinate positions");
if ((s=Fbonded_setup(&(p->fbon), Coord_domain(coord))) != OK) {
return ERROR(s);
}
return OK;
}
static OSErr
ScriptHandler(
const AppleEvent *event,
AppleEvent *reply,
SRefCon handlerRefcon)
{
OSStatus theErr;
AEDescList theDesc;
int tclErr = -1;
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
char errString[128];
/*
* The do script event receives one parameter that should be data or a
* file.
*/
theErr = AEGetParamDesc(event, keyDirectObject, typeWildCard,
&theDesc);
if (theErr != noErr) {
sprintf(errString, "AEDoScriptHandler: GetParamDesc error %d",
(int)theErr);
theErr = AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
} else if (MissedAnyParameters(event)) {
/*
* Return error if parameter is missing.
*/
sprintf(errString, "AEDoScriptHandler: extra parameters");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1771;
} else if (theDesc.descriptorType == (DescType) typeChar) {
/*
* We've had some data sent to us. Evaluate it.
*/
Tcl_DString encodedText;
short i;
Size size = AEGetDescDataSize(&theDesc);
char *data = ckalloc(size + 1);
AEGetDescData(&theDesc, data, size);
data[size] = 0;
for (i = 0; i < size; i++) {
if (data[i] == '\r') {
data[i] = '\n';
}
}
AEReplaceDescData(theDesc.descriptorType, data, size + 1, &theDesc);
Tcl_ExternalToUtfDString(NULL, data, size, &encodedText);
tclErr = Tcl_EvalEx(interp, Tcl_DStringValue(&encodedText),
Tcl_DStringLength(&encodedText), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&encodedText);
} else if (theDesc.descriptorType == (DescType) typeAlias) {
/*
* We've had a file sent to us. Source it.
*/
Boolean dummy;
FSRef file;
Size theSize = AEGetDescDataSize(&theDesc);
AliasPtr alias = (AliasPtr) ckalloc(theSize);
if (alias) {
AEGetDescData(&theDesc, alias, theSize);
theErr = FSResolveAlias(NULL, &alias, &file, &dummy);
ckfree((char*)alias);
} else {
theErr = memFullErr;
}
if (theErr == noErr) {
Tcl_DString scriptName;
theErr = FSRefToDString(&file, &scriptName);
if (theErr == noErr) {
Tcl_EvalFile(interp, Tcl_DStringValue(&scriptName));
Tcl_DStringFree(&scriptName);
}
} else {
sprintf(errString, "AEDoScriptHandler: file not found");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
}
} else {
/*
* Umm, don't recognize what we've got...
*/
sprintf(errString, "AEDoScriptHandler: invalid script type '%-4.4s',"
" must be 'alis' or 'TEXT'", (char*) &theDesc.descriptorType);
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1770;
}
/*
* If we actually go to run Tcl code - put the result in the reply.
*/
if (tclErr >= 0) {
int reslen;
const char *result =
Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &reslen);
if (tclErr == TCL_OK) {
AEPutParamPtr(reply, keyDirectObject, typeChar, result, reslen);
} else {
AEPutParamPtr(reply, keyErrorString, typeChar, result, reslen);
AEPutParamPtr(reply, keyErrorNumber, typeSInt32, (Ptr) &tclErr,
sizeof(int));
}
}
AEDisposeDesc(&theDesc);
return theErr;
}
__declspec(dllexport) int
#else
extern int
#endif
TclKit_AppInit(Tcl_Interp *interp)
{
/*
* Ensure that std channels exist (creating them if necessary)
*/
TclKit_InitStdChannels();
#ifdef KIT_INCLUDES_ITCL
Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL);
#endif
#ifdef KIT_LITE
Tcl_StaticPackage(0, "vlerq", Vlerq_Init, Vlerq_SafeInit);
#else
Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85
Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL);
#endif
Tcl_StaticPackage(0, "tclkitpath", TclKitPath_Init, NULL);
Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
#if KIT_INCLUDES_ZLIB
Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
#endif
#ifdef TCL_THREADS
Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit);
#endif
#ifdef _WIN32
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit);
#else
Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
#endif
Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
#endif
#ifdef KIT_INCLUDES_TK
Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
#endif
/* insert custom packages here */
/* the tcl_rcFileName variable only exists in the initial interpreter */
#ifdef _WIN32
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY);
#endif
#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84
{
Tcl_DString encodingName;
Tcl_GetEncodingNameFromEnvironment(&encodingName);
if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
/* fails, so we set a variable and do it in the boot.tcl script */
Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
}
Tcl_SetVar(interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0);
Tcl_DStringFree(&encodingName);
}
#endif
TclSetPreInitScript(preInitCmd);
if (Tcl_Init(interp) == TCL_ERROR)
goto error;
#if defined(KIT_INCLUDES_TK) && defined(_WIN32)
if (Tk_Init(interp) == TCL_ERROR)
goto error;
if (Tk_CreateConsoleWindow(interp) == TCL_ERROR)
goto error;
#endif
/* messy because TclSetStartupScriptPath is called slightly too late */
if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) {
const char *encoding = NULL;
Tcl_Obj* path = Tcl_GetStartupScript(&encoding);
Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding);
if (path == NULL) {
Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
}
}
Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY);
Tcl_ResetResult(interp);
return TCL_OK;
error:
#if defined(KIT_INCLUDES_TK) && defined(_WIN32)
MessageBeep(MB_ICONEXCLAMATION);
MessageBox(NULL, Tcl_GetStringResult(interp), "Error in Tclkit",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
ExitProcess(1);
/* we won't reach this, but we need the return */
#endif
return TCL_ERROR;
}
/*
* ------------------------------------------------------------------------
* 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;
}
static OSErr
ScriptHandler(
const AppleEvent *event,
AppleEvent *reply,
long handlerRefcon)
{
OSStatus theErr;
AEDescList theDesc;
Size size;
int tclErr = -1;
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
char errString[128];
/*
* The do script event receives one parameter that should be data or a
* file.
*/
theErr = AEGetParamDesc(event, keyDirectObject, typeWildCard,
&theDesc);
if (theErr != noErr) {
sprintf(errString, "AEDoScriptHandler: GetParamDesc error %d",
(int)theErr);
theErr = AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
} else if (MissedAnyParameters(event)) {
/*
* Return error if parameter is missing.
*/
sprintf(errString, "AEDoScriptHandler: extra parameters");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1771;
} else if (theDesc.descriptorType == (DescType) typeAlias &&
AEGetParamPtr(event, keyDirectObject, typeFSRef, NULL, NULL,
0, &size) == noErr && size == sizeof(FSRef)) {
/*
* We've had a file sent to us. Source it.
*/
FSRef file;
theErr = AEGetParamPtr(event, keyDirectObject, typeFSRef, NULL, &file,
size, NULL);
if (theErr == noErr) {
Tcl_DString scriptName;
theErr = FSRefToDString(&file, &scriptName);
if (theErr == noErr) {
tclErr = Tcl_EvalFile(interp, Tcl_DStringValue(&scriptName));
Tcl_DStringFree(&scriptName);
} else {
sprintf(errString, "AEDoScriptHandler: file not found");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
}
}
} else if (AEGetParamPtr(event, keyDirectObject, typeUTF8Text, NULL, NULL,
0, &size) == noErr && size) {
/*
* We've had some data sent to us. Evaluate it.
*/
char *data = ckalloc(size + 1);
theErr = AEGetParamPtr(event, keyDirectObject, typeUTF8Text, NULL, data,
size, NULL);
if (theErr == noErr) {
tclErr = Tcl_EvalEx(interp, data, size, TCL_EVAL_GLOBAL);
}
} else {
/*
* Umm, don't recognize what we've got...
*/
sprintf(errString, "AEDoScriptHandler: invalid script type '%-4.4s', "
"must be 'alis' or coercable to 'utf8'",
(char*) &theDesc.descriptorType);
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1770;
}
/*
* If we actually go to run Tcl code - put the result in the reply.
*/
if (tclErr >= 0) {
int reslen;
const char *result =
Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &reslen);
if (tclErr == TCL_OK) {
AEPutParamPtr(reply, keyDirectObject, typeChar, result, reslen);
} else {
AEPutParamPtr(reply, keyErrorString, typeChar, result, reslen);
AEPutParamPtr(reply, keyErrorNumber, typeSInt32, (Ptr) &tclErr,
sizeof(int));
}
}
AEDisposeDesc(&theDesc);
return theErr;
}
int
Tk_CreateConsoleWindow(
Tcl_Interp *interp) /* Interpreter to use for prompting. */
{
Tcl_Channel chan;
ConsoleInfo *info;
Tk_Window mainWindow;
Tcl_Command token;
int result = TCL_OK;
int haveConsoleChannel = 1;
/* Init an interp with Tcl and Tk */
Tcl_Interp *consoleInterp = Tcl_CreateInterp();
if (Tcl_Init(consoleInterp) != TCL_OK) {
Tcl_Obj *result_obj = Tcl_GetObjResult(consoleInterp);
Tcl_SetObjResult(interp, result_obj);
goto error;
}
if (Tk_Init(consoleInterp) != TCL_OK) {
Tcl_Obj *result_obj = Tcl_GetObjResult(consoleInterp);
Tcl_SetObjResult(interp, result_obj);
goto error;
}
/*
* Fetch the instance data from whatever std channel is a
* console channel. If none, create fresh instance data.
*/
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
} else {
haveConsoleChannel = 0;
}
if (haveConsoleChannel) {
ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
info = data->info;
if (info->consoleInterp) {
/*
* New ConsoleInfo for a new console window.
*/
info = ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
/*
* Update any console channels to make use of the new console.
*/
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
}
} else {
info = ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
}
info->consoleInterp = consoleInterp;
info->interp = interp;
Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info);
info->refCount++;
Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp);
/*
* Add console commands to the interp
*/
token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info,
ConsoleDeleteProc);
info->refCount++;
/*
* We don't have to count the ref held by the [consoleinterp] command
* in the consoleInterp. The ref held by the consoleInterp delete
* handler takes care of us.
*/
Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
info, NULL);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
info->refCount++;
}
Tcl_Preserve(consoleInterp);
result = Tcl_EvalEx(consoleInterp, "source $tk_library/console.tcl",
-1, TCL_EVAL_GLOBAL);
if (result == TCL_ERROR) {
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(consoleInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
}
Tcl_Release(consoleInterp);
if (result == TCL_ERROR) {
Tcl_DeleteCommandFromToken(interp, token);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
if (info->refCount-- <= 1) {
ckfree(info);
}
}
goto error;
}
return TCL_OK;
error:
Tcl_AddErrorInfo(interp, "\n (creating console window)");
if (!Tcl_InterpDeleted(consoleInterp)) {
Tcl_DeleteInterp(consoleInterp);
}
return TCL_ERROR;
}
void
TkMacOSXHandleMenuSelect(
MenuID theMenu,
MenuItemIndex theItem,
int optionKeyPressed)
{
Tk_Window tkwin;
Window window;
TkDisplay *dispPtr;
Tcl_CmdInfo dummy;
int code;
if (theItem == 0) {
TkMacOSXClearMenubarActive();
return;
}
switch (theMenu) {
case kAppleMenu:
switch (theItem) {
case kAppleAboutItem:
if (optionKeyPressed || gInterp == NULL ||
Tcl_GetCommandInfo(gInterp, "tkAboutDialog", &dummy) == 0) {
TkAboutDlg();
} else {
code = Tcl_EvalEx(gInterp, "tkAboutDialog", -1,
TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_ResetResult(gInterp);
}
break;
}
break;
case kFileMenu:
switch (theItem) {
case kSourceItem:
if (gInterp) {
if (Tcl_EvalEx(gInterp, "tk_getOpenFile -filetypes {"
"{{TCL Scripts} {.tcl} TEXT} {{Text Files} {} TEXT}}",
-1, TCL_EVAL_GLOBAL) == TCL_OK) {
Tcl_Obj *path = Tcl_GetObjResult(gInterp);
int len;
Tcl_GetStringFromObj(path, &len);
if (len) {
Tcl_IncrRefCount(path);
code = Tcl_FSEvalFile(gInterp, path);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_DecrRefCount(path);
}
}
Tcl_ResetResult(gInterp);
}
break;
case kDemoItem:
if (gInterp) {
Tcl_Obj *path = GetWidgetDemoPath(gInterp);
if (path) {
Tcl_IncrRefCount(path);
code = Tcl_FSEvalFile(gInterp, path);
if (code != TCL_OK) {
Tcl_BackgroundException(gInterp, code);
}
Tcl_DecrRefCount(path);
Tcl_ResetResult(gInterp);
}
}
break;
case kCloseItem:
/* Send close event */
window = TkMacOSXGetXWindow(ActiveNonFloatingWindow());
dispPtr = TkGetDisplayList();
tkwin = Tk_IdToWindow(dispPtr->display, window);
TkGenWMDestroyEvent(tkwin);
break;
}
break;
case kEditMenu:
/*
* This implementation just send the keysyms Tk thinks are associated
* with function keys that do Cut, Copy & Paste on a Sun keyboard.
*/
GenerateEditEvent(theItem);
break;
default:
TkMacOSXDispatchMenuEvent(theMenu, theItem);
break;
}
/*
* Finally we unhighlight the menu.
*/
HiliteMenu(0);
}
void
TkpDisplayScale(
ClientData clientData) /* Widget record for scale. */
{
TkScale *scalePtr = (TkScale *) clientData;
Tk_Window tkwin = scalePtr->tkwin;
Tcl_Interp *interp = scalePtr->interp;
Pixmap pixmap;
int result;
char string[PRINT_CHARS];
XRectangle drawnArea;
Tcl_DString buf;
scalePtr->flags &= ~REDRAW_PENDING;
if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) {
goto done;
}
/*
* Invoke the scale's command if needed.
*/
Tcl_Preserve(scalePtr);
if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) {
Tcl_Preserve(interp);
sprintf(string, scalePtr->format, scalePtr->value);
Tcl_DStringInit(&buf);
Tcl_DStringAppend(&buf, scalePtr->command, -1);
Tcl_DStringAppend(&buf, " ", -1);
Tcl_DStringAppend(&buf, string, -1);
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (command executed by scale)");
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
}
scalePtr->flags &= ~INVOKE_COMMAND;
if (scalePtr->flags & SCALE_DELETED) {
Tcl_Release(scalePtr);
return;
}
Tcl_Release(scalePtr);
#ifndef TK_NO_DOUBLE_BUFFERING
/*
* In order to avoid screen flashes, this function redraws the scale in a
* pixmap, then copies the pixmap to the screen in a single operation.
* This means that there's no point in time where the on-sreen image has
* been cleared.
*/
pixmap = Tk_GetPixmap(scalePtr->display, Tk_WindowId(tkwin),
Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin));
#else
pixmap = Tk_WindowId(tkwin);
#endif /* TK_NO_DOUBLE_BUFFERING */
drawnArea.x = 0;
drawnArea.y = 0;
drawnArea.width = Tk_Width(tkwin);
drawnArea.height = Tk_Height(tkwin);
/*
* Much of the redisplay is done totally differently for horizontal and
* vertical scales. Handle the part that's different.
*/
if (scalePtr->orient == ORIENT_VERTICAL) {
DisplayVerticalScale(scalePtr, pixmap, &drawnArea);
} else {
DisplayHorizontalScale(scalePtr, pixmap, &drawnArea);
}
/*
* Now handle the part of redisplay that is the same for horizontal and
* vertical scales: border and traversal highlight.
*/
if (scalePtr->flags & REDRAW_OTHER) {
if (scalePtr->relief != TK_RELIEF_FLAT) {
Tk_Draw3DRectangle(tkwin, pixmap, scalePtr->bgBorder,
scalePtr->highlightWidth, scalePtr->highlightWidth,
Tk_Width(tkwin) - 2*scalePtr->highlightWidth,
Tk_Height(tkwin) - 2*scalePtr->highlightWidth,
scalePtr->borderWidth, scalePtr->relief);
}
if (scalePtr->highlightWidth != 0) {
GC gc;
if (scalePtr->flags & GOT_FOCUS) {
gc = Tk_GCForColor(scalePtr->highlightColorPtr, pixmap);
} else {
gc = Tk_GCForColor(
Tk_3DBorderColor(scalePtr->highlightBorder), pixmap);
}
Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, pixmap);
}
}
#ifndef TK_NO_DOUBLE_BUFFERING
/*
* Copy the information from the off-screen pixmap onto the screen, then
* delete the pixmap.
*/
XCopyArea(scalePtr->display, pixmap, Tk_WindowId(tkwin),
scalePtr->copyGC, drawnArea.x, drawnArea.y, drawnArea.width,
drawnArea.height, drawnArea.x, drawnArea.y);
Tk_FreePixmap(scalePtr->display, pixmap);
#endif /* TK_NO_DOUBLE_BUFFERING */
done:
scalePtr->flags &= ~REDRAW_ALL;
}
bool InterceptClientCommand(CClientConnection* Client, const char* Subcommand, int argc, const char** argv, bool NoticeUser) {
CUser* User = Client->GetOwner();
g_NoticeUser = NoticeUser;
g_CurrentClient = Client;
g_Ret = true;
CallBinds(Type_Command, Client->GetOwner()->GetUsername(), Client, argc, argv);
if (g_Ret && strcasecmp(Subcommand, "help") == 0 && User && User->IsAdmin()) {
commandlist_t *Commands = Client->GetCommandList();
AddCommand(Commands, "tcl", "Admin", "executes tcl commands", "Syntax: "
"tcl command\nExecutes the specified tcl command.");
g_Ret = false;
}
if (g_Ret && strcasecmp(Subcommand, "tcl") == 0 && User && User->IsAdmin()) {
if (argc <= 1) {
if (NoticeUser)
Client->RealNotice("Syntax: tcl :command");
else
Client->Privmsg("Syntax: tcl :command");
return true;
}
setctx(User->GetUsername());
Tcl_DString dsScript;
const char **argvdup;
argvdup = ArgDupArray(argv);
ArgRejoinArray(argvdup, 1);
g_CurrentClient = Client;
int Code = Tcl_EvalEx(g_Interp, Tcl_UtfToExternalDString(g_Encoding, argvdup[1], -1, &dsScript),
-1, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
ArgFreeArray(argvdup);
Tcl_DStringFree(&dsScript);
Tcl_Obj* Result = Tcl_GetObjResult(g_Interp);
const char* strResult = Tcl_GetString(Result);
if (Code == TCL_ERROR) {
if (NoticeUser)
Client->RealNotice("An error occured in the tcl script:");
else
Client->Privmsg("An error occured in the tcl script:");
}
if (strResult && *strResult) {
Tcl_DString dsResult;
char* Dup = strdup(Tcl_UtfToExternalDString(g_Encoding, strResult, -1, &dsResult));
Tcl_DStringFree(&dsResult);
char* token = strtok(Dup, "\n");
while (token != NULL) {
if (NoticeUser)
Client->RealNotice(*token ? token : "empty string.");
else
Client->Privmsg(*token ? token : "empty string.");
token = strtok(NULL, "\n");
}
free(Dup);
} else {
if (NoticeUser)
Client->RealNotice("<no error>");
else
Client->Privmsg("<no error>");
}
g_Ret = false;
}
return !g_Ret;
}
