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;
}
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;
}
//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();
}
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;
}
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);
}
void tcl_glib_init ()
{
Tcl_NotifierProcs notifier;
memset(¬ifier, 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(¬ifier);
Tcl_SetServiceMode(TCL_SERVICE_ALL);
tcl_timer_pending = FALSE;
tcl_file_handlers = g_hash_table_new(g_direct_hash, g_direct_equal);
}
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;
}
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;
}
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
}
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;
}
/* 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;
}
