+++ /dev/null
-/*
- * tkWinDialog.c --
- *
- * Contains the Windows implementation of the common dialog boxes.
- *
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tkWinInt.h"
-#include "tkFileFilter.h"
-#include "tkFont.h"
-
-#include <commdlg.h> /* includes common dialog functionality */
-#include <dlgs.h> /* includes common dialog template defines */
-#include <cderr.h> /* includes the common dialog error codes */
-
-#include <shlobj.h> /* includes SHBrowseForFolder */
-#include <shobjidl.h>
-
-#ifdef _MSC_VER
-# pragma comment (lib, "shell32.lib")
-# pragma comment (lib, "comdlg32.lib")
-# pragma comment (lib, "uuid.lib")
-#endif
-
-/* These needed for compilation with VC++ 5.2 */
-/* XXX - remove these since need at least VC 6 */
-#ifndef BIF_EDITBOX
-#define BIF_EDITBOX 0x10
-#endif
-
-#ifndef BIF_VALIDATE
-#define BIF_VALIDATE 0x0020
-#endif
-
-/* This "new" dialog style is now actually the "old" dialog style post-Vista */
-#ifndef BIF_NEWDIALOGSTYLE
-#define BIF_NEWDIALOGSTYLE 0x0040
-#endif
-
-#ifndef BFFM_VALIDATEFAILED
-#ifdef UNICODE
-#define BFFM_VALIDATEFAILED 4
-#else
-#define BFFM_VALIDATEFAILED 3
-#endif
-#endif /* BFFM_VALIDATEFAILED */
-
-typedef struct ThreadSpecificData {
- int debugFlag; /* Flags whether we should output debugging
- * information while displaying a builtin
- * dialog. */
- Tcl_Interp *debugInterp; /* Interpreter to used for debugging. */
- UINT WM_LBSELCHANGED; /* Holds a registered windows event used for
- * communicating between the Directory Chooser
- * dialog and its hook proc. */
- HHOOK hMsgBoxHook; /* Hook proc for tk_messageBox and the */
- HICON hSmallIcon; /* icons used by a parent to be used in */
- HICON hBigIcon; /* the message box */
- int newFileDialogsState;
-#define FDLG_STATE_INIT 0 /* Uninitialized */
-#define FDLG_STATE_USE_NEW 1 /* Use the new dialogs */
-#define FDLG_STATE_USE_OLD 2 /* Use the old dialogs */
-} ThreadSpecificData;
-static Tcl_ThreadDataKey dataKey;
-
-/*
- * The following structures are used by Tk_MessageBoxCmd() to parse arguments
- * and return results.
- */
-
-static const TkStateMap iconMap[] = {
- {MB_ICONERROR, "error"},
- {MB_ICONINFORMATION, "info"},
- {MB_ICONQUESTION, "question"},
- {MB_ICONWARNING, "warning"},
- {-1, NULL}
-};
-
-static const TkStateMap typeMap[] = {
- {MB_ABORTRETRYIGNORE, "abortretryignore"},
- {MB_OK, "ok"},
- {MB_OKCANCEL, "okcancel"},
- {MB_RETRYCANCEL, "retrycancel"},
- {MB_YESNO, "yesno"},
- {MB_YESNOCANCEL, "yesnocancel"},
- {-1, NULL}
-};
-
-static const TkStateMap buttonMap[] = {
- {IDABORT, "abort"},
- {IDRETRY, "retry"},
- {IDIGNORE, "ignore"},
- {IDOK, "ok"},
- {IDCANCEL, "cancel"},
- {IDNO, "no"},
- {IDYES, "yes"},
- {-1, NULL}
-};
-
-static const int buttonFlagMap[] = {
- MB_DEFBUTTON1, MB_DEFBUTTON2, MB_DEFBUTTON3, MB_DEFBUTTON4
-};
-
-static const struct {int type; int btnIds[3];} allowedTypes[] = {
- {MB_ABORTRETRYIGNORE, {IDABORT, IDRETRY, IDIGNORE}},
- {MB_OK, {IDOK, -1, -1 }},
- {MB_OKCANCEL, {IDOK, IDCANCEL, -1 }},
- {MB_RETRYCANCEL, {IDRETRY, IDCANCEL, -1 }},
- {MB_YESNO, {IDYES, IDNO, -1 }},
- {MB_YESNOCANCEL, {IDYES, IDNO, IDCANCEL}}
-};
-
-#define NUM_TYPES (sizeof(allowedTypes) / sizeof(allowedTypes[0]))
-
-/*
- * Abstract trivial differences between Win32 and Win64.
- */
-
-#define TkWinGetHInstance(from) \
- ((HINSTANCE) GetWindowLongPtr((from), GWLP_HINSTANCE))
-#define TkWinGetUserData(from) \
- GetWindowLongPtr((from), GWLP_USERDATA)
-#define TkWinSetUserData(to,what) \
- SetWindowLongPtr((to), GWLP_USERDATA, (LPARAM)(what))
-
-/*
- * The value of TK_MULTI_MAX_PATH dictates how many files can be retrieved
- * with tk_get*File -multiple 1. It must be allocated on the stack, so make it
- * large enough but not too large. - hobbs
- *
- * The data is stored as <dir>\0<file1>\0<file2>\0...<fileN>\0\0. Since
- * MAX_PATH == 260 on Win2K/NT, *40 is ~10Kbytes.
- */
-
-#define TK_MULTI_MAX_PATH (MAX_PATH*40)
-
-/*
- * The following structure is used to pass information between the directory
- * chooser function, Tk_ChooseDirectoryObjCmd(), and its dialog hook proc.
- */
-
-typedef struct {
- TCHAR initDir[MAX_PATH]; /* Initial folder to use */
- TCHAR retDir[MAX_PATH]; /* Returned folder to use */
- Tcl_Interp *interp;
- int mustExist; /* True if file must exist to return from
- * callback */
-} ChooseDir;
-
-/*
- * The following structure is used to pass information between GetFileName
- * function and OFN dialog hook procedures. [Bug 2896501, Patch 2898255]
- */
-
-typedef struct OFNData {
- Tcl_Interp *interp; /* Interp, used only if debug is turned on,
- * for setting the "tk_dialog" variable. */
- int dynFileBufferSize; /* Dynamic filename buffer size, stored to
- * avoid shrinking and expanding the buffer
- * when selection changes */
- TCHAR *dynFileBuffer; /* Dynamic filename buffer */
-} OFNData;
-
-/*
- * The following structure is used to gather options used by various
- * file dialogs
- */
-typedef struct OFNOpts {
- Tk_Window tkwin; /* Owner window for dialog */
- Tcl_Obj *extObj; /* Default extension */
- Tcl_Obj *titleObj; /* Title for dialog */
- Tcl_Obj *filterObj; /* File type filter list */
- Tcl_Obj *typeVariableObj; /* Variable in which to store type selected */
- Tcl_Obj *initialTypeObj; /* Initial value of above, or NULL */
- Tcl_DString utfDirString; /* Initial dir */
- int multi; /* Multiple selection enabled */
- int confirmOverwrite; /* Confirm before overwriting */
- int mustExist; /* Used only for */
- int forceXPStyle; /* XXX - Force XP style even on newer systems */
- TCHAR file[TK_MULTI_MAX_PATH]; /* File name
- XXX - fixed size because it was so
- historically. Why not malloc'ed ?
- XXX - also, TCHAR should really be WCHAR
- because TkWinGetUnicodeEncoding is always
- UCS2.
- */
-} OFNOpts;
-
-/* Define the operation for which option parsing is to be done. */
-enum OFNOper {
- OFN_FILE_SAVE, /* tk_getOpenFile */
- OFN_FILE_OPEN, /* tk_getSaveFile */
- OFN_DIR_CHOOSE /* tk_chooseDirectory */
-};
-
-
-/*
- * The following definitions are required when using older versions of
- * Visual C++ (like 6.0) and possibly MingW. Those headers do not contain
- * required definitions for interfaces new to Vista that we need for
- * the new file dialogs. Duplicating definitions is OK because they
- * should forever remain unchanged.
- *
- * XXX - is there a better/easier way to use new data definitions with
- * older compilers? Should we prefix definitions with Tcl_ instead
- * of using the same names as in the SDK?
- */
-#ifndef __IShellItem_INTERFACE_DEFINED__
-# define __IShellItem_INTERFACE_DEFINED__
-#ifdef __MSVCRT__
-typedef struct IShellItem IShellItem;
-
-typedef enum __MIDL_IShellItem_0001 {
- SIGDN_NORMALDISPLAY = 0,SIGDN_PARENTRELATIVEPARSING = 0x80018001,SIGDN_PARENTRELATIVEFORADDRESSBAR = 0x8001c001,
- SIGDN_DESKTOPABSOLUTEPARSING = 0x80028000,SIGDN_PARENTRELATIVEEDITING = 0x80031001,SIGDN_DESKTOPABSOLUTEEDITING = 0x8004c000,
- SIGDN_FILESYSPATH = 0x80058000,SIGDN_URL = 0x80068000
-} SIGDN;
-
-typedef DWORD SICHINTF;
-
-typedef struct IShellItemVtbl
-{
- BEGIN_INTERFACE
-
- HRESULT (STDMETHODCALLTYPE *QueryInterface)(IShellItem *, REFIID, void **);
- ULONG (STDMETHODCALLTYPE *AddRef)(IShellItem *);
- ULONG (STDMETHODCALLTYPE *Release)(IShellItem *);
- HRESULT (STDMETHODCALLTYPE *BindToHandler)(IShellItem *, IBindCtx *, REFGUID, REFIID, void **);
- HRESULT (STDMETHODCALLTYPE *GetParent)(IShellItem *, IShellItem **);
- HRESULT (STDMETHODCALLTYPE *GetDisplayName)(IShellItem *, SIGDN, LPOLESTR *);
- HRESULT (STDMETHODCALLTYPE *GetAttributes)(IShellItem *, SFGAOF, SFGAOF *);
- HRESULT (STDMETHODCALLTYPE *Compare)(IShellItem *, IShellItem *, SICHINTF, int *);
-
- END_INTERFACE
-} IShellItemVtbl;
-struct IShellItem {
- CONST_VTBL struct IShellItemVtbl *lpVtbl;
-};
-#endif
-#endif
-
-#ifndef __IShellItemArray_INTERFACE_DEFINED__
-#define __IShellItemArray_INTERFACE_DEFINED__
-
-typedef enum SIATTRIBFLAGS {
- SIATTRIBFLAGS_AND = 0x1,
- SIATTRIBFLAGS_OR = 0x2,
- SIATTRIBFLAGS_APPCOMPAT = 0x3,
- SIATTRIBFLAGS_MASK = 0x3,
- SIATTRIBFLAGS_ALLITEMS = 0x4000
-} SIATTRIBFLAGS;
-#ifdef __MSVCRT__
-typedef ULONG SFGAOF;
-#endif /* __MSVCRT__ */
-typedef struct IShellItemArray IShellItemArray;
-typedef struct IShellItemArrayVtbl
-{
- BEGIN_INTERFACE
-
- HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
- IShellItemArray *, REFIID riid,void **ppvObject);
- ULONG ( STDMETHODCALLTYPE *AddRef )(IShellItemArray *);
- ULONG ( STDMETHODCALLTYPE *Release )(IShellItemArray *);
- HRESULT ( STDMETHODCALLTYPE *BindToHandler )(IShellItemArray *,
- IBindCtx *, REFGUID, REFIID, void **);
- /* flags is actually is enum GETPROPERTYSTOREFLAGS */
- HRESULT ( STDMETHODCALLTYPE *GetPropertyStore )(
- IShellItemArray *, int, REFIID, void **);
- /* keyType actually REFPROPERTYKEY */
- HRESULT ( STDMETHODCALLTYPE *GetPropertyDescriptionList )(
- IShellItemArray *, void *, REFIID, void **);
- HRESULT ( STDMETHODCALLTYPE *GetAttributes )(IShellItemArray *,
- SIATTRIBFLAGS, SFGAOF, SFGAOF *);
- HRESULT ( STDMETHODCALLTYPE *GetCount )(
- IShellItemArray *, DWORD *);
- HRESULT ( STDMETHODCALLTYPE *GetItemAt )(
- IShellItemArray *, DWORD, IShellItem **);
- /* ppenumShellItems actually (IEnumShellItems **) */
- HRESULT ( STDMETHODCALLTYPE *EnumItems )(
- IShellItemArray *, void **);
-
- END_INTERFACE
-} IShellItemArrayVtbl;
-
-struct IShellItemArray {
- CONST_VTBL struct IShellItemArrayVtbl *lpVtbl;
-};
-
-#endif /* __IShellItemArray_INTERFACE_DEFINED__ */
-
-/*
- * Older compilers do not define these CLSIDs so we do so here under
- * a slightly different name so as to not clash with the definitions
- * in new compilers
- */
-static const CLSID ClsidFileOpenDialog = {
- 0xDC1C5A9C, 0xE88A, 0X4DDE, {0xA5, 0xA1, 0x60, 0xF8, 0x2A, 0x20, 0xAE, 0xF7}
-};
-static const CLSID ClsidFileSaveDialog = {
- 0xC0B4E2F3, 0xBA21, 0x4773, {0x8D, 0xBA, 0x33, 0x5E, 0xC9, 0x46, 0xEB, 0x8B}
-};
-static const IID IIDIFileOpenDialog = {
- 0xD57C7288, 0xD4AD, 0x4768, {0xBE, 0x02, 0x9D, 0x96, 0x95, 0x32, 0xD9, 0x60}
-};
-static const IID IIDIFileSaveDialog = {
- 0x84BCCD23, 0x5FDE, 0x4CDB, {0xAE, 0xA4, 0xAF, 0x64, 0xB8, 0x3D, 0x78, 0xAB}
-};
-static const IID IIDIShellItem = {
- 0x43826D1E, 0xE718, 0x42EE, {0xBC, 0x55, 0xA1, 0xE2, 0x61, 0xC3, 0x7B, 0xFE}
-};
-
-#ifdef __IFileDialog_INTERFACE_DEFINED__
-# define TCLCOMDLG_FILTERSPEC COMDLG_FILTERSPEC
-#else
-
-/* Forward declarations for structs that are referenced but not used */
-typedef struct IPropertyStore IPropertyStore;
-typedef struct IPropertyDescriptionList IPropertyDescriptionList;
-typedef struct IFileOperationProgressSink IFileOperationProgressSink;
-typedef enum FDAP {
- FDAP_BOTTOM = 0,
- FDAP_TOP = 1
-} FDAP;
-
-typedef struct {
- LPCWSTR pszName;
- LPCWSTR pszSpec;
-} TCLCOMDLG_FILTERSPEC;
-
-enum _FILEOPENDIALOGOPTIONS {
- FOS_OVERWRITEPROMPT = 0x2,
- FOS_STRICTFILETYPES = 0x4,
- FOS_NOCHANGEDIR = 0x8,
- FOS_PICKFOLDERS = 0x20,
- FOS_FORCEFILESYSTEM = 0x40,
- FOS_ALLNONSTORAGEITEMS = 0x80,
- FOS_NOVALIDATE = 0x100,
- FOS_ALLOWMULTISELECT = 0x200,
- FOS_PATHMUSTEXIST = 0x800,
- FOS_FILEMUSTEXIST = 0x1000,
- FOS_CREATEPROMPT = 0x2000,
- FOS_SHAREAWARE = 0x4000,
- FOS_NOREADONLYRETURN = 0x8000,
- FOS_NOTESTFILECREATE = 0x10000,
- FOS_HIDEMRUPLACES = 0x20000,
- FOS_HIDEPINNEDPLACES = 0x40000,
- FOS_NODEREFERENCELINKS = 0x100000,
- FOS_DONTADDTORECENT = 0x2000000,
- FOS_FORCESHOWHIDDEN = 0x10000000,
- FOS_DEFAULTNOMINIMODE = 0x20000000,
- FOS_FORCEPREVIEWPANEON = 0x40000000
-} ;
-typedef DWORD FILEOPENDIALOGOPTIONS;
-
-typedef struct IFileDialog IFileDialog;
-typedef struct IFileDialogVtbl
-{
- BEGIN_INTERFACE
-
- HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
- IFileDialog *, REFIID, void **);
- ULONG ( STDMETHODCALLTYPE *AddRef )( IFileDialog *);
- ULONG ( STDMETHODCALLTYPE *Release )( IFileDialog *);
- HRESULT ( STDMETHODCALLTYPE *Show )( IFileDialog *, HWND);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypes )( IFileDialog *,
- UINT, const TCLCOMDLG_FILTERSPEC *);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypeIndex )(IFileDialog *, UINT);
- HRESULT ( STDMETHODCALLTYPE *GetFileTypeIndex )(IFileDialog *, UINT *);
- /* XXX - Actually pfde is IFileDialogEvents* but we do not use
- this call and do not want to define IFileDialogEvents as that
- pulls in a whole bunch of other stuff. */
- HRESULT ( STDMETHODCALLTYPE *Advise )(
- IFileDialog *, void *, DWORD *);
- HRESULT ( STDMETHODCALLTYPE *Unadvise )(IFileDialog *, DWORD);
- HRESULT ( STDMETHODCALLTYPE *SetOptions )(
- IFileDialog *, FILEOPENDIALOGOPTIONS);
- HRESULT ( STDMETHODCALLTYPE *GetOptions )(
- IFileDialog *, FILEOPENDIALOGOPTIONS *);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultFolder )(
- IFileDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *SetFolder )(
- IFileDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *GetFolder )(
- IFileDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *GetCurrentSelection )(
- IFileDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *SetFileName )(
- IFileDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetFileName )(
- IFileDialog *, LPWSTR *);
- HRESULT ( STDMETHODCALLTYPE *SetTitle )(
- IFileDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetOkButtonLabel )(
- IFileDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetFileNameLabel )(
- IFileDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetResult )(
- IFileDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *AddPlace )(
- IFileDialog *, IShellItem *, FDAP);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultExtension )(
- IFileDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *Close )( IFileDialog *, HRESULT);
- HRESULT ( STDMETHODCALLTYPE *SetClientGuid )(
- IFileDialog *, REFGUID);
- HRESULT ( STDMETHODCALLTYPE *ClearClientData )( IFileDialog *);
- /* pFilter actually IShellItemFilter. But deprecated in Win7 AND we do
- not use it anyways. So define as void* */
- HRESULT ( STDMETHODCALLTYPE *SetFilter )(
- IFileDialog *, void *);
-
- END_INTERFACE
-} IFileDialogVtbl;
-
-struct IFileDialog {
- CONST_VTBL struct IFileDialogVtbl *lpVtbl;
-};
-
-
-typedef struct IFileSaveDialog IFileSaveDialog;
-typedef struct IFileSaveDialogVtbl {
- BEGIN_INTERFACE
-
- HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
- IFileSaveDialog *, REFIID, void **);
- ULONG ( STDMETHODCALLTYPE *AddRef )( IFileSaveDialog *);
- ULONG ( STDMETHODCALLTYPE *Release )( IFileSaveDialog *);
- HRESULT ( STDMETHODCALLTYPE *Show )(
- IFileSaveDialog *, HWND);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypes )( IFileSaveDialog * this,
- UINT, const TCLCOMDLG_FILTERSPEC *);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypeIndex )(
- IFileSaveDialog *, UINT);
- HRESULT ( STDMETHODCALLTYPE *GetFileTypeIndex )(
- IFileSaveDialog *, UINT *);
- /* Actually pfde is IFileSaveDialogEvents* */
- HRESULT ( STDMETHODCALLTYPE *Advise )(
- IFileSaveDialog *, void *, DWORD *);
- HRESULT ( STDMETHODCALLTYPE *Unadvise )( IFileSaveDialog *, DWORD);
- HRESULT ( STDMETHODCALLTYPE *SetOptions )(
- IFileSaveDialog *, FILEOPENDIALOGOPTIONS);
- HRESULT ( STDMETHODCALLTYPE *GetOptions )(
- IFileSaveDialog *, FILEOPENDIALOGOPTIONS *);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultFolder )(
- IFileSaveDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *SetFolder )(
- IFileSaveDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *GetFolder )(
- IFileSaveDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *GetCurrentSelection )(
- IFileSaveDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *SetFileName )(
- IFileSaveDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetFileName )(
- IFileSaveDialog *, LPWSTR *);
- HRESULT ( STDMETHODCALLTYPE *SetTitle )(
- IFileSaveDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetOkButtonLabel )(
- IFileSaveDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetFileNameLabel )(
- IFileSaveDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetResult )(
- IFileSaveDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *AddPlace )(
- IFileSaveDialog *, IShellItem *, FDAP);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultExtension )(
- IFileSaveDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *Close )( IFileSaveDialog *, HRESULT);
- HRESULT ( STDMETHODCALLTYPE *SetClientGuid )(
- IFileSaveDialog *, REFGUID);
- HRESULT ( STDMETHODCALLTYPE *ClearClientData )( IFileSaveDialog *);
- /* pFilter Actually IShellItemFilter* */
- HRESULT ( STDMETHODCALLTYPE *SetFilter )(
- IFileSaveDialog *, void *);
- HRESULT ( STDMETHODCALLTYPE *SetSaveAsItem )(
- IFileSaveDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *SetProperties )(
- IFileSaveDialog *, IPropertyStore *);
- HRESULT ( STDMETHODCALLTYPE *SetCollectedProperties )(
- IFileSaveDialog *, IPropertyDescriptionList *, BOOL);
- HRESULT ( STDMETHODCALLTYPE *GetProperties )(
- IFileSaveDialog *, IPropertyStore **);
- HRESULT ( STDMETHODCALLTYPE *ApplyProperties )(
- IFileSaveDialog *, IShellItem *, IPropertyStore *,
- HWND, IFileOperationProgressSink *);
-
- END_INTERFACE
-
-} IFileSaveDialogVtbl;
-
-struct IFileSaveDialog {
- CONST_VTBL struct IFileSaveDialogVtbl *lpVtbl;
-};
-
-typedef struct IFileOpenDialog IFileOpenDialog;
-typedef struct IFileOpenDialogVtbl {
- BEGIN_INTERFACE
-
- HRESULT ( STDMETHODCALLTYPE *QueryInterface )(
- IFileOpenDialog *, REFIID, void **);
- ULONG ( STDMETHODCALLTYPE *AddRef )( IFileOpenDialog *);
- ULONG ( STDMETHODCALLTYPE *Release )( IFileOpenDialog *);
- HRESULT ( STDMETHODCALLTYPE *Show )( IFileOpenDialog *, HWND);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypes )( IFileOpenDialog *,
- UINT, const TCLCOMDLG_FILTERSPEC *);
- HRESULT ( STDMETHODCALLTYPE *SetFileTypeIndex )(
- IFileOpenDialog *, UINT);
- HRESULT ( STDMETHODCALLTYPE *GetFileTypeIndex )(
- IFileOpenDialog *, UINT *);
- /* Actually pfde is IFileDialogEvents* */
- HRESULT ( STDMETHODCALLTYPE *Advise )(
- IFileOpenDialog *, void *, DWORD *);
- HRESULT ( STDMETHODCALLTYPE *Unadvise )( IFileOpenDialog *, DWORD);
- HRESULT ( STDMETHODCALLTYPE *SetOptions )(
- IFileOpenDialog *, FILEOPENDIALOGOPTIONS);
- HRESULT ( STDMETHODCALLTYPE *GetOptions )(
- IFileOpenDialog *, FILEOPENDIALOGOPTIONS *);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultFolder )(
- IFileOpenDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *SetFolder )(
- IFileOpenDialog *, IShellItem *);
- HRESULT ( STDMETHODCALLTYPE *GetFolder )(
- IFileOpenDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *GetCurrentSelection )(
- IFileOpenDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *SetFileName )(
- IFileOpenDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetFileName )(
- IFileOpenDialog *, LPWSTR *);
- HRESULT ( STDMETHODCALLTYPE *SetTitle )(
- IFileOpenDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetOkButtonLabel )(
- IFileOpenDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *SetFileNameLabel )(
- IFileOpenDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *GetResult )(
- IFileOpenDialog *, IShellItem **);
- HRESULT ( STDMETHODCALLTYPE *AddPlace )(
- IFileOpenDialog *, IShellItem *, FDAP);
- HRESULT ( STDMETHODCALLTYPE *SetDefaultExtension )(
- IFileOpenDialog *, LPCWSTR);
- HRESULT ( STDMETHODCALLTYPE *Close )( IFileOpenDialog *, HRESULT);
- HRESULT ( STDMETHODCALLTYPE *SetClientGuid )(
- IFileOpenDialog *, REFGUID);
- HRESULT ( STDMETHODCALLTYPE *ClearClientData )(
- IFileOpenDialog *);
- HRESULT ( STDMETHODCALLTYPE *SetFilter )(
- IFileOpenDialog *,
- /* pFilter is actually IShellItemFilter */
- void *);
- HRESULT ( STDMETHODCALLTYPE *GetResults )(
- IFileOpenDialog *, IShellItemArray **);
- HRESULT ( STDMETHODCALLTYPE *GetSelectedItems )(
- IFileOpenDialog *, IShellItemArray **);
-
- END_INTERFACE
-} IFileOpenDialogVtbl;
-
-struct IFileOpenDialog
-{
- CONST_VTBL struct IFileOpenDialogVtbl *lpVtbl;
-};
-
-#endif /* __IFileDialog_INTERFACE_DEFINED__ */
-
-/*
- * Definitions of functions used only in this file.
- */
-
-static UINT APIENTRY ChooseDirectoryValidateProc(HWND hdlg, UINT uMsg,
- LPARAM wParam, LPARAM lParam);
-static UINT CALLBACK ColorDlgHookProc(HWND hDlg, UINT uMsg, WPARAM wParam,
- LPARAM lParam);
-static void CleanupOFNOptions(OFNOpts *optsPtr);
-static int ParseOFNOptions(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[], enum OFNOper oper, OFNOpts *optsPtr);
-static int GetFileNameXP(Tcl_Interp *interp, OFNOpts *optsPtr,
- enum OFNOper oper);
-static int GetFileNameVista(Tcl_Interp *interp, OFNOpts *optsPtr,
- enum OFNOper oper);
-static int GetFileName(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[], enum OFNOper oper);
-static int MakeFilterVista(Tcl_Interp *interp, OFNOpts *optsPtr,
- DWORD *countPtr, TCLCOMDLG_FILTERSPEC **dlgFilterPtrPtr,
- DWORD *defaultFilterIndexPtr);
-static void FreeFilterVista(DWORD count, TCLCOMDLG_FILTERSPEC *dlgFilterPtr);
-static int MakeFilter(Tcl_Interp *interp, Tcl_Obj *valuePtr,
- Tcl_DString *dsPtr, Tcl_Obj *initialPtr,
- int *indexPtr);
-static UINT APIENTRY OFNHookProc(HWND hdlg, UINT uMsg, WPARAM wParam,
- LPARAM lParam);
-static LRESULT CALLBACK MsgBoxCBTProc(int nCode, WPARAM wParam, LPARAM lParam);
-static void SetTkDialog(ClientData clientData);
-static const char *ConvertExternalFilename(TCHAR *filename,
- Tcl_DString *dsPtr);
-static void LoadShellProcs(void);
-
-
-/* Definitions of dynamically loaded Win32 calls */
-typedef HRESULT (STDAPICALLTYPE SHCreateItemFromParsingNameProc)(
- PCWSTR pszPath, IBindCtx *pbc, REFIID riid, void **ppv);
-struct ShellProcPointers {
- SHCreateItemFromParsingNameProc *SHCreateItemFromParsingName;
-} ShellProcs;
-
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * LoadShellProcs --
- *
- * Some shell functions are not available on older versions of
- * Windows. This function dynamically loads them and stores pointers
- * to them in ShellProcs. Any function that is not available has
- * the corresponding pointer set to NULL.
- *
- * Note this call never fails. Unavailability of a function is not
- * a reason for failure. Caller should check whether a particular
- * function pointer is NULL or not. Once loaded a function stays
- * forever loaded.
- *
- * XXX - we load the function pointers into global memory. This implies
- * there is a potential (however small) for race conditions between
- * threads. However, Tk is in any case meant to be loaded in exactly
- * one thread so this should not be an issue and saves us from
- * unnecessary bookkeeping.
- *
- * Return value:
- * None.
- *
- * Side effects:
- * ShellProcs is populated.
- *-------------------------------------------------------------------------
- */
-static void LoadShellProcs()
-{
- static HMODULE shell32_handle = NULL;
-
- if (shell32_handle != NULL)
- return; /* We have already been through here. */
-
- /*
- * XXX - Note we never call FreeLibrary. There is no point because
- * shell32.dll is loaded at startup anyways and stays for the duration
- * of the process so why bother with keeping track of when to unload
- */
- shell32_handle = LoadLibrary(TEXT("shell32.dll"));
- if (shell32_handle == NULL) /* Should never happen but check anyways. */
- return;
-
- ShellProcs.SHCreateItemFromParsingName =
- (SHCreateItemFromParsingNameProc*) GetProcAddress(shell32_handle,
- "SHCreateItemFromParsingName");
-}
-
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * EatSpuriousMessageBugFix --
- *
- * In the file open/save dialog, double clicking on a list item causes
- * the dialog box to close, but an unwanted WM_LBUTTONUP message is sent
- * to the window underneath. If the window underneath happens to be a
- * windows control (eg a button) then it will be activated by accident.
- *
- * This problem does not occur in dialog boxes, because windows must do
- * some special processing to solve the problem. (separate message
- * processing functions are used to cope with keyboard navigation of
- * controls.)
- *
- * Here is one solution. After returning, we poll the message queue for
- * 1/4s looking for WM_LBUTTON up messages. If we see one it's consumed.
- * If we get a WM_LBUTTONDOWN message, then we exit early, since the user
- * must be doing something new. This fix only works for the current
- * application, so the problem will still occur if the open dialog
- * happens to be over another applications button. However this is a
- * fairly rare occurrance.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Consumes an unwanted BUTTON messages.
- *
- *-------------------------------------------------------------------------
- */
-
-static void
-EatSpuriousMessageBugFix(void)
-{
- MSG msg;
- DWORD nTime = GetTickCount() + 250;
-
- while (GetTickCount() < nTime) {
- if (PeekMessageA(&msg, 0, WM_LBUTTONDOWN, WM_LBUTTONDOWN, PM_NOREMOVE)){
- break;
- }
- PeekMessageA(&msg, 0, WM_LBUTTONUP, WM_LBUTTONUP, PM_REMOVE);
- }
-}
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * TkWinDialogDebug --
- *
- * Function to turn on/off debugging support for common dialogs under
- * windows. The variable "tk_debug" is set to the identifier of the
- * dialog window when the modal dialog window pops up and it is safe to
- * send messages to the dialog.
- *
- * Results:
- * None.
- *
- * Side effects:
- * This variable only makes sense if just one dialog is up at a time.
- *
- *-------------------------------------------------------------------------
- */
-
-void
-TkWinDialogDebug(
- int debug)
-{
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- tsdPtr->debugFlag = debug;
-}
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * Tk_ChooseColorObjCmd --
- *
- * This function implements the color dialog box for the Windows
- * platform. See the user documentation for details on what it does.
- *
- * Results:
- * See user documentation.
- *
- * Side effects:
- * A dialog window is created the first time this function is called.
- * This window is not destroyed and will be reused the next time the
- * application invokes the "tk_chooseColor" command.
- *
- *-------------------------------------------------------------------------
- */
-
-int
-Tk_ChooseColorObjCmd(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- Tk_Window tkwin = clientData, parent;
- HWND hWnd;
- int i, oldMode, winCode, result;
- CHOOSECOLOR chooseColor;
- static int inited = 0;
- static COLORREF dwCustColors[16];
- static long oldColor; /* the color selected last time */
- static const char *const optionStrings[] = {
- "-initialcolor", "-parent", "-title", NULL
- };
- enum options {
- COLOR_INITIAL, COLOR_PARENT, COLOR_TITLE
- };
-
- result = TCL_OK;
- if (inited == 0) {
- /*
- * dwCustColors stores the custom color which the user can modify. We
- * store these colors in a static array so that the next time the
- * color dialog pops up, the same set of custom colors remain in the
- * dialog.
- */
-
- for (i = 0; i < 16; i++) {
- dwCustColors[i] = RGB(255-i * 10, i, i * 10);
- }
- oldColor = RGB(0xa0, 0xa0, 0xa0);
- inited = 1;
- }
-
- parent = tkwin;
- chooseColor.lStructSize = sizeof(CHOOSECOLOR);
- chooseColor.hwndOwner = NULL;
- chooseColor.hInstance = NULL;
- chooseColor.rgbResult = oldColor;
- chooseColor.lpCustColors = dwCustColors;
- chooseColor.Flags = CC_RGBINIT | CC_FULLOPEN | CC_ENABLEHOOK;
- chooseColor.lCustData = (LPARAM) NULL;
- chooseColor.lpfnHook = (LPOFNHOOKPROC) ColorDlgHookProc;
- chooseColor.lpTemplateName = (LPTSTR) interp;
-
- for (i = 1; i < objc; i += 2) {
- int index;
- const char *string;
- Tcl_Obj *optionPtr, *valuePtr;
-
- optionPtr = objv[i];
- valuePtr = objv[i + 1];
-
- if (Tcl_GetIndexFromObjStruct(interp, optionPtr, optionStrings,
- sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if (i + 1 == objc) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "value for \"%s\" missing", Tcl_GetString(optionPtr)));
- Tcl_SetErrorCode(interp, "TK", "COLORDIALOG", "VALUE", NULL);
- return TCL_ERROR;
- }
-
- string = Tcl_GetString(valuePtr);
- switch ((enum options) index) {
- case COLOR_INITIAL: {
- XColor *colorPtr;
-
- colorPtr = Tk_GetColor(interp, tkwin, string);
- if (colorPtr == NULL) {
- return TCL_ERROR;
- }
- chooseColor.rgbResult = RGB(colorPtr->red / 0x100,
- colorPtr->green / 0x100, colorPtr->blue / 0x100);
- break;
- }
- case COLOR_PARENT:
- parent = Tk_NameToWindow(interp, string, tkwin);
- if (parent == NULL) {
- return TCL_ERROR;
- }
- break;
- case COLOR_TITLE:
- chooseColor.lCustData = (LPARAM) string;
- break;
- }
- }
-
- Tk_MakeWindowExist(parent);
- chooseColor.hwndOwner = NULL;
- hWnd = Tk_GetHWND(Tk_WindowId(parent));
- chooseColor.hwndOwner = hWnd;
-
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
- winCode = ChooseColor(&chooseColor);
- (void) Tcl_SetServiceMode(oldMode);
-
- /*
- * Ensure that hWnd is enabled, because it can happen that we have updated
- * the wrapper of the parent, which causes us to leave this child disabled
- * (Windows loses sync).
- */
-
- EnableWindow(hWnd, 1);
-
- /*
- * Clear the interp result since anything may have happened during the
- * modal loop.
- */
-
- Tcl_ResetResult(interp);
-
- /*
- * 3. Process the result of the dialog
- */
-
- if (winCode) {
- /*
- * User has selected a color
- */
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("#%02x%02x%02x",
- GetRValue(chooseColor.rgbResult),
- GetGValue(chooseColor.rgbResult),
- GetBValue(chooseColor.rgbResult)));
- oldColor = chooseColor.rgbResult;
- result = TCL_OK;
- }
-
- return result;
-}
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * ColorDlgHookProc --
- *
- * Provides special handling of messages for the Color common dialog box.
- * Used to set the title when the dialog first appears.
- *
- * Results:
- * The return value is 0 if the default dialog box function should handle
- * the message, non-zero otherwise.
- *
- * Side effects:
- * Changes the title of the dialog window.
- *
- *----------------------------------------------------------------------
- */
-
-static UINT CALLBACK
-ColorDlgHookProc(
- HWND hDlg, /* Handle to the color dialog. */
- UINT uMsg, /* Type of message. */
- WPARAM wParam, /* First message parameter. */
- LPARAM lParam) /* Second message parameter. */
-{
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- const char *title;
- CHOOSECOLOR *ccPtr;
-
- if (WM_INITDIALOG == uMsg) {
-
- /*
- * Set the title string of the dialog.
- */
-
- ccPtr = (CHOOSECOLOR *) lParam;
- title = (const char *) ccPtr->lCustData;
-
- if ((title != NULL) && (title[0] != '\0')) {
- Tcl_DString ds;
-
- SetWindowText(hDlg, Tcl_WinUtfToTChar(title,-1,&ds));
- Tcl_DStringFree(&ds);
- }
- if (tsdPtr->debugFlag) {
- tsdPtr->debugInterp = (Tcl_Interp *) ccPtr->lpTemplateName;
- Tcl_DoWhenIdle(SetTkDialog, hDlg);
- }
- return TRUE;
- }
- return FALSE;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_GetOpenFileCmd --
- *
- * This function implements the "open file" dialog box for the Windows
- * platform. See the user documentation for details on what it does.
- *
- * Results:
- * See user documentation.
- *
- * Side effects:
- * A dialog window is created the first this function is called.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tk_GetOpenFileObjCmd(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- return GetFileName(clientData, interp, objc, objv, OFN_FILE_OPEN);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_GetSaveFileCmd --
- *
- * Same as Tk_GetOpenFileCmd but opens a "save file" dialog box
- * instead
- *
- * Results:
- * Same as Tk_GetOpenFileCmd.
- *
- * Side effects:
- * Same as Tk_GetOpenFileCmd.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tk_GetSaveFileObjCmd(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- return GetFileName(clientData, interp, objc, objv, OFN_FILE_SAVE);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * CleanupOFNOptions --
- *
- * Cleans up any storage allocated by ParseOFNOptions
- *
- * Results:
- * None.
- *
- * Side effects:
- * Releases resources held by *optsPtr
- *----------------------------------------------------------------------
- */
-static void CleanupOFNOptions(OFNOpts *optsPtr)
-{
- Tcl_DStringFree(&optsPtr->utfDirString);
-}
-
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ParseOFNOptions --
- *
- * Option parsing for tk_get{Open,Save}File
- *
- * Results:
- * TCL_OK on success, TCL_ERROR otherwise
- *
- * Side effects:
- * Returns option values in *optsPtr. Note these may include string
- * pointers into objv[]
- *----------------------------------------------------------------------
- */
-
-static int
-ParseOFNOptions(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[], /* Argument objects. */
- enum OFNOper oper, /* 1 for Open, 0 for Save */
- OFNOpts *optsPtr) /* Output, uninitialized on entry */
-{
- int i;
- Tcl_DString ds;
- enum options {
- FILE_DEFAULT, FILE_TYPES, FILE_INITDIR, FILE_INITFILE, FILE_PARENT,
- FILE_TITLE, FILE_TYPEVARIABLE, FILE_MULTIPLE, FILE_CONFIRMOW,
- FILE_MUSTEXIST,
- };
- struct Options {
- const char *name;
- enum options value;
- };
- static const struct Options saveOptions[] = {
- {"-confirmoverwrite", FILE_CONFIRMOW},
- {"-defaultextension", FILE_DEFAULT},
- {"-filetypes", FILE_TYPES},
- {"-initialdir", FILE_INITDIR},
- {"-initialfile", FILE_INITFILE},
- {"-parent", FILE_PARENT},
- {"-title", FILE_TITLE},
- {"-typevariable", FILE_TYPEVARIABLE},
- {NULL, FILE_DEFAULT/*ignored*/ }
- };
- static const struct Options openOptions[] = {
- {"-defaultextension", FILE_DEFAULT},
- {"-filetypes", FILE_TYPES},
- {"-initialdir", FILE_INITDIR},
- {"-initialfile", FILE_INITFILE},
- {"-multiple", FILE_MULTIPLE},
- {"-parent", FILE_PARENT},
- {"-title", FILE_TITLE},
- {"-typevariable", FILE_TYPEVARIABLE},
- {NULL, FILE_DEFAULT/*ignored*/ }
- };
- static const struct Options dirOptions[] = {
- {"-initialdir", FILE_INITDIR},
- {"-mustexist", FILE_MUSTEXIST},
- {"-parent", FILE_PARENT},
- {"-title", FILE_TITLE},
- {NULL, FILE_DEFAULT/*ignored*/ }
- };
-
- const struct Options *options = NULL;
-
- switch (oper) {
- case OFN_FILE_SAVE: options = saveOptions; break;
- case OFN_DIR_CHOOSE: options = dirOptions; break;
- case OFN_FILE_OPEN: options = openOptions; break;
- }
-
- ZeroMemory(optsPtr, sizeof(*optsPtr));
- // optsPtr->forceXPStyle = 1;
- optsPtr->tkwin = clientData;
- optsPtr->confirmOverwrite = 1; /* By default we ask for confirmation */
- Tcl_DStringInit(&optsPtr->utfDirString);
- optsPtr->file[0] = 0;
-
- for (i = 1; i < objc; i += 2) {
- int index;
- const char *string;
- Tcl_Obj *valuePtr = objv[i + 1];
-
- if (Tcl_GetIndexFromObjStruct(interp, objv[i], options,
- sizeof(struct Options), "option", 0, &index) != TCL_OK) {
- /*
- * XXX -xpstyle is explicitly checked for as it is undocumented
- * and we do not want it to show in option error messages.
- */
- if (strcmp(Tcl_GetString(objv[i]), "-xpstyle"))
- goto error_return;
- if (Tcl_GetBooleanFromObj(interp, valuePtr,
- &optsPtr->forceXPStyle) != TCL_OK)
- goto error_return;
-
- continue;
-
- } else if (i + 1 == objc) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "value for \"%s\" missing", options[index].name));
- Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", NULL);
- goto error_return;
- }
-
- string = Tcl_GetString(valuePtr);
- switch (options[index].value) {
- case FILE_DEFAULT:
- optsPtr->extObj = valuePtr;
- break;
- case FILE_TYPES:
- optsPtr->filterObj = valuePtr;
- break;
- case FILE_INITDIR:
- Tcl_DStringFree(&optsPtr->utfDirString);
- if (Tcl_TranslateFileName(interp, string,
- &optsPtr->utfDirString) == NULL)
- goto error_return;
- break;
- case FILE_INITFILE:
- if (Tcl_TranslateFileName(interp, string, &ds) == NULL)
- goto error_return;
- Tcl_UtfToExternal(NULL, TkWinGetUnicodeEncoding(),
- Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), 0, NULL,
- (char *) &optsPtr->file[0], sizeof(optsPtr->file),
- NULL, NULL, NULL);
- Tcl_DStringFree(&ds);
- break;
- case FILE_PARENT:
- optsPtr->tkwin = Tk_NameToWindow(interp, string, clientData);
- if (optsPtr->tkwin == NULL)
- goto error_return;
- break;
- case FILE_TITLE:
- optsPtr->titleObj = valuePtr;
- break;
- case FILE_TYPEVARIABLE:
- optsPtr->typeVariableObj = valuePtr;
- optsPtr->initialTypeObj = Tcl_ObjGetVar2(interp, valuePtr,
- NULL, TCL_GLOBAL_ONLY);
- break;
- case FILE_MULTIPLE:
- if (Tcl_GetBooleanFromObj(interp, valuePtr,
- &optsPtr->multi) != TCL_OK)
- goto error_return;
- break;
- case FILE_CONFIRMOW:
- if (Tcl_GetBooleanFromObj(interp, valuePtr,
- &optsPtr->confirmOverwrite) != TCL_OK)
- goto error_return;
- break;
- case FILE_MUSTEXIST:
- if (Tcl_GetBooleanFromObj(interp, valuePtr,
- &optsPtr->mustExist) != TCL_OK)
- goto error_return;
- break;
- }
- }
-
- return TCL_OK;
-
-error_return: /* interp should already hold error */
- /* On error, we need to clean up anything we might have allocated */
- CleanupOFNOptions(optsPtr);
- return TCL_ERROR;
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- * VistaFileDialogsAvailable
- *
- * Checks whether the new (Vista) file dialogs can be used on
- * the system.
- *
- * Returns:
- * 1 if new dialogs are available, 0 otherwise
- *
- * Side effects:
- * Loads required procedures dynamically if available.
- * If new dialogs are available, COM is also initialized.
- *----------------------------------------------------------------------
- */
-static int VistaFileDialogsAvailable()
-{
- HRESULT hr;
- IFileDialog *fdlgPtr = NULL;
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- if (tsdPtr->newFileDialogsState == FDLG_STATE_INIT) {
- tsdPtr->newFileDialogsState = FDLG_STATE_USE_OLD;
- LoadShellProcs();
- if (ShellProcs.SHCreateItemFromParsingName != NULL) {
- hr = CoInitialize(0);
- /* XXX - need we schedule CoUninitialize at thread shutdown ? */
-
- /* Ensure all COM interfaces we use are available */
- if (SUCCEEDED(hr)) {
- hr = CoCreateInstance(&ClsidFileOpenDialog, NULL,
- CLSCTX_INPROC_SERVER, &IIDIFileOpenDialog, (void **) &fdlgPtr);
- if (SUCCEEDED(hr)) {
- fdlgPtr->lpVtbl->Release(fdlgPtr);
- hr = CoCreateInstance(&ClsidFileSaveDialog, NULL,
- CLSCTX_INPROC_SERVER, &IIDIFileSaveDialog,
- (void **) &fdlgPtr);
- if (SUCCEEDED(hr)) {
- fdlgPtr->lpVtbl->Release(fdlgPtr);
-
- /* Looks like we have all we need */
- tsdPtr->newFileDialogsState = FDLG_STATE_USE_NEW;
- }
- }
- }
- }
- }
-
- return (tsdPtr->newFileDialogsState == FDLG_STATE_USE_NEW);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * GetFileNameVista --
- *
- * Displays the new file dialogs on Vista and later.
- * This function must generally not be called unless the
- * tsdPtr->newFileDialogsState is FDLG_STATE_USE_NEW but if
- * it is, it will just pass the call to the older GetFileNameXP
- *
- * Results:
- * TCL_OK - dialog was successfully displayed, results returned in interp
- * TCL_ERROR - error return
- *
- * Side effects:
- * Dialogs is displayed
- *----------------------------------------------------------------------
- */
-static int GetFileNameVista(Tcl_Interp *interp, OFNOpts *optsPtr,
- enum OFNOper oper)
-{
- HRESULT hr;
- HWND hWnd;
- DWORD flags, nfilters, defaultFilterIndex;
- TCLCOMDLG_FILTERSPEC *filterPtr = NULL;
- IFileDialog *fdlgIf = NULL;
- IShellItem *dirIf = NULL;
- LPWSTR wstr;
- Tcl_Obj *resultObj = NULL;
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- int oldMode;
-
- if (tsdPtr->newFileDialogsState != FDLG_STATE_USE_NEW) {
- /* XXX - should be an assert but Tcl does not seem to have one? */
- Tcl_SetResult(interp, "Internal error: GetFileNameVista: IFileDialog API not available", TCL_STATIC);
- return TCL_ERROR;
- }
-
- /*
- * At this point new interfaces are supposed to be available.
- * fdlgIf is actually a IFileOpenDialog or IFileSaveDialog
- * both of which inherit from IFileDialog. We use the common
- * IFileDialog interface for the most part, casting only for
- * type-specific calls.
- */
- Tk_MakeWindowExist(optsPtr->tkwin);
- hWnd = Tk_GetHWND(Tk_WindowId(optsPtr->tkwin));
-
- /*
- * The only validation we need to do w.r.t caller supplied data
- * is the filter specification so do that before creating
- */
- if (MakeFilterVista(interp, optsPtr, &nfilters, &filterPtr,
- &defaultFilterIndex) != TCL_OK)
- return TCL_ERROR;
-
- /*
- * Beyond this point, do not just return on error as there will be
- * resources that need to be released/freed.
- */
-
- if (oper == OFN_FILE_OPEN || oper == OFN_DIR_CHOOSE)
- hr = CoCreateInstance(&ClsidFileOpenDialog, NULL,
- CLSCTX_INPROC_SERVER, &IIDIFileOpenDialog, (void **) &fdlgIf);
- else
- hr = CoCreateInstance(&ClsidFileSaveDialog, NULL,
- CLSCTX_INPROC_SERVER, &IIDIFileSaveDialog, (void **) &fdlgIf);
-
- if (FAILED(hr))
- goto vamoose;
-
- /*
- * Get current settings first because we want to preserve existing
- * settings like whether to show hidden files etc. based on the
- * user's existing preference
- */
- hr = fdlgIf->lpVtbl->GetOptions(fdlgIf, &flags);
- if (FAILED(hr))
- goto vamoose;
-
- if (filterPtr) {
- flags |= FOS_STRICTFILETYPES;
- hr = fdlgIf->lpVtbl->SetFileTypes(fdlgIf, nfilters, filterPtr);
- if (FAILED(hr))
- goto vamoose;
- hr = fdlgIf->lpVtbl->SetFileTypeIndex(fdlgIf, defaultFilterIndex);
- if (FAILED(hr))
- goto vamoose;
- }
-
- /* Flags are equivalent to those we used in the older API */
-
- /*
- * Following flags must be set irrespective of original setting
- * XXX - should FOS_NOVALIDATE be there ? Note FOS_NOVALIDATE has different
- * semantics than OFN_NOVALIDATE in the old API.
- */
- flags |=
- FOS_FORCEFILESYSTEM | /* Only want files, not other shell items */
- FOS_NOVALIDATE | /* Don't check for access denied etc. */
- FOS_PATHMUSTEXIST; /* The *directory* path must exist */
-
-
- if (oper == OFN_DIR_CHOOSE) {
- flags |= FOS_PICKFOLDERS;
- if (optsPtr->mustExist)
- flags |= FOS_FILEMUSTEXIST; /* XXX - check working */
- } else
- flags &= ~ FOS_PICKFOLDERS;
-
- if (optsPtr->multi)
- flags |= FOS_ALLOWMULTISELECT;
- else
- flags &= ~FOS_ALLOWMULTISELECT;
-
- if (optsPtr->confirmOverwrite)
- flags |= FOS_OVERWRITEPROMPT;
- else
- flags &= ~FOS_OVERWRITEPROMPT;
-
- hr = fdlgIf->lpVtbl->SetOptions(fdlgIf, flags);
- if (FAILED(hr))
- goto vamoose;
-
- if (optsPtr->extObj != NULL) {
- wstr = Tcl_GetUnicode(optsPtr->extObj);
- if (wstr[0] == L'.')
- ++wstr;
- hr = fdlgIf->lpVtbl->SetDefaultExtension(fdlgIf, wstr);
- if (FAILED(hr))
- goto vamoose;
- }
-
- if (optsPtr->titleObj != NULL) {
- hr = fdlgIf->lpVtbl->SetTitle(fdlgIf,
- Tcl_GetUnicode(optsPtr->titleObj));
- if (FAILED(hr))
- goto vamoose;
- }
-
- if (optsPtr->file[0]) {
- hr = fdlgIf->lpVtbl->SetFileName(fdlgIf, optsPtr->file);
- if (FAILED(hr))
- goto vamoose;
- }
-
- if (Tcl_DStringValue(&optsPtr->utfDirString)[0] != '\0') {
- Tcl_DString dirString;
- Tcl_WinUtfToTChar(Tcl_DStringValue(&optsPtr->utfDirString),
- Tcl_DStringLength(&optsPtr->utfDirString), &dirString);
- hr = ShellProcs.SHCreateItemFromParsingName(
- (TCHAR *) Tcl_DStringValue(&dirString), NULL,
- &IIDIShellItem, (void **) &dirIf);
- /* XXX - Note on failure we do not raise error, simply ignore ini dir */
- if (SUCCEEDED(hr)) {
- /* Note we use SetFolder, not SetDefaultFolder - see MSDN docs */
- fdlgIf->lpVtbl->SetFolder(fdlgIf, dirIf); /* Ignore errors */
- }
- Tcl_DStringFree(&dirString);
- }
-
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
- hr = fdlgIf->lpVtbl->Show(fdlgIf, hWnd);
- Tcl_SetServiceMode(oldMode);
-
- /*
- * Ensure that hWnd is enabled, because it can happen that we have updated
- * the wrapper of the parent, which causes us to leave this child disabled
- * (Windows loses sync).
- */
-
- if (hWnd)
- EnableWindow(hWnd, 1);
-
- /*
- * Clear interp result since it might have been set during the modal loop.
- * http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6
- */
- Tcl_ResetResult(interp);
-
- if (SUCCEEDED(hr)) {
- if ((oper == OFN_FILE_OPEN) && optsPtr->multi) {
- IShellItemArray *multiIf;
- DWORD dw, count;
- IFileOpenDialog *fodIf = (IFileOpenDialog *) fdlgIf;
- hr = fodIf->lpVtbl->GetResults(fodIf, &multiIf);
- if (SUCCEEDED(hr)) {
- Tcl_Obj *multiObj;
- hr = multiIf->lpVtbl->GetCount(multiIf, &count);
- multiObj = Tcl_NewListObj(count, NULL);
- if (SUCCEEDED(hr)) {
- IShellItem *itemIf;
- for (dw = 0; dw < count; ++dw) {
- hr = multiIf->lpVtbl->GetItemAt(multiIf, dw, &itemIf);
- if (FAILED(hr))
- break;
- hr = itemIf->lpVtbl->GetDisplayName(itemIf,
- SIGDN_FILESYSPATH, &wstr);
- if (SUCCEEDED(hr)) {
- Tcl_DString fnds;
- ConvertExternalFilename(wstr, &fnds);
- CoTaskMemFree(wstr);
- Tcl_ListObjAppendElement(
- interp, multiObj,
- Tcl_NewStringObj(Tcl_DStringValue(&fnds),
- Tcl_DStringLength(&fnds)));
- }
- itemIf->lpVtbl->Release(itemIf);
- if (FAILED(hr))
- break;
- }
- }
- multiIf->lpVtbl->Release(multiIf);
- if (SUCCEEDED(hr))
- resultObj = multiObj;
- else
- Tcl_DecrRefCount(multiObj);
- }
- } else {
- IShellItem *resultIf;
- hr = fdlgIf->lpVtbl->GetResult(fdlgIf, &resultIf);
- if (SUCCEEDED(hr)) {
- hr = resultIf->lpVtbl->GetDisplayName(resultIf, SIGDN_FILESYSPATH,
- &wstr);
- if (SUCCEEDED(hr)) {
- Tcl_DString fnds;
- ConvertExternalFilename(wstr, &fnds);
- resultObj = Tcl_NewStringObj(Tcl_DStringValue(&fnds),
- Tcl_DStringLength(&fnds));
- CoTaskMemFree(wstr);
- }
- resultIf->lpVtbl->Release(resultIf);
- }
- }
- if (SUCCEEDED(hr)) {
- if (filterPtr && optsPtr->typeVariableObj) {
- UINT ftix;
- hr = fdlgIf->lpVtbl->GetFileTypeIndex(fdlgIf, &ftix);
- if (SUCCEEDED(hr)) {
- /* Note ftix is a 1-based index */
- if (ftix > 0 && ftix <= nfilters) {
- Tcl_ObjSetVar2(interp, optsPtr->typeVariableObj, NULL,
- Tcl_NewUnicodeObj(filterPtr[ftix-1].pszName, -1),
- TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
- }
- }
- }
- }
- } else {
- if (hr == HRESULT_FROM_WIN32(ERROR_CANCELLED))
- hr = 0; /* User cancelled, return empty string */
- }
-
-vamoose: /* (hr != 0) => error */
- if (dirIf)
- dirIf->lpVtbl->Release(dirIf);
- if (fdlgIf)
- fdlgIf->lpVtbl->Release(fdlgIf);
-
- if (filterPtr)
- FreeFilterVista(nfilters, filterPtr);
-
- if (hr == 0) {
- if (resultObj) /* May be NULL if user cancelled */
- Tcl_SetObjResult(interp, resultObj);
- return TCL_OK;
- } else {
- if (resultObj)
- Tcl_DecrRefCount(resultObj);
- Tcl_SetObjResult(interp, TkWin32ErrorObj(hr));
- return TCL_ERROR;
- }
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * GetFileNameXP --
- *
- * Displays the old pre-Vista file dialogs.
- *
- * Results:
- * TCL_OK - if dialog was successfully displayed
- * TCL_ERROR - error return
- *
- * Side effects:
- * See user documentation.
- *----------------------------------------------------------------------
- */
-static int GetFileNameXP(Tcl_Interp *interp, OFNOpts *optsPtr, enum OFNOper oper)
-{
- OPENFILENAME ofn;
- OFNData ofnData;
- int cdlgerr;
- int filterIndex = 0, result = TCL_ERROR, winCode, oldMode;
- HWND hWnd;
- Tcl_DString utfFilterString, ds;
- Tcl_DString extString, filterString, dirString, titleString;
- const char *str;
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- ZeroMemory(&ofnData, sizeof(OFNData));
- Tcl_DStringInit(&utfFilterString);
- Tcl_DStringInit(&dirString); /* XXX - original code was missing this
- leaving dirString uninitialized for
- the unlikely code path where cwd failed */
-
- if (MakeFilter(interp, optsPtr->filterObj, &utfFilterString,
- optsPtr->initialTypeObj, &filterIndex) != TCL_OK) {
- goto end;
- }
-
- Tk_MakeWindowExist(optsPtr->tkwin);
- hWnd = Tk_GetHWND(Tk_WindowId(optsPtr->tkwin));
-
- ZeroMemory(&ofn, sizeof(OPENFILENAME));
- ofn.lStructSize = sizeof(OPENFILENAME);
- ofn.hwndOwner = hWnd;
- ofn.hInstance = TkWinGetHInstance(ofn.hwndOwner);
- ofn.lpstrFile = optsPtr->file;
- ofn.nMaxFile = TK_MULTI_MAX_PATH;
- ofn.Flags = OFN_HIDEREADONLY | OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR
- | OFN_EXPLORER| OFN_ENABLEHOOK| OFN_ENABLESIZING;
- ofn.lpfnHook = (LPOFNHOOKPROC) OFNHookProc;
- ofn.lCustData = (LPARAM) &ofnData;
-
- if (oper != OFN_FILE_SAVE) {
- ofn.Flags |= OFN_FILEMUSTEXIST;
- } else if (optsPtr->confirmOverwrite) {
- ofn.Flags |= OFN_OVERWRITEPROMPT;
- }
- if (tsdPtr->debugFlag != 0) {
- ofnData.interp = interp;
- }
- if (optsPtr->multi != 0) {
- ofn.Flags |= OFN_ALLOWMULTISELECT;
-
- /*
- * Starting buffer size. The buffer will be expanded by the OFN dialog
- * procedure when necessary
- */
-
- ofnData.dynFileBufferSize = 512;
- ofnData.dynFileBuffer = ckalloc(512 * sizeof(TCHAR));
- }
-
- if (optsPtr->extObj != NULL) {
- str = Tcl_GetString(optsPtr->extObj);
- if (str[0] == '.')
- ++str;
- Tcl_WinUtfToTChar(str, -1, &extString);
- ofn.lpstrDefExt = (TCHAR *) Tcl_DStringValue(&extString);
- }
-
- Tcl_WinUtfToTChar(Tcl_DStringValue(&utfFilterString),
- Tcl_DStringLength(&utfFilterString), &filterString);
- ofn.lpstrFilter = (TCHAR *) Tcl_DStringValue(&filterString);
- ofn.nFilterIndex = filterIndex;
-
- if (Tcl_DStringValue(&optsPtr->utfDirString)[0] != '\0') {
- Tcl_WinUtfToTChar(Tcl_DStringValue(&optsPtr->utfDirString),
- Tcl_DStringLength(&optsPtr->utfDirString), &dirString);
- } else {
- /*
- * NT 5.0 changed the meaning of lpstrInitialDir, so we have to ensure
- * that we set the [pwd] if the user didn't specify anything else.
- */
-
- Tcl_DString cwd;
-
- Tcl_DStringFree(&optsPtr->utfDirString);
- if ((Tcl_GetCwd(interp, &optsPtr->utfDirString) == NULL) ||
- (Tcl_TranslateFileName(interp,
- Tcl_DStringValue(&optsPtr->utfDirString), &cwd) == NULL)) {
- Tcl_ResetResult(interp);
- } else {
- Tcl_WinUtfToTChar(Tcl_DStringValue(&cwd),
- Tcl_DStringLength(&cwd), &dirString);
- }
- Tcl_DStringFree(&cwd);
- }
- ofn.lpstrInitialDir = (TCHAR *) Tcl_DStringValue(&dirString);
-
- if (optsPtr->titleObj != NULL) {
- Tcl_WinUtfToTChar(Tcl_GetString(optsPtr->titleObj), -1, &titleString);
- ofn.lpstrTitle = (TCHAR *) Tcl_DStringValue(&titleString);
- }
-
- /*
- * Popup the dialog.
- */
-
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
- if (oper != OFN_FILE_SAVE) {
- winCode = GetOpenFileName(&ofn);
- } else {
- winCode = GetSaveFileName(&ofn);
- }
- Tcl_SetServiceMode(oldMode);
- EatSpuriousMessageBugFix();
-
- /*
- * Ensure that hWnd is enabled, because it can happen that we have updated
- * the wrapper of the parent, which causes us to leave this child disabled
- * (Windows loses sync).
- */
-
- EnableWindow(hWnd, 1);
-
- /*
- * Clear the interp result since anything may have happened during the
- * modal loop.
- */
-
- Tcl_ResetResult(interp);
-
- /*
- * Process the results.
- *
- * Use the CommDlgExtendedError() function to retrieve the error code.
- * This function can return one of about two dozen codes; most of these
- * indicate some sort of gross system failure (insufficient memory, bad
- * window handles, etc.). Most of the error codes will be ignored; as we
- * find we want more specific error messages for particular errors, we can
- * extend the code as needed.
- */
-
- cdlgerr = CommDlgExtendedError();
-
- /*
- * We now allow FNERR_BUFFERTOOSMALL when multiselection is enabled. The
- * filename buffer has been dynamically allocated by the OFN dialog
- * procedure to accomodate all selected files.
- */
-
- if ((winCode != 0)
- || ((cdlgerr == FNERR_BUFFERTOOSMALL)
- && (ofn.Flags & OFN_ALLOWMULTISELECT))) {
- int gotFilename = 0; /* Flag for tracking whether we have any
- * filename at all. For details, see
- * http://stackoverflow.com/q/9227859/301832
- */
-
- if (ofn.Flags & OFN_ALLOWMULTISELECT) {
- /*
- * The result in dynFileBuffer contains many items, separated by
- * NUL characters. It is terminated with two nulls in a row. The
- * first element is the directory path.
- */
-
- TCHAR *files = ofnData.dynFileBuffer;
- Tcl_Obj *returnList = Tcl_NewObj();
- int count = 0;
-
- /*
- * Get directory.
- */
-
- ConvertExternalFilename(files, &ds);
-
- while (*files != '\0') {
- while (*files != '\0') {
- files++;
- }
- files++;
- if (*files != '\0') {
- Tcl_Obj *fullnameObj;
- Tcl_DString filenameBuf;
-
- count++;
- ConvertExternalFilename(files, &filenameBuf);
-
- fullnameObj = Tcl_NewStringObj(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_AppendToObj(fullnameObj, "/", -1);
- Tcl_AppendToObj(fullnameObj, Tcl_DStringValue(&filenameBuf),
- Tcl_DStringLength(&filenameBuf));
- gotFilename = 1;
- Tcl_DStringFree(&filenameBuf);
- Tcl_ListObjAppendElement(NULL, returnList, fullnameObj);
- }
- }
-
- if (count == 0) {
- /*
- * Only one file was returned.
- */
-
- Tcl_ListObjAppendElement(NULL, returnList,
- Tcl_NewStringObj(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds)));
- gotFilename |= (Tcl_DStringLength(&ds) > 0);
- }
- Tcl_SetObjResult(interp, returnList);
- Tcl_DStringFree(&ds);
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- ConvertExternalFilename(ofn.lpstrFile, &ds), -1));
- gotFilename = (Tcl_DStringLength(&ds) > 0);
- Tcl_DStringFree(&ds);
- }
- result = TCL_OK;
- if ((ofn.nFilterIndex > 0) && gotFilename && optsPtr->typeVariableObj
- && optsPtr->filterObj) {
- int listObjc, count;
- Tcl_Obj **listObjv = NULL;
- Tcl_Obj **typeInfo = NULL;
-
- if (Tcl_ListObjGetElements(interp, optsPtr->filterObj,
- &listObjc, &listObjv) != TCL_OK) {
- result = TCL_ERROR;
- } else if (Tcl_ListObjGetElements(interp,
- listObjv[ofn.nFilterIndex - 1], &count,
- &typeInfo) != TCL_OK) {
- result = TCL_ERROR;
- } else {
- /*
- * BUGFIX for d43a10ce2fed950e00890049f3c273f2cdd12583
- * The original code was broken because it passed typeinfo[0]
- * directly into Tcl_ObjSetVar2. In the case of typeInfo[0]
- * pointing into a list which is also referenced by
- * typeVariableObj, TOSV2 shimmers the object into
- * variable intrep which loses the list representation.
- * This invalidates typeInfo[0] which is freed but
- * nevertheless stored as the value of the variable.
- */
- Tcl_Obj *selFilterObj = typeInfo[0];
- Tcl_IncrRefCount(selFilterObj);
- if (Tcl_ObjSetVar2(interp, optsPtr->typeVariableObj, NULL,
- selFilterObj, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
- result = TCL_ERROR;
- }
- Tcl_DecrRefCount(selFilterObj);
- }
- }
- } else if (cdlgerr == FNERR_INVALIDFILENAME) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid filename \"%s\"",
- ConvertExternalFilename(ofn.lpstrFile, &ds)));
- Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "INVALID_FILENAME",
- NULL);
- Tcl_DStringFree(&ds);
- } else {
- result = TCL_OK;
- }
-
- if (ofn.lpstrTitle != NULL) {
- Tcl_DStringFree(&titleString);
- }
- if (ofn.lpstrInitialDir != NULL) {
- /* XXX - huh? lpstrInitialDir is set from Tcl_DStringValue which
- can never return NULL */
- Tcl_DStringFree(&dirString);
- }
- Tcl_DStringFree(&filterString);
- if (ofn.lpstrDefExt != NULL) {
- Tcl_DStringFree(&extString);
- }
-
-end:
- Tcl_DStringFree(&utfFilterString);
- if (ofnData.dynFileBuffer != NULL) {
- ckfree(ofnData.dynFileBuffer);
- ofnData.dynFileBuffer = NULL;
- }
-
- return result;
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * GetFileName --
- *
- * Calls GetOpenFileName() or GetSaveFileName().
- *
- * Results:
- * See user documentation.
- *
- * Side effects:
- * See user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetFileName(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[], /* Argument objects. */
- enum OFNOper oper) /* 1 to call GetOpenFileName(), 0 to call
- * GetSaveFileName(). */
-{
- OFNOpts ofnOpts;
- int result;
-
- result = ParseOFNOptions(clientData, interp, objc, objv, oper, &ofnOpts);
- if (result != TCL_OK)
- return result;
-
- if (VistaFileDialogsAvailable() && ! ofnOpts.forceXPStyle)
- result = GetFileNameVista(interp, &ofnOpts, oper);
- else
- result = GetFileNameXP(interp, &ofnOpts, oper);
-
- CleanupOFNOptions(&ofnOpts);
- return result;
-}
-
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * OFNHookProc --
- *
- * Dialog box hook function. This is used to sets the "tk_dialog"
- * variable for test/debugging when the dialog is ready to receive
- * messages. When multiple file selection is enabled this function
- * is used to process the list of names.
- *
- * Results:
- * Returns 0 to allow default processing of messages to occur.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------------
- */
-
-static UINT APIENTRY
-OFNHookProc(
- HWND hdlg, /* Handle to child dialog window. */
- UINT uMsg, /* Message identifier */
- WPARAM wParam, /* Message parameter */
- LPARAM lParam) /* Message parameter */
-{
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- OPENFILENAME *ofnPtr;
- OFNData *ofnData;
-
- if (uMsg == WM_INITDIALOG) {
- TkWinSetUserData(hdlg, lParam);
- } else if (uMsg == WM_NOTIFY) {
- OFNOTIFY *notifyPtr = (OFNOTIFY *) lParam;
-
- /*
- * This is weird... or not. The CDN_FILEOK is NOT sent when the
- * selection exceeds declared buffer size (the nMaxFile member of the
- * OPENFILENAME struct passed to GetOpenFileName function). So, we
- * have to rely on the most recent CDN_SELCHANGE then. Unfortunately
- * this means, that gathering the selected filenames happens twice
- * when they fit into the declared buffer. Luckily, it's not frequent
- * operation so it should not incur any noticeable delay. See [Bug
- * 2987995]
- */
-
- if (notifyPtr->hdr.code == CDN_FILEOK ||
- notifyPtr->hdr.code == CDN_SELCHANGE) {
- int dirsize, selsize;
- TCHAR *buffer;
- int buffersize;
-
- /*
- * Change of selection. Unscramble the unholy mess that's in the
- * selection buffer, resizing it if necessary.
- */
-
- ofnPtr = notifyPtr->lpOFN;
- ofnData = (OFNData *) ofnPtr->lCustData;
- buffer = ofnData->dynFileBuffer;
- hdlg = GetParent(hdlg);
-
- selsize = (int) SendMessage(hdlg, CDM_GETSPEC, 0, 0);
- dirsize = (int) SendMessage(hdlg, CDM_GETFOLDERPATH, 0, 0);
- buffersize = (selsize + dirsize + 1);
-
- /*
- * Just empty the buffer if dirsize indicates an error. [Bug
- * 3071836]
- */
-
- if ((selsize > 1) && (dirsize > 0)) {
- if (ofnData->dynFileBufferSize < buffersize) {
- buffer = ckrealloc(buffer, buffersize * sizeof(TCHAR));
- ofnData->dynFileBufferSize = buffersize;
- ofnData->dynFileBuffer = buffer;
- }
-
- SendMessage(hdlg, CDM_GETFOLDERPATH, dirsize, (LPARAM) buffer);
- buffer += dirsize;
-
- SendMessage(hdlg, CDM_GETSPEC, selsize, (LPARAM) buffer);
-
- /*
- * If there are multiple files, delete the quotes and change
- * every second quote to NULL terminator
- */
-
- if (buffer[0] == '"') {
- BOOL findquote = TRUE;
- TCHAR *tmp = buffer;
-
- while (*buffer != '\0') {
- if (findquote) {
- if (*buffer == '"') {
- findquote = FALSE;
- }
- buffer++;
- } else {
- if (*buffer == '"') {
- findquote = TRUE;
- *buffer = '\0';
- }
- *tmp++ = *buffer++;
- }
- }
- *tmp = '\0'; /* Second NULL terminator. */
- } else {
-
- /*
- * Replace directory terminating NULL with a with a backslash,
- * but only if not an absolute path.
- */
-
- Tcl_DString tmpfile;
- ConvertExternalFilename(buffer, &tmpfile);
- if (TCL_PATH_ABSOLUTE ==
- Tcl_GetPathType(Tcl_DStringValue(&tmpfile))) {
- /* re-get the full path to the start of the buffer */
- buffer = (TCHAR *) ofnData->dynFileBuffer;
- SendMessage(hdlg, CDM_GETSPEC, selsize, (LPARAM) buffer);
- } else {
- *(buffer-1) = '\\';
- }
- buffer[selsize] = '\0'; /* Second NULL terminator. */
- Tcl_DStringFree(&tmpfile);
- }
- } else {
- /*
- * Nothing is selected, so just empty the string.
- */
-
- if (buffer != NULL) {
- *buffer = '\0';
- }
- }
- }
- } else if (uMsg == WM_WINDOWPOSCHANGED) {
- /*
- * This message is delivered at the right time to enable Tk to set the
- * debug information. Unhooks itself so it won't set the debug
- * information every time it gets a WM_WINDOWPOSCHANGED message.
- */
-
- ofnPtr = (OPENFILENAME *) TkWinGetUserData(hdlg);
- if (ofnPtr != NULL) {
- ofnData = (OFNData *) ofnPtr->lCustData;
- if (ofnData->interp != NULL) {
- hdlg = GetParent(hdlg);
- tsdPtr->debugInterp = ofnData->interp;
- Tcl_DoWhenIdle(SetTkDialog, hdlg);
- }
- TkWinSetUserData(hdlg, NULL);
- }
- }
- return 0;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * MakeFilter --
- *
- * Allocate a buffer to store the filters in a format understood by
- * Windows.
- *
- * Results:
- * A standard TCL return value.
- *
- * Side effects:
- * ofnPtr->lpstrFilter is modified.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-MakeFilter(
- Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Obj *valuePtr, /* Value of the -filetypes option */
- Tcl_DString *dsPtr, /* Filled with windows filter string. */
- Tcl_Obj *initialPtr, /* Initial type name */
- int *indexPtr) /* Index of initial type in filter string */
-{
- char *filterStr;
- char *p;
- const char *initial = NULL;
- int pass;
- int ix = 0; /* index counter */
- FileFilterList flist;
- FileFilter *filterPtr;
-
- if (initialPtr) {
- initial = Tcl_GetString(initialPtr);
- }
- TkInitFileFilters(&flist);
- if (TkGetFileFilters(interp, &flist, valuePtr, 1) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (flist.filters == NULL) {
- /*
- * Use "All Files (*.*) as the default filter if none is specified
- */
- const char *defaultFilter = "All Files (*.*)";
-
- p = filterStr = ckalloc(30);
-
- strcpy(p, defaultFilter);
- p+= strlen(defaultFilter);
-
- *p++ = '\0';
- *p++ = '*';
- *p++ = '.';
- *p++ = '*';
- *p++ = '\0';
- *p++ = '\0';
- *p = '\0';
-
- } else {
- size_t len;
-
- if (valuePtr == NULL) {
- len = 0;
- } else {
- (void) Tcl_GetString(valuePtr);
- len = valuePtr->length;
- }
-
- /*
- * We format the filetype into a string understood by Windows: {"Text
- * Documents" {.doc .txt} {TEXT}} becomes "Text Documents
- * (*.doc,*.txt)\0*.doc;*.txt\0"
- *
- * See the Windows OPENFILENAME manual page for details on the filter
- * string format.
- */
-
- /*
- * Since we may only add asterisks (*) to the filter, we need at most
- * twice the size of the string to format the filter
- */
-
- filterStr = ckalloc(len * 3);
-
- for (filterPtr = flist.filters, p = filterStr; filterPtr;
- filterPtr = filterPtr->next) {
- const char *sep;
- FileFilterClause *clausePtr;
-
- /*
- * Check initial index for match, set *indexPtr. Filter index is 1
- * based so increment first
- */
-
- ix++;
- if (indexPtr && initial
- && (strcmp(initial, filterPtr->name) == 0)) {
- *indexPtr = ix;
- }
-
- /*
- * First, put in the name of the file type.
- */
-
- strcpy(p, filterPtr->name);
- p+= strlen(filterPtr->name);
- *p++ = ' ';
- *p++ = '(';
-
- for (pass = 1; pass <= 2; pass++) {
- /*
- * In the first pass, we format the extensions in the name
- * field. In the second pass, we format the extensions in the
- * filter pattern field
- */
-
- sep = "";
- for (clausePtr=filterPtr->clauses;clausePtr;
- clausePtr=clausePtr->next) {
- GlobPattern *globPtr;
-
- for (globPtr = clausePtr->patterns; globPtr;
- globPtr = globPtr->next) {
- strcpy(p, sep);
- p += strlen(sep);
- strcpy(p, globPtr->pattern);
- p += strlen(globPtr->pattern);
-
- if (pass == 1) {
- sep = ",";
- } else {
- sep = ";";
- }
- }
- }
- if (pass == 1) {
- *p ++ = ')';
- }
- *p++ = '\0';
- }
- }
-
- /*
- * Windows requires the filter string to be ended by two NULL
- * characters.
- */
-
- *p++ = '\0';
- *p = '\0';
- }
-
- Tcl_DStringAppend(dsPtr, filterStr, (int) (p - filterStr));
- ckfree(filterStr);
-
- TkFreeFileFilters(&flist);
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * FreeFilterVista
- *
- * Frees storage previously allocated by MakeFilterVista.
- * count is the number of elements in dlgFilterPtr[]
- */
-static void FreeFilterVista(DWORD count, TCLCOMDLG_FILTERSPEC *dlgFilterPtr)
-{
- if (dlgFilterPtr != NULL) {
- DWORD dw;
- for (dw = 0; dw < count; ++dw) {
- if (dlgFilterPtr[dw].pszName != NULL)
- ckfree(dlgFilterPtr[dw].pszName);
- if (dlgFilterPtr[dw].pszSpec != NULL)
- ckfree(dlgFilterPtr[dw].pszSpec);
- }
- ckfree(dlgFilterPtr);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * MakeFilterVista --
- *
- * Returns file type filters in a format required
- * by the Vista file dialogs.
- *
- * Results:
- * A standard TCL return value.
- *
- * Side effects:
- * Various values are returned through the parameters as
- * described in the comments below.
- *----------------------------------------------------------------------
- */
-static int MakeFilterVista(
- Tcl_Interp *interp, /* Current interpreter. */
- OFNOpts *optsPtr, /* Caller specified options */
- DWORD *countPtr, /* Will hold number of filters */
- TCLCOMDLG_FILTERSPEC **dlgFilterPtrPtr, /* Will hold pointer to filter array.
- Set to NULL if no filters specified.
- Must be freed by calling
- FreeFilterVista */
- DWORD *initialIndexPtr) /* Will hold index of default type */
-{
- TCLCOMDLG_FILTERSPEC *dlgFilterPtr;
- const char *initial = NULL;
- FileFilterList flist;
- FileFilter *filterPtr;
- DWORD initialIndex = 0;
- Tcl_DString ds, patterns;
- int i;
-
- if (optsPtr->filterObj == NULL) {
- *dlgFilterPtrPtr = NULL;
- *countPtr = 0;
- return TCL_OK;
- }
-
- if (optsPtr->initialTypeObj)
- initial = Tcl_GetString(optsPtr->initialTypeObj);
-
- TkInitFileFilters(&flist);
- if (TkGetFileFilters(interp, &flist, optsPtr->filterObj, 1) != TCL_OK)
- return TCL_ERROR;
-
- if (flist.filters == NULL) {
- *dlgFilterPtrPtr = NULL;
- *countPtr = 0;
- return TCL_OK;
- }
-
- Tcl_DStringInit(&ds);
- Tcl_DStringInit(&patterns);
- dlgFilterPtr = ckalloc(flist.numFilters * sizeof(*dlgFilterPtr));
-
- for (i = 0, filterPtr = flist.filters;
- filterPtr;
- filterPtr = filterPtr->next, ++i) {
- const char *sep;
- FileFilterClause *clausePtr;
- int nbytes;
-
- /* Check if this entry should be shown as the default */
- if (initial && strcmp(initial, filterPtr->name) == 0)
- initialIndex = i+1; /* Windows filter indices are 1-based */
-
- /* First stash away the text description of the pattern */
- Tcl_WinUtfToTChar(filterPtr->name, -1, &ds);
- nbytes = Tcl_DStringLength(&ds); /* # bytes, not Unicode chars */
- nbytes += sizeof(WCHAR); /* Terminating \0 */
- dlgFilterPtr[i].pszName = ckalloc(nbytes);
- memmove((void *) dlgFilterPtr[i].pszName, Tcl_DStringValue(&ds), nbytes);
- Tcl_DStringFree(&ds);
-
- /*
- * Loop through and join patterns with a ";" Each "clause"
- * corresponds to a single textual description (called typename)
- * in the tk_getOpenFile docs. Each such typename may occur
- * multiple times and all these form a single filter entry
- * with one clause per occurence. Further each clause may specify
- * multiple patterns. Hence the nested loop here.
- */
- sep = "";
- for (clausePtr=filterPtr->clauses ; clausePtr;
- clausePtr=clausePtr->next) {
- GlobPattern *globPtr;
- for (globPtr = clausePtr->patterns; globPtr;
- globPtr = globPtr->next) {
- Tcl_DStringAppend(&patterns, sep, -1);
- Tcl_DStringAppend(&patterns, globPtr->pattern, -1);
- sep = ";";
- }
- }
-
- /* Again we need a Unicode form of the string */
- Tcl_WinUtfToTChar(Tcl_DStringValue(&patterns), -1, &ds);
- nbytes = Tcl_DStringLength(&ds); /* # bytes, not Unicode chars */
- nbytes += sizeof(WCHAR); /* Terminating \0 */
- dlgFilterPtr[i].pszSpec = ckalloc(nbytes);
- memmove((void *)dlgFilterPtr[i].pszSpec, Tcl_DStringValue(&ds), nbytes);
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&patterns);
- }
-
- if (initialIndex == 0)
- initialIndex = 1; /* If no default, show first entry */
- *initialIndexPtr = initialIndex;
- *dlgFilterPtrPtr = dlgFilterPtr;
- *countPtr = flist.numFilters;
-
- TkFreeFileFilters(&flist);
- return TCL_OK;
-}
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_ChooseDirectoryObjCmd --
- *
- * This function implements the "tk_chooseDirectory" dialog box for the
- * Windows platform. See the user documentation for details on what it
- * does. Uses the newer SHBrowseForFolder explorer type interface.
- *
- * Results:
- * See user documentation.
- *
- * Side effects:
- * A modal dialog window is created. Tcl_SetServiceMode() is called to
- * allow background events to be processed
- *
- *----------------------------------------------------------------------
- *
- * The function tk_chooseDirectory pops up a dialog box for the user to select
- * a directory. The following option-value pairs are possible as command line
- * arguments:
- *
- * -initialdir dirname
- *
- * Specifies that the directories in directory should be displayed when the
- * dialog pops up. If this parameter is not specified, then the directories in
- * the current working directory are displayed. If the parameter specifies a
- * relative path, the return value will convert the relative path to an
- * absolute path. This option may not always work on the Macintosh. This is
- * not a bug. Rather, the General Controls control panel on the Mac allows the
- * end user to override the application default directory.
- *
- * -parent window
- *
- * Makes window the logical parent of the dialog. The dialog is displayed on
- * top of its parent window.
- *
- * -title titleString
- *
- * Specifies a string to display as the title of the dialog box. If this
- * option is not specified, then a default title will be displayed.
- *
- * -mustexist boolean
- *
- * Specifies whether the user may specify non-existant directories. If this
- * parameter is true, then the user may only select directories that already
- * exist. The default value is false.
- *
- * New Behaviour:
- *
- * - If mustexist = 0 and a user entered folder does not exist, a prompt will
- * pop-up asking if the user wants another chance to change it. The old
- * dialog just returned the bogus entry. On mustexist = 1, the entries MUST
- * exist before exiting the box with OK.
- *
- * Bugs:
- *
- * - If valid abs directory name is entered into the entry box and Enter
- * pressed, the box will close returning the name. This is inconsistent when
- * entering relative names or names with forward slashes, which are
- * invalidated then corrected in the callback. After correction, the box is
- * held open to allow further modification by the user.
- *
- * - Not sure how to implement localization of message prompts.
- *
- * - -title is really -message.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tk_ChooseDirectoryObjCmd(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- TCHAR path[MAX_PATH];
- int oldMode, result;
- LPCITEMIDLIST pidl; /* Returned by browser */
- BROWSEINFO bInfo; /* Used by browser */
- ChooseDir cdCBData; /* Structure to pass back and forth */
- LPMALLOC pMalloc; /* Used by shell */
- HWND hWnd;
- TCHAR saveDir[MAX_PATH];
- Tcl_DString titleString; /* Title */
- Tcl_DString tempString; /* temporary */
- Tcl_Obj *objPtr;
- OFNOpts ofnOpts;
- const char *utfDir;
-
- result = ParseOFNOptions(clientData, interp, objc, objv,
- OFN_DIR_CHOOSE, &ofnOpts);
- if (result != TCL_OK)
- return result;
-
- /* Use new dialogs if available */
- if (VistaFileDialogsAvailable() && ! ofnOpts.forceXPStyle) {
- result = GetFileNameVista(interp, &ofnOpts, OFN_DIR_CHOOSE);
- CleanupOFNOptions(&ofnOpts);
- return result;
- }
-
- /* Older dialogs */
-
- path[0] = '\0';
- ZeroMemory(&cdCBData, sizeof(ChooseDir));
- cdCBData.interp = interp;
- cdCBData.mustExist = ofnOpts.mustExist;
-
- utfDir = Tcl_DStringValue(&ofnOpts.utfDirString);
- if (utfDir[0] != '\0') {
- const TCHAR *uniStr;
-
- Tcl_WinUtfToTChar(Tcl_DStringValue(&ofnOpts.utfDirString), -1,
- &tempString);
- uniStr = (TCHAR *) Tcl_DStringValue(&tempString);
-
- /* Convert possible relative path to full path to keep dialog happy. */
-
- GetFullPathName(uniStr, MAX_PATH, saveDir, NULL);
- _tcsncpy(cdCBData.initDir, saveDir, MAX_PATH);
- }
-
- /* XXX - rest of this (original) code has no error checks at all. */
-
- /*
- * Get ready to call the browser
- */
-
- Tk_MakeWindowExist(ofnOpts.tkwin);
- hWnd = Tk_GetHWND(Tk_WindowId(ofnOpts.tkwin));
-
- /*
- * Setup the parameters used by SHBrowseForFolder
- */
-
- bInfo.hwndOwner = hWnd;
- bInfo.pszDisplayName = path;
- bInfo.pidlRoot = NULL;
- if (_tcslen(cdCBData.initDir) == 0) {
- GetCurrentDirectory(MAX_PATH, cdCBData.initDir);
- }
- bInfo.lParam = (LPARAM) &cdCBData;
-
- if (ofnOpts.titleObj != NULL) {
- Tcl_WinUtfToTChar(Tcl_GetString(ofnOpts.titleObj), -1, &titleString);
- bInfo.lpszTitle = (LPTSTR) Tcl_DStringValue(&titleString);
- } else {
- bInfo.lpszTitle = TEXT("Please choose a directory, then select OK.");
- }
-
- /*
- * Set flags to add edit box, status text line and use the new ui. Allow
- * override with magic variable (ignore errors in retrieval). See
- * http://msdn.microsoft.com/en-us/library/bb773205(VS.85).aspx for
- * possible flag values.
- */
-
- bInfo.ulFlags = BIF_EDITBOX | BIF_STATUSTEXT | BIF_RETURNFSANCESTORS
- | BIF_VALIDATE | BIF_NEWDIALOGSTYLE;
- objPtr = Tcl_GetVar2Ex(interp, "::tk::winChooseDirFlags", NULL,
- TCL_GLOBAL_ONLY);
- if (objPtr != NULL) {
- int flags;
- Tcl_GetIntFromObj(NULL, objPtr, &flags);
- bInfo.ulFlags = flags;
- }
-
- /*
- * Callback to handle events
- */
-
- bInfo.lpfn = (BFFCALLBACK) ChooseDirectoryValidateProc;
-
- /*
- * Display dialog in background and process result. We look to give the
- * user a chance to change their mind on an invalid folder if mustexist is
- * 0.
- */
-
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
- GetCurrentDirectory(MAX_PATH, saveDir);
- if (SHGetMalloc(&pMalloc) == NOERROR) {
- /*
- * XXX - MSDN says CoInitialize must have been called before
- * SHBrowseForFolder can be used but don't see that called anywhere.
- */
- pidl = SHBrowseForFolder(&bInfo);
-
- /*
- * This is a fix for Windows 2000, which seems to modify the folder
- * name buffer even when the dialog is canceled (in this case the
- * buffer contains garbage). See [Bug #3002230]
- */
-
- path[0] = '\0';
-
- /*
- * Null for cancel button or invalid dir, otherwise valid.
- */
-
- if (pidl != NULL) {
- if (!SHGetPathFromIDList(pidl, path)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "error: not a file system folder", -1));
- Tcl_SetErrorCode(interp, "TK", "DIRDIALOG", "PSEUDO", NULL);
- }
- pMalloc->lpVtbl->Free(pMalloc, (void *) pidl);
- } else if (_tcslen(cdCBData.retDir) > 0) {
- _tcscpy(path, cdCBData.retDir);
- }
- pMalloc->lpVtbl->Release(pMalloc);
- }
- SetCurrentDirectory(saveDir);
- Tcl_SetServiceMode(oldMode);
-
- /*
- * Ensure that hWnd is enabled, because it can happen that we have updated
- * the wrapper of the parent, which causes us to leave this child disabled
- * (Windows loses sync).
- */
-
- EnableWindow(hWnd, 1);
-
- /*
- * Change the pathname to the Tcl "normalized" pathname, where back
- * slashes are used instead of forward slashes
- */
-
- Tcl_ResetResult(interp);
- if (*path) {
- Tcl_DString ds;
-
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- ConvertExternalFilename(path, &ds), -1));
- Tcl_DStringFree(&ds);
- }
-
- CleanupOFNOptions(&ofnOpts);
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ChooseDirectoryValidateProc --
- *
- * Hook function called by the explorer ChooseDirectory dialog when
- * events occur. It is used to validate the text entry the user may have
- * entered.
- *
- * Results:
- * Returns 0 to allow default processing of message, or 1 to tell default
- * dialog function not to close.
- *
- *----------------------------------------------------------------------
- */
-
-static UINT APIENTRY
-ChooseDirectoryValidateProc(
- HWND hwnd,
- UINT message,
- LPARAM lParam,
- LPARAM lpData)
-{
- TCHAR selDir[MAX_PATH];
- ChooseDir *chooseDirSharedData = (ChooseDir *) lpData;
- Tcl_DString tempString;
- Tcl_DString initDirString;
- TCHAR string[MAX_PATH];
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- if (tsdPtr->debugFlag) {
- tsdPtr->debugInterp = (Tcl_Interp *) chooseDirSharedData->interp;
- Tcl_DoWhenIdle(SetTkDialog, hwnd);
- }
- chooseDirSharedData->retDir[0] = '\0';
- switch (message) {
- case BFFM_VALIDATEFAILED:
- /*
- * First save and check to see if it is a valid path name, if so then
- * make that path the one shown in the window. Otherwise, it failed
- * the check and should be treated as such. Use
- * Set/GetCurrentDirectory which allows relative path names and names
- * with forward slashes. Use Tcl_TranslateFileName to make sure names
- * like ~ are converted correctly.
- */
-
- Tcl_WinTCharToUtf((TCHAR *) lParam, -1, &initDirString);
- if (Tcl_TranslateFileName(chooseDirSharedData->interp,
- Tcl_DStringValue(&initDirString), &tempString) == NULL) {
- /*
- * Should we expose the error (in the interp result) to the user
- * at this point?
- */
-
- chooseDirSharedData->retDir[0] = '\0';
- return 1;
- }
- Tcl_DStringFree(&initDirString);
- Tcl_WinUtfToTChar(Tcl_DStringValue(&tempString), -1, &initDirString);
- Tcl_DStringFree(&tempString);
- _tcsncpy(string, (TCHAR *) Tcl_DStringValue(&initDirString),
- MAX_PATH);
- Tcl_DStringFree(&initDirString);
-
- if (SetCurrentDirectory(string) == 0) {
-
- /*
- * Get the full path name to the user entry, at this point it does
- * not exist so see if it is supposed to. Otherwise just return
- * it.
- */
-
- GetFullPathName(string, MAX_PATH,
- chooseDirSharedData->retDir, NULL);
- if (chooseDirSharedData->mustExist) {
- /*
- * User HAS to select a valid directory.
- */
-
- wsprintf(selDir, TEXT("Directory '%s' does not exist,\n")
- TEXT("please select or enter an existing directory."),
- chooseDirSharedData->retDir);
- MessageBox(NULL, selDir, NULL, MB_ICONEXCLAMATION|MB_OK);
- chooseDirSharedData->retDir[0] = '\0';
- return 1;
- }
- } else {
- /*
- * Changed to new folder OK, return immediatly with the current
- * directory in utfRetDir.
- */
-
- GetCurrentDirectory(MAX_PATH, chooseDirSharedData->retDir);
- return 0;
- }
- return 0;
-
- case BFFM_SELCHANGED:
- /*
- * Set the status window to the currently selected path and enable the
- * OK button if a file system folder, otherwise disable the OK button
- * for things like server names. Perhaps a new switch
- * -enablenonfolders can be used to allow non folders to be selected.
- *
- * Not called when user changes edit box directly.
- */
-
- if (SHGetPathFromIDList((LPITEMIDLIST) lParam, selDir)) {
- SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, (LPARAM) selDir);
- // enable the OK button
- SendMessage(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 1);
- } else {
- // disable the OK button
- SendMessage(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 0);
- }
- UpdateWindow(hwnd);
- return 1;
-
- case BFFM_INITIALIZED: {
- /*
- * Directory browser intializing - tell it where to start from, user
- * specified parameter.
- */
-
- TCHAR *initDir = chooseDirSharedData->initDir;
-
- SetCurrentDirectory(initDir);
-
- if (*initDir == '\\') {
- /*
- * BFFM_SETSELECTION only understands UNC paths as pidls, so
- * convert path to pidl using IShellFolder interface.
- */
-
- LPMALLOC pMalloc;
- LPSHELLFOLDER psfFolder;
-
- if (SUCCEEDED(SHGetMalloc(&pMalloc))) {
- if (SUCCEEDED(SHGetDesktopFolder(&psfFolder))) {
- LPITEMIDLIST pidlMain;
- ULONG ulCount, ulAttr;
-
- if (SUCCEEDED(psfFolder->lpVtbl->ParseDisplayName(
- psfFolder, hwnd, NULL, (TCHAR *)
- initDir, &ulCount,&pidlMain,&ulAttr))
- && (pidlMain != NULL)) {
- SendMessage(hwnd, BFFM_SETSELECTION, FALSE,
- (LPARAM) pidlMain);
- pMalloc->lpVtbl->Free(pMalloc, pidlMain);
- }
- psfFolder->lpVtbl->Release(psfFolder);
- }
- pMalloc->lpVtbl->Release(pMalloc);
- }
- } else {
- SendMessage(hwnd, BFFM_SETSELECTION, TRUE, (LPARAM) initDir);
- }
- SendMessage(hwnd, BFFM_ENABLEOK, 0, (LPARAM) 1);
- break;
- }
-
- }
- return 0;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tk_MessageBoxObjCmd --
- *
- * This function implements the MessageBox window for the Windows
- * platform. See the user documentation for details on what it does.
- *
- * Results:
- * See user documentation.
- *
- * Side effects:
- * None. The MessageBox window will be destroy before this function
- * returns.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tk_MessageBoxObjCmd(
- ClientData clientData, /* Main window associated with interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- Tk_Window tkwin = clientData, parent;
- HWND hWnd;
- Tcl_Obj *messageObj, *titleObj, *detailObj, *tmpObj;
- int defaultBtn, icon, type;
- int i, oldMode, winCode;
- UINT flags;
- static const char *const optionStrings[] = {
- "-default", "-detail", "-icon", "-message",
- "-parent", "-title", "-type", NULL
- };
- enum options {
- MSG_DEFAULT, MSG_DETAIL, MSG_ICON, MSG_MESSAGE,
- MSG_PARENT, MSG_TITLE, MSG_TYPE
- };
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- defaultBtn = -1;
- detailObj = NULL;
- icon = MB_ICONINFORMATION;
- messageObj = NULL;
- parent = tkwin;
- titleObj = NULL;
- type = MB_OK;
-
- for (i = 1; i < objc; i += 2) {
- int index;
- Tcl_Obj *optionPtr, *valuePtr;
-
- optionPtr = objv[i];
- valuePtr = objv[i + 1];
-
- if (Tcl_GetIndexFromObjStruct(interp, optionPtr, optionStrings,
- sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if (i + 1 == objc) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "value for \"%s\" missing", Tcl_GetString(optionPtr)));
- Tcl_SetErrorCode(interp, "TK", "MSGBOX", "VALUE", NULL);
- return TCL_ERROR;
- }
-
- switch ((enum options) index) {
- case MSG_DEFAULT:
- defaultBtn = TkFindStateNumObj(interp, optionPtr, buttonMap,
- valuePtr);
- if (defaultBtn < 0) {
- return TCL_ERROR;
- }
- break;
-
- case MSG_DETAIL:
- detailObj = valuePtr;
- break;
-
- case MSG_ICON:
- icon = TkFindStateNumObj(interp, optionPtr, iconMap, valuePtr);
- if (icon < 0) {
- return TCL_ERROR;
- }
- break;
-
- case MSG_MESSAGE:
- messageObj = valuePtr;
- break;
-
- case MSG_PARENT:
- parent = Tk_NameToWindow(interp, Tcl_GetString(valuePtr), tkwin);
- if (parent == NULL) {
- return TCL_ERROR;
- }
- break;
-
- case MSG_TITLE:
- titleObj = valuePtr;
- break;
-
- case MSG_TYPE:
- type = TkFindStateNumObj(interp, optionPtr, typeMap, valuePtr);
- if (type < 0) {
- return TCL_ERROR;
- }
- break;
- }
- }
-
- while (!Tk_IsTopLevel(parent)) {
- parent = Tk_Parent(parent);
- }
- Tk_MakeWindowExist(parent);
- hWnd = Tk_GetHWND(Tk_WindowId(parent));
-
- flags = 0;
- if (defaultBtn >= 0) {
- int defaultBtnIdx = -1;
-
- for (i = 0; i < (int) NUM_TYPES; i++) {
- if (type == allowedTypes[i].type) {
- int j;
-
- for (j = 0; j < 3; j++) {
- if (allowedTypes[i].btnIds[j] == defaultBtn) {
- defaultBtnIdx = j;
- break;
- }
- }
- if (defaultBtnIdx < 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "invalid default button \"%s\"",
- TkFindStateString(buttonMap, defaultBtn)));
- Tcl_SetErrorCode(interp, "TK", "MSGBOX", "DEFAULT", NULL);
- return TCL_ERROR;
- }
- break;
- }
- }
- flags = buttonFlagMap[defaultBtnIdx];
- }
-
- flags |= icon | type | MB_TASKMODAL | MB_SETFOREGROUND;
-
- tmpObj = messageObj ? Tcl_DuplicateObj(messageObj)
- : Tcl_NewUnicodeObj(NULL, 0);
- Tcl_IncrRefCount(tmpObj);
- if (detailObj) {
- Tcl_AppendUnicodeToObj(tmpObj, L"\n\n", 2);
- Tcl_AppendObjToObj(tmpObj, detailObj);
- }
-
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
-
- /*
- * MessageBoxW exists for all platforms. Use it to allow unicode error
- * message to be displayed correctly where possible by the OS.
- *
- * In order to have the parent window icon reflected in a MessageBox, we
- * have to create a hook that will trigger when the MessageBox is being
- * created.
- */
-
- tsdPtr->hSmallIcon = TkWinGetIcon(parent, ICON_SMALL);
- tsdPtr->hBigIcon = TkWinGetIcon(parent, ICON_BIG);
- tsdPtr->hMsgBoxHook = SetWindowsHookEx(WH_CBT, MsgBoxCBTProc, NULL,
- GetCurrentThreadId());
- winCode = MessageBox(hWnd, Tcl_GetUnicode(tmpObj),
- titleObj ? Tcl_GetUnicode(titleObj) : L"", flags);
- UnhookWindowsHookEx(tsdPtr->hMsgBoxHook);
- (void) Tcl_SetServiceMode(oldMode);
-
- /*
- * Ensure that hWnd is enabled, because it can happen that we have updated
- * the wrapper of the parent, which causes us to leave this child disabled
- * (Windows loses sync).
- */
-
- EnableWindow(hWnd, 1);
-
- Tcl_DecrRefCount(tmpObj);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- TkFindStateString(buttonMap, winCode), -1));
- return TCL_OK;
-}
-\f
-static LRESULT CALLBACK
-MsgBoxCBTProc(
- int nCode,
- WPARAM wParam,
- LPARAM lParam)
-{
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- if (nCode == HCBT_CREATEWND) {
- /*
- * Window owned by our task is being created. Since the hook is
- * installed just before the MessageBox call and removed after the
- * MessageBox call, the window being created is either the message box
- * or one of its controls. Check that the class is WC_DIALOG to ensure
- * that it's the one we want.
- */
-
- LPCBT_CREATEWND lpcbtcreate = (LPCBT_CREATEWND) lParam;
-
- if (WC_DIALOG == lpcbtcreate->lpcs->lpszClass) {
- HWND hwnd = (HWND) wParam;
-
- SendMessage(hwnd, WM_SETICON, ICON_SMALL,
- (LPARAM) tsdPtr->hSmallIcon);
- SendMessage(hwnd, WM_SETICON, ICON_BIG, (LPARAM) tsdPtr->hBigIcon);
- }
- }
-
- /*
- * Call the next hook proc, if there is one
- */
-
- return CallNextHookEx(tsdPtr->hMsgBoxHook, nCode, wParam, lParam);
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * SetTkDialog --
- *
- * Records the HWND for a native dialog in the 'tk_dialog' variable so
- * that the test-suite can operate on the correct dialog window. Use of
- * this is enabled when a test program calls TkWinDialogDebug by calling
- * the test command 'tkwinevent debug 1'.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-SetTkDialog(
- ClientData clientData)
-{
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- char buf[32];
-
- sprintf(buf, "0x%p", (HWND) clientData);
- Tcl_SetVar2(tsdPtr->debugInterp, "tk_dialog", NULL, buf, TCL_GLOBAL_ONLY);
-}
-\f
-/*
- * Factored out a common pattern in use in this file.
- */
-
-static const char *
-ConvertExternalFilename(
- TCHAR *filename,
- Tcl_DString *dsPtr)
-{
- char *p;
-
- Tcl_WinTCharToUtf(filename, -1, dsPtr);
- for (p = Tcl_DStringValue(dsPtr); *p != '\0'; p++) {
- /*
- * Change the pathname to the Tcl "normalized" pathname, where back
- * slashes are used instead of forward slashes
- */
-
- if (*p == '\\') {
- *p = '/';
- }
- }
- return Tcl_DStringValue(dsPtr);
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * GetFontObj --
- *
- * Convert a windows LOGFONT into a Tk font description.
- *
- * Result:
- * A list containing a Tk font description.
- *
- * ----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-GetFontObj(
- HDC hdc,
- LOGFONT *plf)
-{
- Tcl_DString ds;
- Tcl_Obj *resObj;
- int pt = 0;
-
- resObj = Tcl_NewListObj(0, NULL);
- Tcl_WinTCharToUtf(plf->lfFaceName, -1, &ds);
- Tcl_ListObjAppendElement(NULL, resObj,
- Tcl_NewStringObj(Tcl_DStringValue(&ds), -1));
- Tcl_DStringFree(&ds);
- pt = -MulDiv(plf->lfHeight, 72, GetDeviceCaps(hdc, LOGPIXELSY));
- Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewIntObj(pt));
- if (plf->lfWeight >= 700) {
- Tcl_ListObjAppendElement(NULL, resObj, Tcl_NewStringObj("bold", -1));
- }
- if (plf->lfItalic) {
- Tcl_ListObjAppendElement(NULL, resObj,
- Tcl_NewStringObj("italic", -1));
- }
- if (plf->lfUnderline) {
- Tcl_ListObjAppendElement(NULL, resObj,
- Tcl_NewStringObj("underline", -1));
- }
- if (plf->lfStrikeOut) {
- Tcl_ListObjAppendElement(NULL, resObj,
- Tcl_NewStringObj("overstrike", -1));
- }
- return resObj;
-}
-\f
-static void
-ApplyLogfont(
- Tcl_Interp *interp,
- Tcl_Obj *cmdObj,
- HDC hdc,
- LOGFONT *logfontPtr)
-{
- int objc;
- Tcl_Obj **objv, **tmpv;
-
- Tcl_ListObjGetElements(NULL, cmdObj, &objc, &objv);
- tmpv = ckalloc(sizeof(Tcl_Obj *) * (objc + 2));
- memcpy(tmpv, objv, sizeof(Tcl_Obj *) * objc);
- tmpv[objc] = GetFontObj(hdc, logfontPtr);
- TkBackgroundEvalObjv(interp, objc+1, tmpv, TCL_EVAL_GLOBAL);
- ckfree(tmpv);
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * HookProc --
- *
- * Font selection hook. If the user selects Apply on the dialog, we call
- * the applyProc script with the currently selected font as arguments.
- *
- * ----------------------------------------------------------------------
- */
-
-typedef struct HookData {
- Tcl_Interp *interp;
- Tcl_Obj *titleObj;
- Tcl_Obj *cmdObj;
- Tcl_Obj *parentObj;
- Tcl_Obj *fontObj;
- HWND hwnd;
- Tk_Window parent;
-} HookData;
-
-static UINT_PTR CALLBACK
-HookProc(
- HWND hwndDlg,
- UINT msg,
- WPARAM wParam,
- LPARAM lParam)
-{
- CHOOSEFONT *pcf = (CHOOSEFONT *) lParam;
- HWND hwndCtrl;
- static HookData *phd = NULL;
- ThreadSpecificData *tsdPtr =
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
-
- if (WM_INITDIALOG == msg && lParam != 0) {
- phd = (HookData *) pcf->lCustData;
- phd->hwnd = hwndDlg;
- if (tsdPtr->debugFlag) {
- tsdPtr->debugInterp = phd->interp;
- Tcl_DoWhenIdle(SetTkDialog, hwndDlg);
- }
- if (phd->titleObj != NULL) {
- Tcl_DString title;
-
- Tcl_WinUtfToTChar(Tcl_GetString(phd->titleObj), -1, &title);
- if (Tcl_DStringLength(&title) > 0) {
- SetWindowText(hwndDlg, (LPCTSTR) Tcl_DStringValue(&title));
- }
- Tcl_DStringFree(&title);
- }
-
- /*
- * Disable the colour combobox (0x473) and its label (0x443).
- */
-
- hwndCtrl = GetDlgItem(hwndDlg, 0x443);
- if (IsWindow(hwndCtrl)) {
- EnableWindow(hwndCtrl, FALSE);
- }
- hwndCtrl = GetDlgItem(hwndDlg, 0x473);
- if (IsWindow(hwndCtrl)) {
- EnableWindow(hwndCtrl, FALSE);
- }
- TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
- return 1; /* we handled the message */
- }
-
- if (WM_DESTROY == msg) {
- phd->hwnd = NULL;
- TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility");
- return 0;
- }
-
- /*
- * Handle apply button by calling the provided command script as a
- * background evaluation (ie: errors dont come back here).
- */
-
- if (WM_COMMAND == msg && LOWORD(wParam) == 1026) {
- LOGFONT lf = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, {0, 0}};
- HDC hdc = GetDC(hwndDlg);
-
- SendMessage(hwndDlg, WM_CHOOSEFONT_GETLOGFONT, 0, (LPARAM) &lf);
- if (phd && phd->cmdObj) {
- ApplyLogfont(phd->interp, phd->cmdObj, hdc, &lf);
- }
- if (phd && phd->parent) {
- TkSendVirtualEvent(phd->parent, "TkFontchooserFontChanged");
- }
- return 1;
- }
- return 0; /* pass on for default processing */
-}
-\f
-/*
- * Helper for the FontchooserConfigure command to return the current value of
- * any of the options (which may be NULL in the structure)
- */
-
-enum FontchooserOption {
- FontchooserParent, FontchooserTitle, FontchooserFont, FontchooserCmd,
- FontchooserVisible
-};
-
-static Tcl_Obj *
-FontchooserCget(
- HookData *hdPtr,
- int optionIndex)
-{
- Tcl_Obj *resObj = NULL;
-
- switch(optionIndex) {
- case FontchooserParent:
- if (hdPtr->parentObj) {
- resObj = hdPtr->parentObj;
- } else {
- resObj = Tcl_NewStringObj(".", 1);
- }
- break;
- case FontchooserTitle:
- if (hdPtr->titleObj) {
- resObj = hdPtr->titleObj;
- } else {
- resObj = Tcl_NewStringObj("", 0);
- }
- break;
- case FontchooserFont:
- if (hdPtr->fontObj) {
- resObj = hdPtr->fontObj;
- } else {
- resObj = Tcl_NewStringObj("", 0);
- }
- break;
- case FontchooserCmd:
- if (hdPtr->cmdObj) {
- resObj = hdPtr->cmdObj;
- } else {
- resObj = Tcl_NewStringObj("", 0);
- }
- break;
- case FontchooserVisible:
- resObj = Tcl_NewBooleanObj(hdPtr->hwnd && IsWindow(hdPtr->hwnd));
- break;
- default:
- resObj = Tcl_NewStringObj("", 0);
- }
- return resObj;
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * FontchooserConfigureCmd --
- *
- * Implementation of the 'tk fontchooser configure' ensemble command. See
- * the user documentation for what it does.
- *
- * Results:
- * See the user documentation.
- *
- * Side effects:
- * Per-interp data structure may be modified
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-FontchooserConfigureCmd(
- ClientData clientData, /* Main window */
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tk_Window tkwin = clientData;
- HookData *hdPtr = NULL;
- int i, r = TCL_OK;
- static const char *const optionStrings[] = {
- "-parent", "-title", "-font", "-command", "-visible", NULL
- };
-
- hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
-
- /*
- * With no arguments we return all the options in a dict.
- */
-
- if (objc == 1) {
- Tcl_Obj *keyObj, *valueObj;
- Tcl_Obj *dictObj = Tcl_NewDictObj();
-
- for (i = 0; r == TCL_OK && optionStrings[i] != NULL; ++i) {
- keyObj = Tcl_NewStringObj(optionStrings[i], -1);
- valueObj = FontchooserCget(hdPtr, i);
- r = Tcl_DictObjPut(interp, dictObj, keyObj, valueObj);
- }
- if (r == TCL_OK) {
- Tcl_SetObjResult(interp, dictObj);
- }
- return r;
- }
-
- for (i = 1; i < objc; i += 2) {
- int optionIndex;
-
- if (Tcl_GetIndexFromObjStruct(interp, objv[i], optionStrings,
- sizeof(char *), "option", 0, &optionIndex) != TCL_OK) {
- return TCL_ERROR;
- }
- if (objc == 2) {
- /*
- * If one option and no arg - return the current value.
- */
-
- Tcl_SetObjResult(interp, FontchooserCget(hdPtr, optionIndex));
- return TCL_OK;
- }
- if (i + 1 == objc) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "value for \"%s\" missing", Tcl_GetString(objv[i])));
- Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "VALUE", NULL);
- return TCL_ERROR;
- }
- switch (optionIndex) {
- case FontchooserVisible: {
- static const char *msg = "cannot change read-only option "
- "\"-visible\": use the show or hide command";
-
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
- Tcl_SetErrorCode(interp, "TK", "FONTDIALOG", "READONLY", NULL);
- return TCL_ERROR;
- }
- case FontchooserParent: {
- Tk_Window parent = Tk_NameToWindow(interp,
- Tcl_GetString(objv[i+1]), tkwin);
-
- if (parent == None) {
- return TCL_ERROR;
- }
- if (hdPtr->parentObj) {
- Tcl_DecrRefCount(hdPtr->parentObj);
- }
- hdPtr->parentObj = objv[i+1];
- if (Tcl_IsShared(hdPtr->parentObj)) {
- hdPtr->parentObj = Tcl_DuplicateObj(hdPtr->parentObj);
- }
- Tcl_IncrRefCount(hdPtr->parentObj);
- break;
- }
- case FontchooserTitle:
- if (hdPtr->titleObj) {
- Tcl_DecrRefCount(hdPtr->titleObj);
- }
- hdPtr->titleObj = objv[i+1];
- if (Tcl_IsShared(hdPtr->titleObj)) {
- hdPtr->titleObj = Tcl_DuplicateObj(hdPtr->titleObj);
- }
- Tcl_IncrRefCount(hdPtr->titleObj);
- break;
- case FontchooserFont:
- if (hdPtr->fontObj) {
- Tcl_DecrRefCount(hdPtr->fontObj);
- }
- (void)Tcl_GetString(objv[i+1]);
- if (objv[i+1]->length) {
- hdPtr->fontObj = objv[i+1];
- if (Tcl_IsShared(hdPtr->fontObj)) {
- hdPtr->fontObj = Tcl_DuplicateObj(hdPtr->fontObj);
- }
- Tcl_IncrRefCount(hdPtr->fontObj);
- } else {
- hdPtr->fontObj = NULL;
- }
- break;
- case FontchooserCmd:
- if (hdPtr->cmdObj) {
- Tcl_DecrRefCount(hdPtr->cmdObj);
- }
- (void)Tcl_GetString(objv[i+1]);
- if (objv[i+1]->length) {
- hdPtr->cmdObj = objv[i+1];
- if (Tcl_IsShared(hdPtr->cmdObj)) {
- hdPtr->cmdObj = Tcl_DuplicateObj(hdPtr->cmdObj);
- }
- Tcl_IncrRefCount(hdPtr->cmdObj);
- } else {
- hdPtr->cmdObj = NULL;
- }
- break;
- }
- }
- return TCL_OK;
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * FontchooserShowCmd --
- *
- * Implements the 'tk fontchooser show' ensemble command. The per-interp
- * configuration data for the dialog is held in an interp associated
- * structure.
- *
- * Calls the Win32 FontChooser API which provides a modal dialog. See
- * HookProc where we make a few changes to the dialog and set some
- * additional state.
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-FontchooserShowCmd(
- ClientData clientData, /* Main window */
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_DString ds;
- Tk_Window tkwin = clientData, parent;
- CHOOSEFONT cf;
- LOGFONT lf;
- HDC hdc;
- HookData *hdPtr;
- int r = TCL_OK, oldMode = 0;
-
- hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
-
- parent = tkwin;
- if (hdPtr->parentObj) {
- parent = Tk_NameToWindow(interp, Tcl_GetString(hdPtr->parentObj),
- tkwin);
- if (parent == None) {
- return TCL_ERROR;
- }
- }
-
- Tk_MakeWindowExist(parent);
-
- ZeroMemory(&cf, sizeof(CHOOSEFONT));
- ZeroMemory(&lf, sizeof(LOGFONT));
- lf.lfCharSet = DEFAULT_CHARSET;
- cf.lStructSize = sizeof(CHOOSEFONT);
- cf.hwndOwner = Tk_GetHWND(Tk_WindowId(parent));
- cf.lpLogFont = &lf;
- cf.nFontType = SCREEN_FONTTYPE;
- cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_ENABLEHOOK;
- cf.rgbColors = RGB(0,0,0);
- cf.lpfnHook = HookProc;
- cf.lCustData = (INT_PTR) hdPtr;
- hdPtr->interp = interp;
- hdPtr->parent = parent;
- hdc = GetDC(cf.hwndOwner);
-
- if (hdPtr->fontObj != NULL) {
- TkFont *fontPtr;
- Tk_Font f = Tk_AllocFontFromObj(interp, tkwin, hdPtr->fontObj);
-
- if (f == NULL) {
- return TCL_ERROR;
- }
- fontPtr = (TkFont *) f;
- cf.Flags |= CF_INITTOLOGFONTSTRUCT;
- Tcl_WinUtfToTChar(fontPtr->fa.family, -1, &ds);
- _tcsncpy(lf.lfFaceName, (TCHAR *)Tcl_DStringValue(&ds),
- LF_FACESIZE-1);
- Tcl_DStringFree(&ds);
- lf.lfFaceName[LF_FACESIZE-1] = 0;
- lf.lfHeight = -MulDiv(TkFontGetPoints(tkwin, fontPtr->fa.size),
- GetDeviceCaps(hdc, LOGPIXELSY), 72);
- if (fontPtr->fa.weight == TK_FW_BOLD) {
- lf.lfWeight = FW_BOLD;
- }
- if (fontPtr->fa.slant != TK_FS_ROMAN) {
- lf.lfItalic = TRUE;
- }
- if (fontPtr->fa.underline) {
- lf.lfUnderline = TRUE;
- }
- if (fontPtr->fa.overstrike) {
- lf.lfStrikeOut = TRUE;
- }
- Tk_FreeFont(f);
- }
-
- if (TCL_OK == r && hdPtr->cmdObj != NULL) {
- int len = 0;
-
- r = Tcl_ListObjLength(interp, hdPtr->cmdObj, &len);
- if (len > 0) {
- cf.Flags |= CF_APPLY;
- }
- }
-
- if (TCL_OK == r) {
- oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
- if (ChooseFont(&cf)) {
- if (hdPtr->cmdObj) {
- ApplyLogfont(hdPtr->interp, hdPtr->cmdObj, hdc, &lf);
- }
- if (hdPtr->parent) {
- TkSendVirtualEvent(hdPtr->parent, "TkFontchooserFontChanged");
- }
- }
- Tcl_SetServiceMode(oldMode);
- EnableWindow(cf.hwndOwner, 1);
- }
-
- ReleaseDC(cf.hwndOwner, hdc);
- return r;
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * FontchooserHideCmd --
- *
- * Implementation of the 'tk fontchooser hide' ensemble. See the user
- * documentation for details.
- * As the Win32 FontChooser function is always modal all we do here is
- * destroy the dialog
- *
- * ----------------------------------------------------------------------
- */
-
-static int
-FontchooserHideCmd(
- ClientData clientData, /* Main window */
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- HookData *hdPtr = Tcl_GetAssocData(interp, "::tk::fontchooser", NULL);
-
- if (hdPtr->hwnd && IsWindow(hdPtr->hwnd)) {
- EndDialog(hdPtr->hwnd, 0);
- }
- return TCL_OK;
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * DeleteHookData --
- *
- * Clean up the font chooser configuration data when the interp is
- * destroyed.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-DeleteHookData(ClientData clientData, Tcl_Interp *interp)
-{
- HookData *hdPtr = clientData;
-
- if (hdPtr->parentObj) {
- Tcl_DecrRefCount(hdPtr->parentObj);
- }
- if (hdPtr->fontObj) {
- Tcl_DecrRefCount(hdPtr->fontObj);
- }
- if (hdPtr->titleObj) {
- Tcl_DecrRefCount(hdPtr->titleObj);
- }
- if (hdPtr->cmdObj) {
- Tcl_DecrRefCount(hdPtr->cmdObj);
- }
- ckfree(hdPtr);
-}
-\f
-/*
- * ----------------------------------------------------------------------
- *
- * TkInitFontchooser --
- *
- * Associate the font chooser configuration data with the Tcl
- * interpreter. There is one font chooser per interp.
- *
- * ----------------------------------------------------------------------
- */
-
-MODULE_SCOPE const TkEnsemble tkFontchooserEnsemble[];
-const TkEnsemble tkFontchooserEnsemble[] = {
- { "configure", FontchooserConfigureCmd, NULL },
- { "show", FontchooserShowCmd, NULL },
- { "hide", FontchooserHideCmd, NULL },
- { NULL, NULL, NULL }
-};
-
-int
-TkInitFontchooser(Tcl_Interp *interp, ClientData clientData)
-{
- HookData *hdPtr = ckalloc(sizeof(HookData));
-
- memset(hdPtr, 0, sizeof(HookData));
- Tcl_SetAssocData(interp, "::tk::fontchooser", DeleteHookData, hdPtr);
- return TCL_OK;
-}
-\f
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
OSDN Git Service
