/*
 * 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 */

#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;


/*
 *-------------------------------------------------------------------------
 *
 * 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");
}


/*
 *-------------------------------------------------------------------------
 *
 * 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 flush all mouse events
 *      for 1/4 second. In 8.6.5 and earlier, the code used to
 *      poll the message queue consuming WM_LBUTTONUP messages.
 * 	On seeing a WM_LBUTTONDOWN message, it would exit early, since the user
 * 	must be doing something new. However this early exit does not work
 *      on Vista and later because the Windows sends both BUTTONDOWN and
 *      BUTTONUP after the DBLCLICK instead of just BUTTONUP as on XP.
 *      Rather than try and figure out version specific sequences, we
 *      ignore all mouse events in that interval.
 *
 *      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 unwanted mouse related messages.
 *
 *-------------------------------------------------------------------------
 */

static void
EatSpuriousMessageBugFix(void)
{
    MSG msg;
    DWORD nTime = GetTickCount() + 250;

    while (GetTickCount() < nTime) {
	PeekMessage(&msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE);
    }
}

/*
 *-------------------------------------------------------------------------
 *
 * 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;
}

/*
 *-------------------------------------------------------------------------
 *
 * 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;
}

/*
 *-------------------------------------------------------------------------
 *
 * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
}



/*
 *----------------------------------------------------------------------
 *
 * 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;

	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 (i + 1 == objc) {
                Tcl_SetObjResult(interp, Tcl_NewStringObj("value for \"-xpstyle\" missing", -1));
                Tcl_SetErrorCode(interp, "TK", "FILEDIALOG", "VALUE", NULL);
                goto error_return;
            }
	    if (Tcl_GetBooleanFromObj(interp, objv[i+1],
                                      &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;
	}

        valuePtr = objv[i + 1];
	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;

}


/*
 *----------------------------------------------------------------------
 * 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);
}

/*
 *----------------------------------------------------------------------
 *
 * 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) {
	Tcl_Panic("Internal error: GetFileNameVista: IFileDialog API not available");
	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) {
        /*
         * Causes -filetypes {{All *}} -defaultextension ext to return
         * foo.ext.ext when foo is typed into the entry box
         *     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_Obj *normPath, *iniDirPath;
        iniDirPath = Tcl_NewStringObj(Tcl_DStringValue(&optsPtr->utfDirString), -1);
        Tcl_IncrRefCount(iniDirPath);
        normPath = Tcl_FSGetNormalizedPath(interp, iniDirPath);
        /* XXX - Note on failures do not raise error, simply ignore ini dir */
        if (normPath) {
            const WCHAR *nativePath;
            Tcl_IncrRefCount(normPath);
            nativePath = Tcl_FSGetNativePath(normPath); /* Points INTO normPath*/
            if (nativePath) {
                hr = ShellProcs.SHCreateItemFromParsingName(
                    nativePath, NULL,
                    &IIDIShellItem, (void **) &dirIf);
                if (SUCCEEDED(hr)) {
                    /* Note we use SetFolder, not SetDefaultFolder - see MSDN */
                    fdlgIf->lpVtbl->SetFolder(fdlgIf, dirIf); /* Ignore errors */
                }
            }
            Tcl_DecrRefCount(normPath); /* ALSO INVALIDATES nativePath !! */
        }
        Tcl_DecrRefCount(iniDirPath);
    }

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
    hr = fdlgIf->lpVtbl->Show(fdlgIf, hWnd);
    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).
     */

    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;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * 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;
}


/*
 *----------------------------------------------------------------------
 *
 * 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;
}


/*
 *-------------------------------------------------------------------------
 *
 * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
}


/*
 *----------------------------------------------------------------------
 *
 * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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;
}

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);
}

/*
 * ----------------------------------------------------------------------
 *
 * 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);
}

/*
 * 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);
}

/*
 * ----------------------------------------------------------------------
 *
 * 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;
}

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);
}

/*
 * ----------------------------------------------------------------------
 *
 * 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", NULL);
	return 1; /* we handled the message */
    }

    if (WM_DESTROY == msg) {
	phd->hwnd = NULL;
	TkSendVirtualEvent(phd->parent, "TkFontchooserVisibility", NULL);
	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", NULL);
	}
	return 1;
    }
    return 0; /* pass on for default processing */
}

/*
 * 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;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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", NULL);
	    }
	}
	Tcl_SetServiceMode(oldMode);
	EnableWindow(cf.hwndOwner, 1);
    }

    ReleaseDC(cf.hwndOwner, hdc);
    return r;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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;
}

/*
 * ----------------------------------------------------------------------
 *
 * 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);
}

/*
 * ----------------------------------------------------------------------
 *
 * 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;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
