win32: file dialog

original commit: 7ffff49507231bad77715aecdfec51eb4b9ed2e4

collects/mred/private/wx/win32/dialog.rkt

@@ -16,8 +16,6 @@
 
 (provide dialog%)
 
-(define _WORD _short)
-
 (define-cstruct _DLGTEMPLATE
   ([style _DWORD]
    [dwExtendedStyle _DWORD]

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))))))))

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)
 

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,6 +81,13 @@
 
 (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)
@@ -84,16 +95,14 @@
 		     (let ([v (malloc _gcpointer)])
 		       (ptr-set! v _string/utf-16 s)
 		       (let ([p (ptr-ref v _gcpointer)])
-			 (let ([len (let loop ([i 0])
+			 (let ([len (+ 1 (utf-16-length s))])
-				      (if (zero? (ptr-ref p _uint16 i))
-					  (add1 i)
-					  (loop (add1 i))))])
 			   (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]

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)