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

82
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,37 +48,39 @@
(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)]
(send (new path-dialog% [style (if std? (remq 'standard style) style)])
[put? put?] (if (or std? (eq? (system-type) 'unix))
[dir? dir?] (send (new path-dialog%
[multi? multi?] [put? put?]
[message message] [dir? dir?]
[parent parent] [multi? multi?]
[directory directory] [message message]
[filename filename] [parent parent]
[filters [directory directory]
(cond [(eq? filters default-filters) #t] ; has its own defaults [filename filename]
[dir? #f] [filters
[else filters])]) (cond [(eq? filters default-filters) #t] ; its own defaults
run) [dir? #f]
(let ([s (wx:file-selector [else filters])])
message directory filename extension run)
;; file types: (let ([s (wx:file-selector
(apply string-append message directory filename extension
(map (lambda (s) (format "~a|~a|" (car s) (cadr s))) ;; file types:
filters)) (apply string-append
;; style: (map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
(cons (cond [dir? 'dir] filters))
[put? 'put] ;; style:
[multi? 'multi] (cons (cond [dir? 'dir]
[else 'get]) [put? 'put]
style) [multi? 'multi]
;; parent: [else 'get])
(and parent (mred->wx parent)))]) style)
(if (and multi? s) ;; parent:
(map bytes->path (files->list (path->bytes s))) (and parent (mred->wx parent)))])
s))))) (if (and multi? s)
(map bytes->path (files->list (path->bytes 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))