suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make the cocoa file dialogs deal better with ";"-separated globs.

Browse Source 
* Note the ugly hack of adding "foo~" for every "foo" suffix.

* Note also that when "*.*" is in the glob list all files should be
  available but it looks like this isn't working yet for some reason.
This commit is contained in:
Eli Barzilay 2011-06-03 00:54:07 -04:00
parent 67d58b9041
commit e9487fb0c7
1 changed files with 24 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/mred/private/wx/cocoa/filedialog.rkt
View File

@ -9,8 +9,7 @@
"queue.rkt" "queue.rkt"
"frame.rkt") "frame.rkt")
(provide (provide (protect-out file-selector))
(protect-out file-selector))
(import-class NSOpenPanel NSSavePanel NSURL NSArray) (import-class NSOpenPanel NSSavePanel NSURL NSArray)
@ -28,16 +27,26 @@
(not (send parent get-sheet)) (not (send parent get-sheet))
parent)]) parent)])
(let ([extensions (append (let* ([globs (apply append
(if (and extension (map (lambda (f) (regexp-split #rx" *; *" (cadr f)))
(not (equal? "" extension))) filters))]
(list extension) ;; get suffixes from "*.foo" globs (and *only* such globs)
null) [extensions
(if (memq 'packages style) (list "app") null) (for/list ([g (in-list globs)]
(for/list ([e (in-list filters)] #:when (and (regexp-match #rx"[*][.][^.]+$" g)
#:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e)) (not (equal? g "*.*"))))
(not (equal? (cadr e) "*.*")))) (car (regexp-match #rx"[^.]+$" g)))]
(car (regexp-match #rx"[^.]+$" (cadr e)))))]) [extensions
(if (memq 'packages style) (cons "app" extensions) extensions)]
[extensions
(if (and extension (not (equal? "" extension)))
(cons extension extensions) extensions)]
;; add "foo~" suffixes too.
[extensions
(append (for/list ([e (in-list extensions)]
#:when (not (regexp-match? #rx"~$" e)))
(string-append e "~"))
extensions)])
(unless (null? extensions) (unless (null? extensions)
(when (memq 'put style) (when (memq 'put style)
(tellv ns setCanSelectHiddenExtension: #:type _BOOL #t)) (tellv ns setCanSelectHiddenExtension: #:type _BOOL #t))
@ -45,10 +54,8 @@
arrayWithObjects: #:type (_list i _NSString) extensions arrayWithObjects: #:type (_list i _NSString) extensions
count: #:type _NSUInteger (length extensions))]) count: #:type _NSUInteger (length extensions))])
(tellv ns setAllowedFileTypes: a)) (tellv ns setAllowedFileTypes: a))
(let ([others? (ormap (lambda (e) (tellv ns setAllowsOtherFileTypes:
(equal? (cadr e) "*.*")) #:type _BOOL (and (member "*.*" globs) #t))))
filters)])
(tellv ns setAllowsOtherFileTypes: #:type _BOOL others?))))
(cond (cond
[(memq 'multi style) [(memq 'multi style)