108 lines
3.9 KiB
Racket
108 lines
3.9 KiB
Racket
#lang scheme/unit
|
|
|
|
(require string-constants
|
|
"sig.rkt"
|
|
"../preferences.rkt"
|
|
mred/mred-sig
|
|
racket/path)
|
|
|
|
(import mred^
|
|
[prefix keymap: framework:keymap^]
|
|
[prefix frame: framework:frame^])
|
|
|
|
(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)
|
|
#:dialog-mixin frame:focus-table-mixin)])
|
|
(and f (or (not filter) (filter-match? filter f filter-msg))
|
|
(let* ([f (simple-form-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 op (current-output-port))
|
|
(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)
|
|
#:dialog-mixin frame:focus-table-mixin)])
|
|
(and f (or (not filter) (filter-match? filter f filter-msg))
|
|
(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 (simple-form-path f)])))))
|
|
|
|
(define-syntax-rule
|
|
(define/rename id exp)
|
|
(define id (procedure-rename exp 'id)))
|
|
|
|
;; external interfaces to file functions
|
|
|
|
(define/rename std-put-file (*put-file '()))
|
|
(define/rename std-get-file (*get-file '()))
|
|
(define/rename common-put-file (*put-file '(common)))
|
|
(define/rename common-get-file (*get-file '(common)))
|
|
|
|
(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)))
|