racket/collects/framework/private/finder.ss
2008-11-01 19:55:21 +00:00

102 lines
3.6 KiB
Scheme

#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 #f style)])
(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)))