diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 026dfe65..a6f24eb0 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -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" "*.*"))) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt new file mode 100644 index 00000000..1d19c677 --- /dev/null +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -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))))))) + diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3dbec1b2..a82b3eef 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -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) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 2f44863f..a03daccc 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -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)) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 27a25c42..0f0672e6 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -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)])