Esempio n. 1
0
static int
TesteventloopCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    static int *framePtr = NULL;/* Pointer to integer on stack frame of
				 * innermost invocation of the "wait"
				 * subcommand. */

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" option ... \"", NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "done") == 0) {
	*framePtr = 1;
    } else if (strcmp(argv[1], "wait") == 0) {
	int *oldFramePtr, done;
	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);

	/*
	 * Save the old stack frame pointer and set up the current frame.
	 */

	oldFramePtr = framePtr;
	framePtr = &done;

	/*
	 * Enter a standard Windows event loop until the flag changes. Note
	 * that we do not explicitly call Tcl_ServiceEvent().
	 */

	done = 0;
	while (!done) {
	    MSG msg;

	    if (!GetMessage(&msg, NULL, 0, 0)) {
		/*
		 * The application is exiting, so repost the quit message and
		 * start unwinding.
		 */

		PostQuitMessage((int) msg.wParam);
		break;
	    }
	    TranslateMessage(&msg);
	    DispatchMessage(&msg);
	}
	(void) Tcl_SetServiceMode(oldMode);
	framePtr = oldFramePtr;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be done or wait", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}
Esempio n. 2
0
static int
TesteventloopCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    const char **argv)		/* Argument strings. */
{
    static int *framePtr = NULL;/* Pointer to integer on stack frame of
				 * innermost invocation of the "wait"
				 * subcommand. */

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" option ... \"", NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "done") == 0) {
	*framePtr = 1;
    } else if (strcmp(argv[1], "wait") == 0) {
	int *oldFramePtr;
	int done;
	int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);

	/*
	 * Save the old stack frame pointer and set up the current frame.
	 */

	oldFramePtr = framePtr;
	framePtr = &done;

	/*
	 * Enter an Xt event loop until the flag changes. Note that we do not
	 * explicitly call Tcl_ServiceEvent().
	 */

	done = 0;
	while (!done) {
	    XtAppProcessEvent(TclSetAppContext(NULL), XtIMAll);
	}
	(void) Tcl_SetServiceMode(oldMode);
	framePtr = oldFramePtr;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be done or wait", NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}
