1  #lang scheme/unit
  2  
  3    (require string-constants
  4             "sig.rkt"
  5             "../preferences.rkt"
  6             mred/mred-sig
  7             racket/path)
  8    
  9    (import mred^
 10            [prefix keymap: framework:keymap^]
 11            [prefix frame: framework:frame^])
 12    
 13    (export (rename framework:finder^
 14                    [-put-file put-file]
 15                    [-get-file get-file]))
 16    
 17    (define dialog-parent-parameter (make-parameter #f))
 18    
 19    (define filter-match?
 20      (λ (filter name msg)
 21        (let-values ([(base name dir?) (split-path name)])
 22          (if (regexp-match-exact? filter (path->bytes name))
 23              #t
 24              (begin
 25                (message-box (string-constant error) msg)
 26                #f)))))
 27    
 28    (define default-filters (make-parameter '(["Any" "*.*"])))
 29    (define default-extension (make-parameter ""))
 30    
 31    ;; dialog wrappers
 32    
 33    (define (*put-file style)
 34      (lambda ([name #f]
 35               [directory #f]
 36               [replace? #f]
 37               [prompt (string-constant select-file)]
 38               [filter #f]
 39               [filter-msg (string-constant file-wrong-form)]
 40               [parent-win (dialog-parent-parameter)])
 41        (let* ([directory (if (and (not directory) (string? name))
 42                              (path-only name)
 43                              directory)]
 44               [name (or (and (string? name) (file-name-from-path name))
 45                         name)]
 46               [f (put-file prompt parent-win directory name
 47                            (default-extension) style (default-filters)
 48                            #:dialog-mixin frame:focus-table-mixin)])
 49          (and f (or (not filter) (filter-match? filter f filter-msg))
 50               (let* ([f (simple-form-path f)]
 51                      [dir (path-only f)]
 52                      [name (file-name-from-path f)])
 53                 (cond
 54                   [(not (and (path-string? dir) (directory-exists? dir)))
 55                    (message-box (string-constant error)
 56                                 (string-constant dir-dne))
 57                    #f]
 58                   [(or (not name) (equal? name ""))
 59                    (message-box (string-constant error)
 60                                 (string-constant empty-filename))
 61                    #f]
 62                   [else f]))))))
 63    
 64    (define op (current-output-port))
 65    (define (*get-file style)
 66      (lambda ([directory #f]
 67               [prompt (string-constant select-file)]
 68               [filter #f]
 69               [filter-msg (string-constant file-wrong-form)]
 70               [parent-win (dialog-parent-parameter)])
 71        (let ([f (get-file prompt parent-win directory #f
 72                           (default-extension) style (default-filters)
 73                           #:dialog-mixin frame:focus-table-mixin)])
 74          (and f (or (not filter) (filter-match? filter f filter-msg))
 75               (cond [(directory-exists? f)
 76                      (message-box (string-constant error)
 77                                   (string-constant that-is-dir-name))
 78                      #f]
 79                     [(not (file-exists? f))
 80                      (message-box (string-constant error) 
 81                                   (string-constant file-dne))
 82                      #f]
 83                     [else (simple-form-path f)])))))
 84    
 85    (define-syntax-rule
 86      (define/rename id exp)
 87      (define id (procedure-rename exp 'id)))
 88    
 89    ;; external interfaces to file functions
 90    
 91    (define/rename std-put-file    (*put-file '()))
 92    (define/rename std-get-file    (*get-file '()))
 93    (define/rename common-put-file (*put-file '(common)))
 94    (define/rename common-get-file (*get-file '(common)))
 95    
 96    (define -put-file
 97      (λ args
 98        (apply (case (preferences:get 'framework:file-dialogs)
 99                 [(std) std-put-file]
100                 [(common) common-put-file])
101               args)))
102    (define -get-file
103      (λ args
104        (apply (case (preferences:get 'framework:file-dialogs)
105                 [(std) std-get-file]
106                 [(common) common-get-file])
107               args)))