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

adjust the framework get file dialog functions to not call normalize-path unless

Browse Source 
they've recently checked to see if the file exists
This commit is contained in:
Robby Findler 2011-08-26 09:15:54 -05:00
parent 913883fd28
commit 1d13d1399c
1 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/framework/private/finder.rkt
View File

@ -69,23 +69,26 @@
(let ([f (get-file prompt parent-win directory #f (let ([f (get-file prompt parent-win directory #f
(default-extension) style (default-filters))]) (default-extension) style (default-filters))])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(let ([f (normalize-path f)]) (cond [(directory-exists? f)
(cond [(directory-exists? f) (message-box (string-constant error)
(message-box (string-constant error) (string-constant that-is-dir-name))
(string-constant that-is-dir-name)) #f]
#f] [(not (file-exists? f))
[(not (file-exists? f)) (message-box (string-constant error)
(message-box (string-constant error) (string-constant file-dne))
(string-constant file-dne)) #f]
#f] [else (normalize-path f)])))))
[else f]))))))
(define-syntax-rule
(define/rename id exp)
(define id (procedure-rename exp 'id)))
;; external interfaces to file functions ;; external interfaces to file functions
(define std-put-file (*put-file '())) (define/rename std-put-file (*put-file '()))
(define std-get-file (*get-file '())) (define/rename std-get-file (*get-file '()))
(define common-put-file (*put-file '(common))) (define/rename common-put-file (*put-file '(common)))
(define common-get-file (*get-file '(common))) (define/rename common-get-file (*get-file '(common)))
(define common-get-file-list void) (define common-get-file-list void)
(define -put-file (define -put-file