Esempio n. 3
0
//The main entry
int main( int argc, char ** argv )
{
#ifdef FIX__CTYPE_
    ctSetup();
#endif


    //init tcl
    Tcl_FindExecutable(argv[0]);
    Tcl_Interp * interp = Tcl_CreateInterp();
    Tcl_Init( interp );

    QTextCodec* codec = QTextCodec::codecForName("UTF-8");
    QTextCodec::setCodecForTr(codec);
    QTextCodec::setCodecForCStrings(codec);
    QTextCodec::setCodecForLocale(codec);

    //Qt application
    QApplication a( argc, argv );
    Tcl_SetServiceMode (TCL_SERVICE_ALL);
    Qtk_InitNotifier( &a );
    //Register the msgbox command
    commandsManager::getInstance(interp)->registerFunction("msgbox" , (commandsManager::commandType) CallQMessageBox, "Shows the Qt message box");
    //Create and show the main window
    QMainWindow mw;
    const QString str = "hello";

    mw.setWindowTitle("Memory compiler SOI018");
    mw.setMinimumSize(640, 480);
    //Instantiate and set the focus to the QtclConsole
/*    QtclConsole *console = QtclConsole::getInstance(&mw,
   	                                                     "Welcome to <b>Qt / Tcl console</b> !<br>"
   	                                                     "For any remarks, please mail me at: <font color=blue>[email protected]</font><br><br>");
*/


    // Run config reading




    memwindow window((QWidget*)&mw);
 //   window.show();
    //   mw.setFocusProxy((QWidget*)console);
  //  mw.setCentralWidget((QWidget*)console);
    mw.setCentralWidget(&window);
    mw.show();

    return a.exec();
}
Esempio n. 4
0
int
TkMacOSXProcessMenuEvent(TkMacOSXEvent *eventPtr, MacEventStatus * statusPtr)
{
    int		    menuContext;
    OSStatus	    status;

    switch (eventPtr->eKind) {
	case kEventMenuBeginTracking:
	case kEventMenuEndTracking:
	    break;
	default:
	    return 0;
	    break;
    }
    status = GetEventParameter(eventPtr->eventRef, 
	    kEventParamMenuContext,
	    typeUInt32, NULL, 
	    sizeof(menuContext), NULL,
	    &menuContext);
    if (status == noErr && (menuContext & kMenuContextMenuBar)) {
        static int oldMode = TCL_SERVICE_ALL;
        if (eventPtr->eKind == kEventMenuBeginTracking) {
            oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
            TkMacOSXClearMenubarActive();
        
            /*
             * Handle -postcommand
             */
        
            TkMacOSXPreprocessMenu();
        } else {
            Tcl_SetServiceMode(oldMode);   
        }
    }
    return 0;
}
Esempio n. 5
0
File: tcltk.c Progetto: kmillar/rho
SEXP RTcl_ServiceMode(SEXP args)
{
    int value;
    
    if (!isLogical(CADR(args)) || length(CADR(args)) > 1)
    	error(_("invalid argument"));
    
    if (length(CADR(args))) 
	value = Tcl_SetServiceMode(LOGICAL(CADR(args))[0] ? 
				   TCL_SERVICE_ALL : TCL_SERVICE_NONE);
    else
    	value = Tcl_GetServiceMode();
    
    return ScalarLogical(value == TCL_SERVICE_ALL);
}
Esempio n. 6
0
void tcl_glib_init ()
{
	Tcl_NotifierProcs notifier;

	memset(&notifier, 0, sizeof(notifier));

	notifier.createFileHandlerProc = tcl_create_file_handler;
	notifier.deleteFileHandlerProc = tcl_delete_file_handler;
	notifier.setTimerProc = tcl_set_timer;
	notifier.waitForEventProc = tcl_wait_for_event;

	Tcl_SetNotifier(&notifier);
	Tcl_SetServiceMode(TCL_SERVICE_ALL);

	tcl_timer_pending = FALSE;
	tcl_file_handlers = g_hash_table_new(g_direct_hash, g_direct_equal);
}
Esempio n. 7
0
static int
winprint_print_text_dialog (struct winprint_data *wd, Tcl_Interp *interp,
			    const struct print_text_options *pto,
			    PRINTDLG *pd, int *cancelled)
{
  int mode, ret;

  *cancelled = 0;

  memset (pd, 0, sizeof (PRINTDLG));
  pd->lStructSize = sizeof (PRINTDLG);

  if (! pto->dialog)
    pd->Flags = PD_RETURNDEFAULT | PD_RETURNDC;
  else
    {
      Tk_Window parent;

      if (pto->parent == NULL)
	parent = Tk_MainWindow (interp);
      else
	{
	  parent = Tk_NameToWindow (interp, pto->parent,
				    Tk_MainWindow (interp));
	  if (parent == NULL)
	    return TCL_ERROR;
	}
      if (Tk_WindowId (parent) == None)
	Tk_MakeWindowExist (parent);
      pd->hwndOwner = Tk_GetHWND (Tk_WindowId (parent));

      if (wd->page_setup != NULL)
	{
	  pd->hDevMode = wd->page_setup->hDevMode;
	  pd->hDevNames = wd->page_setup->hDevNames;
	}

      pd->Flags = PD_NOSELECTION | PD_RETURNDC | PD_USEDEVMODECOPIES;

      pd->nCopies = 1;
      pd->nFromPage = 1;
      pd->nToPage = 1;
      pd->nMinPage = 1;
      pd->nMaxPage = 0xffff;
    }

  mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);

  ret = PrintDlg (pd);

  (void) Tcl_SetServiceMode (mode);

  if (! ret)
    {
      DWORD code;

      code = CommDlgExtendedError ();

      /* For some errors, the print dialog will already have reported
         an error.  We treat those as though the user pressed cancel.
         Unfortunately, I do not know just which errors those are.  */

      if (code == 0 || code == PDERR_NODEFAULTPRN)
	{
	  *cancelled = 1;
	  return TCL_OK;
	}
      else
	{
	  char buf[20];

	  sprintf (buf, "0x%lx", (unsigned long) code);
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "Windows common dialog error ", buf,
				  (char *) NULL);
	  return TCL_ERROR;
	}
    }

  return TCL_OK;
}
Esempio n. 8
0
static int
winprint_page_setup_command (ClientData cd, Tcl_Interp *interp, int argc,
			     char **argv)
{
  struct winprint_data *wd = (struct winprint_data *) cd;
  Tk_Window parent;
  int i, mode, ret;
  PAGESETUPDLG psd;

  parent = Tk_MainWindow (interp);

  for (i = 2; i < argc; i += 2)
    {
      if (i + 1 >= argc)
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "value for \"", argv[i], "\" missing",
				  (char *) NULL);
	  return TCL_ERROR;
	}

      if (strcmp (argv[i], "-parent") == 0)
	{
	  parent = Tk_NameToWindow (interp, argv[i + 1],
				    Tk_MainWindow (interp));
	  if (parent == NULL)
	    return TCL_ERROR;
	}
      else
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "unknown option \"", argv[i], "\"",
				  (char *) NULL);
	  return TCL_ERROR;
	}
    }

  if (wd->page_setup != NULL)
    psd = *wd->page_setup;
  else
    {
      memset (&psd, 0, sizeof (PAGESETUPDLG));
      psd.lStructSize = sizeof (PAGESETUPDLG);
      psd.Flags = PSD_DEFAULTMINMARGINS;
    }

  if (Tk_WindowId (parent) == None)
    Tk_MakeWindowExist (parent);
  psd.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));

  mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);

  ret = PageSetupDlg (&psd);

  (void) Tcl_SetServiceMode (mode);

  if (! ret)
    {
      DWORD code;

      code = CommDlgExtendedError ();
      if (code == 0)
	{
	  /* The user pressed cancel.  */
	  return TCL_OK;
	}
      else
	{
	  char buf[20];

	  sprintf (buf, "0x%lx", (unsigned long) code);
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "Windows common dialog error ", buf,
				  (char *) NULL);
	  return TCL_ERROR;
	}
    }

  if (wd->page_setup == NULL)
    wd->page_setup = (PAGESETUPDLG *) ckalloc (sizeof (PAGESETUPDLG));

  *wd->page_setup = psd;

  return TCL_OK;
}
Esempio n. 9
0
File: tcltk.c Progetto: kmillar/rho
void tcltk_init(int *TkUp)
{
    int code;

    *TkUp = 0;

    /* Absence of the following line is said to be an error with
     * tcl >= 8.4 on all platforms, and is known to cause crashes under
     * Windows */

    Tcl_FindExecutable(NULL);

    RTcl_interp = Tcl_CreateInterp();
    code = Tcl_Init(RTcl_interp);
    if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));

