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

svn: r3206

Browse Source
This commit is contained in:
Eli Barzilay 2006-06-03 20:34:04 +00:00
parent c948e8cbc6
commit c21d9fca85
2 changed files with 43 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/framework/private/finder.ss
View File

@ -659,7 +659,7 @@
; the std- and common- forms both have opt-lambda's, with the same ; the std- and common- forms both have opt-lambda's, with the same
; list of args. Should the opt-lambda's be placed in the dispatching function? ; list of args. Should the opt-lambda's be placed in the dispatching function?
(define std-put-file (define std-put-file
(opt-lambda ([name #f] (opt-lambda ([name #f]
[directory #f] [directory #f]
@ -668,83 +668,59 @@
[filter #f] [filter #f]
[filter-msg (string-constant file-wrong-form)] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let* ([directory (if (and (not directory) (let* ([directory (if (and (not directory) (string? name))
(string? name))
(path-only name) (path-only name)
directory)] directory)]
[name (or (and (string? name) [name (or (and (string? name) (file-name-from-path name))
(file-name-from-path name))
name)] name)]
[f (put-file [f (put-file prompt parent-win directory name
prompt (default-extension) '() (default-filters))])
parent-win (and f (or (not filter) (filter-match? filter f filter-msg))
directory (let* ([f (normal-case-path (normalize-path f))]
name [dir (path-only f)]
(default-extension) [name (file-name-from-path f)])
'() (cond
(default-filters))]) [(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]))))))
(if (or (not f)
(and filter
(not (filter-match? filter
f
filter-msg))))
#f
(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 std-get-file (define std-get-file
(opt-lambda ([directory #f] (opt-lambda ([directory #f]
[prompt (string-constant select-file)] [prompt (string-constant select-file)]
[filter #f] [filter #f]
[filter-msg (string-constant file-wrong-form)] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([f (get-file (let ([f (get-file prompt parent-win directory)])
prompt (and f (or (not filter) (filter-match? filter f filter-msg))
parent-win (let ([f (normalize-path f)])
directory)]) (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
(if f
(if (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]))
#f)
#f))))
; external interfaces to file functions
(define -put-file (define -put-file
(λ args (λ args
(let ([actual-fun (apply (case (preferences:get 'framework:file-dialogs)
(case (preferences:get 'framework:file-dialogs) [(std) std-put-file]
[(std) std-put-file] [(common) common-put-file])
[(common) common-put-file])]) args)))
(apply actual-fun args))))
(define -get-file (define -get-file
(λ args (λ args
(let ([actual-fun (apply (case (preferences:get 'framework:file-dialogs)
(case (preferences:get 'framework:file-dialogs)
[(std) std-get-file] [(std) std-get-file]
[(common) common-get-file])]) [(common) common-get-file])
(apply actual-fun args))))))) args))))))

8
collects/framework/private/main.ss
View File

@ -234,12 +234,8 @@
(preferences:set-default 'framework:verify-exit #t boolean?) (preferences:set-default 'framework:verify-exit #t boolean?)
(preferences:set-default 'framework:delete-forward? #t boolean?) (preferences:set-default 'framework:delete-forward? #t boolean?)
(preferences:set-default 'framework:show-periods-in-dirlist #f boolean?) (preferences:set-default 'framework:show-periods-in-dirlist #f boolean?)
(preferences:set-default (preferences:set-default 'framework:file-dialogs 'std
'framework:file-dialogs (λ (x) (and (memq x '(common std)) #t)))
'std
(λ (x)
(or (eq? x 'common)
(eq? x 'std))))
;; scheme prefs ;; scheme prefs