137 lines
5.9 KiB
Racket
137 lines
5.9 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/objc
|
|
racket/class
|
|
racket/path
|
|
"../../lock.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"queue.rkt"
|
|
"frame.rkt")
|
|
|
|
(provide (protect-out 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)
|
|
(promote-to-gui!)
|
|
(let ([ns (as-objc-allocation-with-retain
|
|
(if (memq 'put style)
|
|
(tell NSSavePanel savePanel)
|
|
(tell NSOpenPanel openPanel)))]
|
|
[parent (and parent
|
|
(not (send parent get-sheet))
|
|
parent)])
|
|
|
|
(let* ([globs (apply append
|
|
(map (lambda (f) (regexp-split #rx" *; *" (cadr f)))
|
|
filters))]
|
|
;; get suffixes from "*.foo" globs (and *only* such globs)
|
|
[extensions
|
|
(for/list ([g (in-list globs)]
|
|
#:when (and (regexp-match #rx"[*][.][^.]+$" g)
|
|
(not (equal? g "*.*"))))
|
|
(car (regexp-match #rx"[^.]+$" g)))]
|
|
[extensions
|
|
(if (memq 'packages style) (cons "app" extensions) extensions)]
|
|
[extensions
|
|
(if (and extension (not (equal? "" extension)))
|
|
(cons extension extensions) extensions)])
|
|
(unless (null? extensions)
|
|
(when (memq 'put style)
|
|
(tellv ns setCanSelectHiddenExtension: #:type _BOOL #t))
|
|
(let ([allow-any? (member "*.*" globs)])
|
|
(when (or (not allow-any?)
|
|
(memq 'put style))
|
|
(let ([a (tell NSArray
|
|
arrayWithObjects: #:type (_list i _NSString) extensions
|
|
count: #:type _NSUInteger (length extensions))])
|
|
(tellv ns setAllowedFileTypes: a))
|
|
(tellv ns setAllowsOtherFileTypes: #:type _BOOL allow-any?)))))
|
|
|
|
(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 (or (memq 'put style)
|
|
(memq 'dir style))
|
|
(tellv ns setCanCreateDirectories: #:type _BOOL #t))
|
|
|
|
(when message
|
|
(tellv ns setMessage: #:type _NSString message))
|
|
(when directory
|
|
(let ([dir (if (string? directory)
|
|
directory
|
|
(path->string directory))])
|
|
(if (version-10.6-or-later?)
|
|
(tellv ns setDirectoryURL: (tell NSURL
|
|
fileURLWithPath: #:type _NSString dir
|
|
isDirectory: #:type _BOOL #t))
|
|
(tellv ns setDirectory: #:type _NSString dir))))
|
|
(when filename
|
|
(when (version-10.6-or-later?)
|
|
(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)]
|
|
[parent (and (version-10.6-or-later?)
|
|
parent)]
|
|
[completion (and (version-10.10-or-later?)
|
|
parent
|
|
;; retain until done:
|
|
(box null))]
|
|
[completion-result 0])
|
|
(when parent
|
|
(tellv ns beginSheetModalForWindow: (send parent get-cocoa-window)
|
|
completionHandler: #:type _pointer (and completion
|
|
(objc-block
|
|
(_fun #:atomic? #t #:keep completion _pointer _int -> _void)
|
|
(lambda (blk val)
|
|
(set! completion-result val)
|
|
(tellv app stopModal))
|
|
#:keep completion))))
|
|
(begin0
|
|
(if completion
|
|
;; For 10.10, using `runModal` centers the sheet before
|
|
;; running the model loop, so we have to use a completion
|
|
;; handler as installed above plus `runModalForWindow:`
|
|
;; (and this works despite the docs's claim that
|
|
;; `runModalForWindow:` centers its argument).
|
|
(begin
|
|
(tell app runModalForWindow: ns)
|
|
(set-box! completion #f)
|
|
completion-result)
|
|
;; For 10.9 and earlier, runModel will do the hard part
|
|
;; for us:
|
|
(tell #:type _NSInteger ns runModal))
|
|
(when parent (tell app endSheet: ns))
|
|
(when front (tellv (send front get-cocoa-window)
|
|
makeKeyAndOrderFront: #f)))))])
|
|
(begin0
|
|
(if (zero? result)
|
|
#f
|
|
(atomically
|
|
(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)))))
|
|
(release ns)))))
|