/* HAVE_AQUA is not really right here.
   On Mac OS X we might be using Aqua Tcl/Tk or X11 Tcl/Tk, and that
   is in principle independent of whether we want quartz() built.
*/
#if !defined(Win32) && !defined(HAVE_AQUA)
    char *p= getenv("DISPLAY");
    if(p && p[0])  /* exclude DISPLAY = "" */
#endif
    {
	code = Tk_Init(RTcl_interp);  /* Load Tk into interpreter */
	if (code != TCL_OK) {
	    warning(Tcl_GetStringResult(RTcl_interp));
	} else {
	    Tcl_StaticPackage(RTcl_interp, "Tk", Tk_Init, Tk_SafeInit);

	    code = Tcl_Eval(RTcl_interp, "wm withdraw .");  /* Hide window */
	    if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));
	    *TkUp = 1;
	}
    }
#if !defined(Win32) && !defined(HAVE_AQUA)
    else
	warningcall(R_NilValue, _("no DISPLAY variable so Tk is not available"));
#endif

    Tcl_CreateCommand(RTcl_interp,
		      "R_eval",
		      R_eval,
		      (ClientData) NULL,
		      (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateCommand(RTcl_interp,
		      "R_call",
		      R_call,
		      (ClientData) NULL,
		      (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateCommand(RTcl_interp,
		      "R_call_lang",
		      R_call_lang,
		      (ClientData) NULL,
		      (Tcl_CmdDeleteProc *) NULL);

#ifndef Win32
    Tcl_unix_setup();
#endif
    Tcl_SetServiceMode(TCL_SERVICE_ALL);

/*** We may want to revive this at some point ***/

#if 0
  code = Tcl_EvalFile(RTcl_interp, "init.tcl");
  if (code != TCL_OK)
    error("%s\n", Tcl_GetStringResult(RTcl_interp));
#endif

}
Esempio n. 10
0
static int
win_choose_font (ClientData cd, Tcl_Interp *interp, int argc, char **argv)
{
  char *deffont;
  Tk_Window parent;
  int i, oldMode;
  CHOOSEFONT cf;
  LOGFONT lf;
  HDC hdc;
  HFONT hfont;
  char facebuf[LF_FACESIZE];
  TEXTMETRIC tm;
  int pointsize;
  char *s;
  Tcl_DString resultStr;             /* used to translate result in UTF8 in Tcl/Tk8.1 */
  deffont = NULL;
  parent = Tk_MainWindow (interp);

  for (i = 1; i < argc; i += 2)
    {
      if (i + 1 >= argc)
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "value for \"", argv[i], "\" missing",
				  (char *) NULL);
	  return TCL_ERROR;
	}

      if (strcmp (argv[i], "-default") == 0)
	deffont = argv[i + 1];
      else if (strcmp (argv[i], "-parent") == 0)
	{
	  parent = Tk_NameToWindow (interp, argv[i + 1],
				    Tk_MainWindow (interp));
	  if (parent == NULL)
	    return TCL_ERROR;
	}
      else
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "unknown option \"", argv[i], "\"",
				  (char *) NULL);
	  return TCL_ERROR;
	}
    }

  memset (&cf, 0, sizeof (CHOOSEFONT));
  cf.lStructSize = sizeof (CHOOSEFONT);

  if (Tk_WindowId (parent) == None)
    Tk_MakeWindowExist (parent);
  cf.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));

  cf.lpLogFont = &lf;
  cf.Flags = CF_SCREENFONTS | CF_FORCEFONTEXIST;

  memset (&lf, 0, sizeof (LOGFONT));

  if (deffont != NULL)
    {
      Tk_Font tkfont;
      const TkFontAttributes *fa;

      tkfont = Tk_GetFont (interp, parent, deffont);
      if (tkfont == NULL)
	return TCL_ERROR;

      cf.Flags |= CF_INITTOLOGFONTSTRUCT;

      /* In order to initialize LOGFONT, we need to extract the real
	 font attributes from the Tk internal font information.  */
      fa = &((TkFont *) tkfont)->fa;

      /* This code is taken from TkpGetFontFromAttributes.  It
         converts a TkFontAttributes structure into a LOGFONT
         structure.  */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
      lf.lfHeight = - fa->size;
#else
      lf.lfHeight = - fa->pointsize;
#endif
      if (lf.lfHeight < 0)
	lf.lfHeight = MulDiv (lf.lfHeight,
			      254 * WidthOfScreen (Tk_Screen (parent)),
			      720 * WidthMMOfScreen (Tk_Screen (parent)));
      lf.lfWeight = fa->weight == TK_FW_NORMAL ? FW_NORMAL : FW_BOLD;
      lf.lfItalic = fa->slant;
      lf.lfUnderline = fa->underline;
      lf.lfStrikeOut = fa->overstrike;
      lf.lfCharSet = DEFAULT_CHARSET;
      lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
      lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
      lf.lfQuality = DEFAULT_QUALITY;
      lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
      if (fa->family == NULL)
	lf.lfFaceName[0] = '\0';
      else
	strncpy (lf.lfFaceName, fa->family, sizeof (lf.lfFaceName));

      Tk_FreeFont (tkfont);
    }

  oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
  if (! ChooseFont (&cf))
    {
      DWORD code;

      code = CommDlgExtendedError ();
      if (code == 0)
	{
	  /* The user pressed cancel.  */
	  Tcl_ResetResult (interp);
	  return TCL_OK;
	}
      else
	{
	  char buf[200];

	  sprintf (buf, "Windows common dialog error 0x%lx", (unsigned long) code);
	  Tcl_ResetResult (interp);
          #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
            Tcl_ExternalToUtfDString(NULL, buf, -1, &resultStr);
          #else
            Tcl_InitDString(&resultStr);
            Tcl_DStingAppend(&resultStr, buf, -1);
          #endif
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  Tcl_DStringValue(&resultStr),
				  (char *) NULL);
          Tcl_DStringFree(&resultStr);
	  return TCL_ERROR;
	}
    }
  Tcl_SetServiceMode(oldMode);
  /* We now have a LOGFONT structure.  We store it into a device
     context, and then extract enough information to build a Tk font
     specification.  With luck, when Tk interprets the font
     specification it will wind up with the font that the user expects
     to see.  Some of this code is taken from AllocFont.  */

  hfont = CreateFontIndirect (&lf);
  if (hfont == NULL)
    {
      /* This should be impossible.  */
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "CreateFontIndirect failed on chosen font", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr, "CreateFontIndirect failed on chosen font", -1);
      #endif
      Tcl_SetResult (interp, Tcl_DStringValue(&resultStr), TCL_STATIC);
      Tcl_DStringFree(&resultStr);
      return TCL_ERROR;
    }

  hdc = GetDC (cf.hwndOwner);
  hfont = SelectObject (hdc, hfont);
  GetTextFace (hdc, sizeof (facebuf), facebuf);
  GetTextMetrics (hdc, &tm);

  Tcl_ResetResult (interp);

