From d36e3da8be2a9f15cb687f72217c953b207167cf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Oct 2010 19:43:28 -0600 Subject: [PATCH] win32: file dialog original commit: 7ffff49507231bad77715aecdfec51eb4b9ed2e4 --- collects/mred/private/wx/win32/dialog.rkt | 2 - collects/mred/private/wx/win32/filedialog.rkt | 225 ++++++++++++++++++ collects/mred/private/wx/win32/procs.rkt | 2 +- collects/mred/private/wx/win32/types.rkt | 19 +- collects/mred/private/wx/win32/utils.rkt | 3 + 5 files changed, 243 insertions(+), 8 deletions(-) create mode 100644 collects/mred/private/wx/win32/filedialog.rkt diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index 3a5537d6..b3e8a887 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -16,8 +16,6 @@ (provide dialog%) -(define _WORD _short) - (define-cstruct _DLGTEMPLATE ([style _DWORD] [dwExtendedStyle _DWORD] diff --git a/collects/mred/private/wx/win32/filedialog.rkt b/collects/mred/private/wx/win32/filedialog.rkt new file mode 100644 index 00000000..c49b225e --- /dev/null +++ b/collects/mred/private/wx/win32/filedialog.rkt @@ -0,0 +1,225 @@ +#lang racket/base +(require ffi/unsafe + racket/class + racket/string + "utils.rkt" + "types.rkt" + "const.rkt" + "wndclass.rkt" + "../../lock.rkt") + +(provide file-selector) + +(define-cstruct _OPENFILENAME + ([lStructSize _DWORD] + [hwndOwner _HWND] + [hInstance _HINSTANCE] + [lpstrFilter _permanent-string/utf-16] + [lpstrCustomFilter _permanent-string/utf-16] + [nMaxCustFilter _DWORD] + [nFilterIndex _DWORD] + [lpstrFile _pointer] + [nMaxFile _DWORD] + [lpstrFileTitle _pointer] + [nMaxFileTitle _DWORD] + [lpstrInitialDir _permanent-string/utf-16] + [lpstrTitle _permanent-string/utf-16] + [Flags _DWORD] + [nFileOffset _WORD] + [nFileExtension _WORD] + [lpstrDefExt _permanent-string/utf-16] + [lCustData _LPARAM] + [lpfnHook _fpointer] + [lpTemplateName _permanent-string/utf-16] + [pvReserved _pointer] + [dwReserved _DWORD] + [FlagsEx _DWORD])) + +(define-comdlg32 GetSaveFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) +(define-comdlg32 GetOpenFileNameW (_wfun _OPENFILENAME-pointer -> _BOOL)) + +(define OFN_READONLY #x00000001) +(define OFN_OVERWRITEPROMPT #x00000002) +(define OFN_HIDEREADONLY #x00000004) +(define OFN_NOCHANGEDIR #x00000008) +(define OFN_SHOWHELP #x00000010) +(define OFN_ENABLEHOOK #x00000020) +(define OFN_ENABLETEMPLATE #x00000040) +(define OFN_ENABLETEMPLATEHANDLE #x00000080) +(define OFN_ALLOWMULTISELECT #x00000200) +(define OFN_EXTENSIONDIFFERENT #x00000400) +(define OFN_PATHMUSTEXIST #x00000800) +(define OFN_FILEMUSTEXIST #x00001000) +(define OFN_NOREADONLYRETURN #x00008000) +(define OFN_EXPLORER #x00080000) + +(define BUFFER-LEN 4096) + +(define-cstruct _BROWSEINFO + ([hwndOwner _HWND] + [pidlRoot _pointer] + [pszDisplayName _pointer] + [lpszTitle _permanent-string/utf-16] + [ulFlags _UINT] + [lpfn _pointer] + [lParam _LPARAM] + [iImage _int])) + +(define BIF_RETURNONLYFSDIRS #x00000001) +(define BIF_NEWDIALOGSTYLE #x00000040) + +(define-cstruct _IUnknownVtbl + ([QueryInterface _fpointer] + [AddRef _fpointer] + [Release (_wfun _pointer -> _ULONG)])) + +(define-cstruct (_IMallocVtbl _IUnknownVtbl) + ([Alloc _fpointer] + [Realloc _fpointer] + [Free (_wfun _pointer _pointer -> _void)] + [GetSize _fpointer] + [DidAlloc _fpointer] + [HeapMinimize _fpointer])) + +(define-cstruct _IMalloc + ([vtbl _IMallocVtbl-pointer])) + +(define (IMalloc-Free im p) + ((IMallocVtbl-Free (IMalloc-vtbl im)) im p)) +(define (IMalloc-Release im) + ((IUnknownVtbl-Release (IMalloc-vtbl im)) im)) + +(define-shell32 SHBrowseForFolderW (_wfun _BROWSEINFO-pointer -> _pointer)) +(define-shell32 SHGetPathFromIDListW (_wfun _pointer _pointer -> _BOOL)) +(define-shell32 SHGetMalloc (_wfun (p : (_ptr o _IMalloc-pointer)) -> (r : _HRESULT) + -> (if (negative? r) + (error 'SHGetMalloc "failed: ~s" (bitwise-and #xFFFF r)) + p))) + +(define (file-selector message directory filename + extension + filters style parent) + (if (memq 'dir style) + (dialog-selector message directory + style parent) + (do-file-selector message directory filename + extension + filters style parent))) + +(define (do-file-selector message directory filename + extension + filters style parent) + (atomically + (let* ([pre-ofn + (make-OPENFILENAME + (ctype-sizeof _OPENFILENAME) + (and parent + (send parent get-hwnd)) + hInstance + (string-append + (string-join + (for/list ([f (in-list filters)]) + (format "~a\0~a" (car f) (cadr f))) + "\0") + "\0") + #f + 0 + 0 ; nFilterIndex + (malloc 'raw (* BUFFER-LEN (ctype-sizeof _short))) + BUFFER-LEN + #f + 0 + (and directory + (path->string (simplify-path directory #f))) + message + (bitwise-ior + OFN_HIDEREADONLY + (if (memq 'put style) OFN_OVERWRITEPROMPT 0) + (if (memq 'multi style) (bitwise-ior OFN_ALLOWMULTISELECT OFN_EXPLORER) 0) + (if directory OFN_NOCHANGEDIR 0)) + 0 + 0 + extension + 0 + #f + #f + #f + 0 + 0)] + [ofn (malloc 'raw (ctype-sizeof _OPENFILENAME))]) + (set-cpointer-tag! ofn OPENFILENAME-tag) + (memcpy ofn pre-ofn 1 _OPENFILENAME) + (if filename + (let* ([filename (path->string (simplify-path filename #f))] + [len (utf-16-length filename)]) + (memcpy (OPENFILENAME-lpstrFile ofn) + (cast filename _string/utf-16 _gcpointer) + (+ len 1) + _uint16)) + (ptr-set! (OPENFILENAME-lpstrFile ofn) _uint16 0)) + (let ([r (if (memq 'put style) + (GetSaveFileNameW ofn) + (GetOpenFileNameW ofn))]) + (begin0 + (and r + (if (memq 'multi style) + (let ([strs + (let ([p (OPENFILENAME-lpstrFile ofn)]) + (let loop ([pos 0]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + null] + [else (let ([end-pos + (let loop ([pos (+ pos 2)]) + (cond + [(and (zero? (ptr-ref p _byte pos)) + (zero? (ptr-ref p _byte (add1 pos)))) + pos] + [else (loop (+ pos 2))]))]) + (cons + (cast (ptr-add p pos) _pointer _string/utf-16) + (loop (+ end-pos 2))))])))]) + (if ((length strs) . < . 2) + #f + (map (lambda (p) (build-path (car strs) p)) + (cdr strs)))) + (cast (OPENFILENAME-lpstrFile ofn) _pointer _string/utf-16))) + (when directory + (free (OPENFILENAME-lpstrInitialDir ofn))) + (when message + (free (OPENFILENAME-lpstrTitle ofn))) + (free (OPENFILENAME-lpstrFilter ofn)) + (free (OPENFILENAME-lpstrFile ofn))))))) + +(define MAX_PATH 4096) + +(define (dialog-selector message directory + style parent) + (atomically + (let ([pre-bi (make-BROWSEINFO + (and parent + (send parent get-hwnd)) + #f + (malloc 'raw MAX_PATH _uint16) + message + (bitwise-ior BIF_NEWDIALOGSTYLE BIF_RETURNONLYFSDIRS) + #f + 0 + 0)] + [bi (malloc 'raw (ctype-sizeof _BROWSEINFO))]) + (set-cpointer-tag! bi BROWSEINFO-tag) + (memcpy bi pre-bi 1 _BROWSEINFO) + (let ([r (SHBrowseForFolderW bi)]) + (begin0 + (and r + (let ([ok (SHGetPathFromIDListW r (BROWSEINFO-pszDisplayName bi))]) + (and ok + (let ([mi (SHGetMalloc)]) + (IMalloc-Free mi r) + (IMalloc-Release mi)) + (string->path + (cast (BROWSEINFO-pszDisplayName bi) _pointer _string/utf-16))))) + (free (BROWSEINFO-pszDisplayName bi)) + (when message + (free (BROWSEINFO-lpszTitle bi)))))))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index e2a4e761..2efb432e 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -9,6 +9,7 @@ "menu-item.rkt" "frame.rkt" "dc.rkt" + "filedialog.rkt" racket/draw) (provide @@ -87,7 +88,6 @@ (define (get-display-depth) 32) (define-unimplemented is-color-display?) -(define-unimplemented file-selector) (define-unimplemented show-print-setup) (define (can-show-print-setup?) #f) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 4c3ccfd4..360e6719 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -3,6 +3,7 @@ (provide _wfun + _WORD _DWORD _UDWORD _ATOM @@ -14,6 +15,7 @@ _UINT_PTR _BYTE _LONG + _ULONG _SHORT _HRESULT _WCHAR @@ -35,6 +37,7 @@ _fnpointer _permanent-string/utf-16 + utf-16-length (struct-out POINT) _POINT _POINT-pointer (struct-out RECT) _RECT _RECT-pointer @@ -48,6 +51,7 @@ (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) +(define _WORD _int16) (define _DWORD _int32) (define _UDWORD _uint32) (define _ATOM _int) @@ -77,23 +81,28 @@ (define _fnpointer (_or-null _fpointer)) +(define (utf-16-length s) + (for/fold ([len 0]) ([c (in-string s)]) + (+ len + (if ((char->integer c) . > . #xFFFF) + 2 + 1)))) + (define _permanent-string/utf-16 (make-ctype _pointer (lambda (s) - (and s + (and s (let ([v (malloc _gcpointer)]) (ptr-set! v _string/utf-16 s) (let ([p (ptr-ref v _gcpointer)]) - (let ([len (let loop ([i 0]) - (if (zero? (ptr-ref p _uint16 i)) - (add1 i) - (loop (add1 i))))]) + (let ([len (+ 1 (utf-16-length s))]) (let ([c (malloc len _uint16 'raw)]) (memcpy c p len _uint16) c)))))) (lambda (p) p))) (define _LONG _long) +(define _ULONG _ulong) (define _SHORT _short) (define-cstruct _POINT ([x _LONG] diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 25d4cb81..afda3e75 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -9,6 +9,7 @@ define-user32 define-kernel32 define-comctl32 + define-comdlg32 define-shell32 define-uxtheme define-mz @@ -45,6 +46,7 @@ (define user32-lib (ffi-lib "user32.dll")) (define kernel32-lib (ffi-lib "kernel32.dll")) (define comctl32-lib (ffi-lib "comctl32.dll")) +(define comdlg32-lib (ffi-lib "comdlg32.dll")) (define shell32-lib (ffi-lib "shell32.dll")) (define uxtheme-lib (ffi-lib "uxtheme.dll")) @@ -52,6 +54,7 @@ (define-ffi-definer define-user32 user32-lib) (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) +(define-ffi-definer define-comdlg32 comdlg32-lib) (define-ffi-definer define-shell32 shell32-lib) (define-ffi-definer define-uxtheme uxtheme-lib)