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

better treatment of the standard style

Browse Source 
svn: r3233
This commit is contained in:
Eli Barzilay 2006-06-05 18:32:01 +00:00
parent 271d45320c
commit 425f9df4b0
1 changed files with 42 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mred/private/filedialog.ss
View File

@ -26,7 +26,7 @@
(cons (read-bytes n s) (cons (read-bytes n s)
(loop)))))))) (loop))))))))
(define (mk-file-selector who put? multi? dir? force-unix?) (define (mk-file-selector who put? multi? dir?)
(lambda (message parent directory filename extension style filters) (lambda (message parent directory filename extension style filters)
;; Calls from C++ have wrong kind of window: ;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%) (when (is-a? parent wx:window%)
@ -34,10 +34,12 @@
(check-label-string/false who message) (check-label-string/false who message)
(check-top-level-parent/false who parent) (check-top-level-parent/false who parent)
(check-path/false who directory) (check-path/false who filename) (check-string/false who extension) (check-path/false who directory)
(check-path/false who filename)
(check-string/false who extension)
(check-style who #f (cond (check-style who #f (cond
[dir? '(enter-packages)] [dir? '(standard enter-packages)]
[else '(packages enter-packages)]) style) [else '(standard packages enter-packages)]) style)
(unless (and (list? filters) (unless (and (list? filters)
(andmap (lambda (p) (andmap (lambda (p)
(and (list? p) (and (list? p)
@ -46,7 +48,9 @@
(string? (cadr p)))) (string? (cadr p))))
filters)) filters))
(raise-type-error who "list of 2-string lists" filters)) (raise-type-error who "list of 2-string lists" filters))
(if (or (eq? (system-type) 'unix) force-unix?) (let* ([std? (memq 'standard style)]
[style (if std? (remq 'standard style) style)])
(if (or std? (eq? (system-type) 'unix))
(send (new path-dialog% (send (new path-dialog%
[put? put?] [put? put?]
[dir? dir?] [dir? dir?]
@ -56,7 +60,7 @@
[directory directory] [directory directory]
[filename filename] [filename filename]
[filters [filters
(cond [(eq? filters default-filters) #t] ; has its own defaults (cond [(eq? filters default-filters) #t] ; its own defaults
[dir? #f] [dir? #f]
[else filters])]) [else filters])])
run) run)
@ -76,7 +80,7 @@
(and parent (mred->wx parent)))]) (and parent (mred->wx parent)))])
(if (and multi? s) (if (and multi? s)
(map bytes->path (files->list (path->bytes s))) (map bytes->path (files->list (path->bytes s)))
s))))) s))))))
(define default-filters '(("Any" "*.*"))) (define default-filters '(("Any" "*.*")))
@ -89,10 +93,8 @@
(define name (define name
(opt-lambda ([message #f] [parent #f] [directory #f] [filename #f] (opt-lambda ([message #f] [parent #f] [directory #f] [filename #f]
[extension #f] [style null] [filters default-filters]) [extension #f] [style null] [filters default-filters])
(let* ([force-unix? (memq 'standard style)] ((mk-file-selector 'name put? multi? #f)
[style (if force-unix? (remq 'standard style) style)]) message parent directory filename extension style filters)))]))
((mk-file-selector 'name put? multi? #f force-unix?)
message parent directory filename extension style filters))))]))
(define-file-selector get-file #f #f) (define-file-selector get-file #f #f)
(define-file-selector get-file-list #f #t) (define-file-selector get-file-list #f #t)
@ -100,7 +102,7 @@
(define get-directory (define get-directory
(opt-lambda ([message #f] [parent #f] [directory #f] [style null]) (opt-lambda ([message #f] [parent #f] [directory #f] [style null])
((mk-file-selector 'get-directory #f #f #t #f) ((mk-file-selector 'get-directory #f #f #t)
message parent directory #f #f style null))) message parent directory #f #f style null)))
(set-get-file! get-file)) (set-get-file! get-file))