#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, facebuf, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr,facebuf,-1);
#endif

  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }

  Tcl_DStringFree(&resultStr);

  pointsize = MulDiv (tm.tmHeight - tm.tmInternalLeading,
		      720 * WidthMMOfScreen (Tk_Screen (parent)),
		      254 * WidthOfScreen (Tk_Screen (parent)));

  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewIntObj (pointsize)) != TCL_OK) {
     return TCL_ERROR;
  }

   if (tm.tmWeight > FW_MEDIUM)
    s = "bold";
  else
    s = "normal";

#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr, s, -1);
#endif

  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }

  Tcl_DStringFree(&resultStr);

  if (tm.tmItalic)
    s = "italic";
  else
    s = "roman";

#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr, s, -1);
#endif

  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }
  Tcl_DStringFree(&resultStr);

  if (tm.tmUnderlined)
    {
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "underline", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr,"underline",-1);
      #endif
      if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				    Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
	  != TCL_OK) {
        Tcl_DStringFree(&resultStr);
	return TCL_ERROR;
      }
      Tcl_DStringFree(&resultStr);
    }

  if (tm.tmStruckOut)
    {
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "overstrike", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr, "overstrike", -1);
      #endif
      if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				    Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
	  != TCL_OK) {
        Tcl_DStringFree(&resultStr);
	return TCL_ERROR;
      }
      Tcl_DStringFree(&resultStr);
    }

  hfont = SelectObject (hdc, hfont);
  ReleaseDC (cf.hwndOwner, hdc);
  DeleteObject (hfont);

  return TCL_OK;
}
Esempio n. 11
0
/* Implement the Windows version of the ide_get_directory command.  */
static int
get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
		       char **argv)
{
  BROWSEINFO bi;
  char buf[MAX_PATH + 1];
  Tk_Window parent;
  int i, oldMode;
  LPITEMIDLIST idlist;
  char *p;
  int atts;
  Tcl_DString tempBuffPtr;
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_DString titleDString;
  Tcl_DString initialDirDString;
  Tcl_DString resultDString;

  Tcl_DStringInit(&titleDString);
  Tcl_DStringInit(&initialDirDString);
#endif

  Tcl_DStringInit(&tempBuffPtr);

  bi.hwndOwner = NULL;
  bi.pidlRoot = NULL;
  bi.pszDisplayName = buf;
  bi.lpszTitle = NULL;
  bi.ulFlags = 0;
  bi.lpfn = NULL;
  bi.lParam = 0;
  bi.iImage = 0;

  parent = Tk_MainWindow (interp);

  for (i = 1; i < argc; i += 2)
    {
      int v;
      int len;

      v = i + 1;
      len = strlen (argv[i]);

      if (strncmp (argv[i], "-parent", len) == 0)
	{
	  if (v == argc)
	    goto arg_missing;

	  parent = Tk_NameToWindow (interp, argv[v],
				    Tk_MainWindow (interp));
	  if (parent == NULL)
	    return TCL_ERROR;
	}
      else if (strncmp (argv[i], "-title", len) == 0)
	{

	  if (v == argc)
	    goto arg_missing;

#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
	  Tcl_UtfToExternalDString(NULL, argv[v], -1, &titleDString);
	  bi.lpszTitle = Tcl_DStringValue(&titleDString);
#else
	  bi.lpszTitle = argv[v];
#endif
	}
      else if (strncmp (argv[i], "-initialdir", len) == 0)
	{
	  if (v == argc)
	    goto arg_missing;

	  /* bi.lParam will be passed to the callback function.(save the need for globals)*/
	  bi.lParam = (LPARAM) Tcl_TranslateFileName(interp, argv[v], &tempBuffPtr);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
	  Tcl_UtfToExternalDString(NULL, (char *) bi.lParam, -1, &initialDirDString);
	  bi.lParam = (LPARAM) Tcl_DStringValue(&initialDirDString);
#endif
	  bi.lpfn   = MyBrowseCallbackProc;
	}
      else
	{
	  Tcl_AppendResult (interp, "unknown option \"", argv[i],
			    "\", must be -parent or -title", (char *) NULL);
	  return TCL_ERROR;
	}
    }

  if (Tk_WindowId (parent) == None)
    Tk_MakeWindowExist (parent);

  bi.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));

  oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
  idlist = SHBrowseForFolder (&bi);
  Tcl_SetServiceMode(oldMode);

  if (idlist == NULL)
    {
      /* User pressed the cancel button.  */
      return TCL_OK;
    }

  if (! SHGetPathFromIDList (idlist, buf))
    {
      Tcl_SetResult (interp, "could not get path for directory", TCL_STATIC);
      return TCL_ERROR;
    }

  /* Ensure the directory exists.  */
  atts = GetFileAttributesA (buf);
  if (atts == -1 || ! (atts & FILE_ATTRIBUTE_DIRECTORY))
    {
      Tcl_AppendResult (interp, "path \"", buf, "\" is not a directory",
			(char *) NULL);
      /* FIXME: free IDLIST.  */
      return TCL_ERROR;
    }

  /* FIXME: We are supposed to free IDLIST using the shell task
     allocator, but cygwin32 doesn't define the required interfaces
     yet.  */



  /* Normalize the path for Tcl.  */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, buf, -1, &resultDString);
  p = Tcl_DStringValue(&resultDString);
#else
  p = buf;
#endif
  for (; *p != '\0'; ++p)
    if (*p == '\\')
      *p = '/';

  Tcl_ResetResult(interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_SetResult(interp, Tcl_DStringValue(&resultDString), TCL_VOLATILE);
  Tcl_DStringFree(&resultDString);
  Tcl_DStringFree(&titleDString);
  Tcl_DStringFree(&initialDirDString);
#else
  Tcl_SetResult(interp, buf, TCL_VOLATILE);
#endif
  Tcl_DStringFree(&tempBuffPtr);

  return TCL_OK;

 arg_missing:
  Tcl_AppendResult(interp, "value for \"", argv[argc - 1], "\" missing",
		   NULL);
  return TCL_ERROR;
}