Пример #1
0
/****
 * 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;
}
Пример #2
0
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;
};
Пример #3
0
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;
}
Пример #4
0
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;
}
Пример #5
0
/*
    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;
}
Пример #6
0
/* 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 );

}
Пример #7
0
int
Itcl_SafeInit (
    Tcl_Interp *interp)
{
    if (Initialize(interp) != TCL_OK) {
        return TCL_ERROR;
    }
    return Tcl_EvalEx(interp, safeInitScript, -1, 0);
}
Пример #8
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
}
Пример #9
0
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);
}
Пример #10
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;
}
Пример #11
0
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;
}
Пример #12
0
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);
    }
}
Пример #13
0
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);
	}
    }
}
Пример #14
0
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;
}
Пример #15
0
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;

}
Пример #16
0
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);
}
Пример #17
0
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
}
Пример #18
0
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;
}
Пример #19
0
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);
}
Пример #20
0
/****
 * 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;
}
Пример #21
0
/*
 * 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
}
Пример #22
0
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;
}
Пример #23
0
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;
}
Пример #24
0
__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;
}
Пример #25
0
/*
 * ------------------------------------------------------------------------
 *  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;
}
Пример #26
0
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;
}
Пример #27
0
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;
}
Пример #28
0
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);
}
Пример #29
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;
}
Пример #30
0
	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;
	}