1582f160bc
patterns instead of one pattern per suffix. (This was almost never
used -- only when saving a file that is in text mode.)
* Since this default is the same that the scheme
mode ("framework/private/scheme.rkt") sets, remove that
setting. (Leave it commented in case there's need to have some
different global default.) It makes the above default get used when
saving a scheme-mode file.
* Finally, for some reason the code in "framework/private/finder.rkt"
was not using these `default-filters' at all for the file open dialog
in `*get-file'. (I tracked it back to CVS when the code was written,
and it was never used.)
I made it use it now. This is visible on gtk (and probably on
windows, not sure what OSX does) in that openning a file would show
you all files. After this change, it would show only racket source
files, but there will be an option to switch the pattern to show all files.
** If the previous setup (showing all files) was intentional, it would
be better to simply change "drracket/private/main.rkt" to add the
racket source globs before the default. In that case it might also
make sense to uncomment the change in scheme.rkt back in, so when
saving the default is the racket file suffixes (but this sounds
like a confusing UI).
103 lines
3.7 KiB
Racket
103 lines
3.7 KiB
Racket
#lang scheme/unit
|
|
|
|
(require string-constants
|
|
"sig.ss"
|
|
"../preferences.ss"
|
|
mred/mred-sig
|
|
scheme/path)
|
|
|
|
|
|
(import mred^
|
|
[prefix keymap: framework:keymap^])
|
|
|
|
(export (rename framework:finder^
|
|
[-put-file put-file]
|
|
[-get-file get-file]))
|
|
|
|
(define dialog-parent-parameter (make-parameter #f))
|
|
|
|
(define filter-match?
|
|
(λ (filter name msg)
|
|
(let-values ([(base name dir?) (split-path name)])
|
|
(if (regexp-match-exact? filter (path->bytes name))
|
|
#t
|
|
(begin
|
|
(message-box (string-constant error) msg)
|
|
#f)))))
|
|
|
|
(define default-filters (make-parameter '(["Any" "*.*"])))
|
|
(define default-extension (make-parameter ""))
|
|
|
|
;; dialog wrappers
|
|
|
|
(define (*put-file style)
|
|
(lambda ([name #f]
|
|
[directory #f]
|
|
[replace? #f]
|
|
[prompt (string-constant select-file)]
|
|
[filter #f]
|
|
[filter-msg (string-constant file-wrong-form)]
|
|
[parent-win (dialog-parent-parameter)])
|
|
(let* ([directory (if (and (not directory) (string? name))
|
|
(path-only name)
|
|
directory)]
|
|
[name (or (and (string? name) (file-name-from-path name))
|
|
name)]
|
|
[f (put-file prompt parent-win directory name
|
|
(default-extension) style (default-filters))])
|
|
(and f (or (not filter) (filter-match? filter f filter-msg))
|
|
(let* ([f (normal-case-path (normalize-path f))]
|
|
[dir (path-only f)]
|
|
[name (file-name-from-path f)])
|
|
(cond
|
|
[(not (and (path-string? dir) (directory-exists? dir)))
|
|
(message-box (string-constant error)
|
|
(string-constant dir-dne))
|
|
#f]
|
|
[(or (not name) (equal? name ""))
|
|
(message-box (string-constant error)
|
|
(string-constant empty-filename))
|
|
#f]
|
|
[else f]))))))
|
|
|
|
(define (*get-file style)
|
|
(lambda ([directory #f]
|
|
[prompt (string-constant select-file)]
|
|
[filter #f]
|
|
[filter-msg (string-constant file-wrong-form)]
|
|
[parent-win (dialog-parent-parameter)])
|
|
(let ([f (get-file prompt parent-win directory #f
|
|
(default-extension) style (default-filters))])
|
|
(and f (or (not filter) (filter-match? filter f filter-msg))
|
|
(let ([f (normalize-path f)])
|
|
(cond [(directory-exists? f)
|
|
(message-box (string-constant error)
|
|
(string-constant that-is-dir-name))
|
|
#f]
|
|
[(not (file-exists? f))
|
|
(message-box (string-constant error)
|
|
(string-constant file-dne))
|
|
#f]
|
|
[else f]))))))
|
|
|
|
;; external interfaces to file functions
|
|
|
|
(define std-put-file (*put-file '()))
|
|
(define std-get-file (*get-file '()))
|
|
(define common-put-file (*put-file '(common)))
|
|
(define common-get-file (*get-file '(common)))
|
|
(define common-get-file-list void)
|
|
|
|
(define -put-file
|
|
(λ args
|
|
(apply (case (preferences:get 'framework:file-dialogs)
|
|
[(std) std-put-file]
|
|
[(common) common-put-file])
|
|
args)))
|
|
(define -get-file
|
|
(λ args
|
|
(apply (case (preferences:get 'framework:file-dialogs)
|
|
[(std) std-get-file]
|
|
[(common) common-get-file])
|
|
args)))
|