cocoa file dialog
original commit: 5117d094731e6fac7fb14d10e65fdcbae8d5f5a3
This commit is contained in:
Matthew Flatt
parent
ba7d6d7cc1
commit
22d6199bc1
|
|
@ -17,17 +17,6 @@
|
|||
put-file
|
||||
get-directory)
|
||||
|
||||
(define (files->list s)
|
||||
(let ([s (open-input-bytes s)])
|
||||
(let loop ()
|
||||
(let ([n (read s)])
|
||||
(if (eof-object? n)
|
||||
null
|
||||
(begin
|
||||
(read-byte s) ; drop space
|
||||
(cons (read-bytes n s)
|
||||
(loop))))))))
|
||||
|
||||
(define (mk-file-selector who put? multi? dir?)
|
||||
(lambda (message parent directory filename extension style filters)
|
||||
;; Calls from C++ have wrong kind of window:
|
||||
|
|
@ -52,9 +41,7 @@
|
|||
(raise-type-error who "list of 2-string lists" filters))
|
||||
(let* ([std? (memq 'common style)]
|
||||
[style (if std? (remq 'common style) style)])
|
||||
(if (or std?
|
||||
;; no Cocoa dialog, yet:
|
||||
(eq? (system-type) 'macosx))
|
||||
(if std?
|
||||
(send (new path-dialog%
|
||||
[put? put?]
|
||||
[dir? dir?]
|
||||
|
|
@ -68,25 +55,22 @@
|
|||
[dir? #f]
|
||||
[else filters])])
|
||||
run)
|
||||
(let ([s (wx:file-selector
|
||||
message directory filename extension
|
||||
;; file types:
|
||||
filters
|
||||
#;
|
||||
(apply string-append
|
||||
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
|
||||
filters))
|
||||
;; style:
|
||||
(cons (cond [dir? 'dir]
|
||||
[put? 'put]
|
||||
[multi? 'multi]
|
||||
[else 'get])
|
||||
style)
|
||||
;; parent:
|
||||
(and parent (mred->wx parent)))])
|
||||
(if (and multi? s)
|
||||
(map bytes->path (files->list (path->bytes s)))
|
||||
s))))))
|
||||
(wx:file-selector
|
||||
message directory filename extension
|
||||
;; file types:
|
||||
filters
|
||||
#;
|
||||
(apply string-append
|
||||
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
|
||||
filters))
|
||||
;; style:
|
||||
(cons (cond [dir? 'dir]
|
||||
[put? 'put]
|
||||
[multi? 'multi]
|
||||
[else 'get])
|
||||
style)
|
||||
;; parent:
|
||||
(and parent (mred->wx parent)))))))
|
||||
|
||||
(define default-filters '(("Any" "*.*")))
|
||||
|
||||
|
|
|
|||
95
collects/mred/private/wx/cocoa/filedialog.rkt
Normal file
95
collects/mred/private/wx/cocoa/filedialog.rkt
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/objc
|
||||
racket/class
|
||||
racket/path
|
||||
"../../lock.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt"
|
||||
"queue.rkt"
|
||||
"frame.rkt")
|
||||
|
||||
(provide file-selector)
|
||||
|
||||
(import-class NSOpenPanel NSSavePanel NSURL NSArray)
|
||||
|
||||
(define (nsurl->string url)
|
||||
(string->path (tell #:type _NSString url path)))
|
||||
|
||||
(define (file-selector message directory filename
|
||||
extension
|
||||
filters style parent)
|
||||
(let ([ns (if (memq 'put style)
|
||||
(tell NSSavePanel savePanel)
|
||||
(tell NSOpenPanel openPanel))]
|
||||
[parent (and parent
|
||||
(not (send parent get-sheet))
|
||||
parent)])
|
||||
;; Why? This looks like a leak, but we get crashes
|
||||
;; without it.
|
||||
(retain ns)
|
||||
|
||||
(let ([extensions (append
|
||||
(if extension (list extension) null)
|
||||
(if (memq 'packages style) (list "app") null)
|
||||
(for/list ([e (in-list filters)]
|
||||
#:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e))
|
||||
(not (equal? (cadr e) "*.*"))))
|
||||
(car (regexp-match #rx"[^.]+$" (cadr e)))))])
|
||||
(unless (null? extensions)
|
||||
(when (memq 'put style)
|
||||
(tellv ns setCanSelectHiddenExtension: #:type _BOOL #t))
|
||||
(let ([a (tell NSArray
|
||||
arrayWithObjects: #:type (_list i _NSString) extensions
|
||||
count: #:type _NSUInteger (length extensions))])
|
||||
(tellv ns setAllowedFileTypes: a))))
|
||||
(when (not (ormap (lambda (e)
|
||||
(equal? (cadr e) "*.*"))
|
||||
filters))
|
||||
(tellv ns setAllowsOtherFileTypes: #:type _BOOL #f))
|
||||
|
||||
(cond
|
||||
[(memq 'multi style)
|
||||
(tellv ns setAllowsMultipleSelection: #:type _BOOL #t)]
|
||||
[(memq 'dir style)
|
||||
(tellv ns setCanChooseDirectories: #:type _BOOL #t)
|
||||
(tellv ns setCanChooseFiles: #:type _BOOL #f)])
|
||||
|
||||
(when message
|
||||
(tellv ns setMessage: #:type _NSString message))
|
||||
(when directory
|
||||
(tellv ns setDirectoryURL: (tell NSURL
|
||||
fileURLWithPath: #:type _NSString (if (string? directory)
|
||||
directory
|
||||
(path->string directory))
|
||||
isDirectory: #:type _BOOL #t)))
|
||||
(when filename
|
||||
(tellv ns setNameFieldStringValue: #:type _NSString (path->string
|
||||
(file-name-from-path filename))))
|
||||
|
||||
(when (memq 'enter-packages style)
|
||||
(tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t))
|
||||
|
||||
(let ([result
|
||||
;; We run the file dialog completely modally --- shutting out
|
||||
;; all other eventspaces and threads. It would be nice to improve
|
||||
;; on this, but it's good enough.
|
||||
(atomically
|
||||
(let ([front (get-front)])
|
||||
(when parent
|
||||
(tellv ns beginSheetModalForWindow: (send parent get-cocoa-window)
|
||||
completionHandler: #f))
|
||||
(begin0
|
||||
(tell #:type _NSInteger ns runModal)
|
||||
(when parent (tell app endSheet: ns))
|
||||
(when front (tellv (send front get-cocoa-window)
|
||||
makeKeyAndOrderFront: #f)))))])
|
||||
(if (zero? result)
|
||||
#f
|
||||
(if (memq 'multi style)
|
||||
(let ([urls (tell ns URLs)])
|
||||
(for/list ([i (in-range (tell #:type _NSUInteger urls count))])
|
||||
(nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i))))
|
||||
(let ([url (tell ns URL)])
|
||||
(nsurl->string url)))))))
|
||||
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require ffi/objc
|
||||
scheme/foreign
|
||||
(require ffi/unsafe/objc
|
||||
ffi/unsafe
|
||||
scheme/class
|
||||
"pool.rkt"
|
||||
"utils.rkt"
|
||||
|
|
@ -13,11 +13,10 @@
|
|||
"../../syntax.rkt"
|
||||
"../common/queue.rkt"
|
||||
"../../lock.rkt")
|
||||
(unsafe!)
|
||||
(objc-unsafe!)
|
||||
|
||||
(provide frame%
|
||||
location->window)
|
||||
location->window
|
||||
get-front)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -26,6 +25,8 @@
|
|||
|
||||
(define front #f)
|
||||
|
||||
(define (get-front) front)
|
||||
|
||||
(define empty-mb (new menu-bar%))
|
||||
(define root-fake-frame #f)
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
"types.rkt"
|
||||
"frame.rkt"
|
||||
"finfo.rkt" ; file-creator-and-type
|
||||
"filedialog.rkt"
|
||||
"../../lock.rkt"
|
||||
"../common/handlers.rkt")
|
||||
|
||||
|
|
@ -110,7 +111,6 @@
|
|||
|
||||
(define (get-display-depth) 32)
|
||||
(define-unimplemented is-color-display?)
|
||||
(define-unimplemented file-selector)
|
||||
(define (id-to-menu-item id) id)
|
||||
(define-unimplemented get-the-x-selection)
|
||||
(define-unimplemented get-the-clipboard)
|
||||
|
|
@ -129,6 +129,7 @@
|
|||
colorUsingColorSpaceName: NSCalibratedRGBColorSpace)]
|
||||
[as-color (lambda (v)
|
||||
(inexact->exact (floor (* 255.0 v))))])
|
||||
(unless hi (error "selection background color lookup failed!"))
|
||||
(make-object color%
|
||||
(as-color
|
||||
(tell #:type _CGFloat hi redComponent))
|
||||
|
|
|
|||
|
|
@ -412,7 +412,7 @@
|
|||
(lambda (k v) k)))
|
||||
|
||||
(define (other-modal? win)
|
||||
;; called in event-pump thread
|
||||
;; called in atmoic mode in eventspace's thread
|
||||
(let loop ([frames (get-top-level-windows)])
|
||||
(and (pair? frames)
|
||||
(let ([status (send (car frames) frame-relative-dialog-status win)])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user