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

.

Browse Source 
original commit: dbc683d4dc362e7361960eca3398064b69af53b6
This commit is contained in:
Matthew Flatt 2002-07-03 23:05:02 +00:00
parent 7b40de8849
commit b50ad4b637
2 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mred/mred.ss
View File

@ -5191,7 +5191,7 @@
(cons (read-string n s)
(loop))))))))
(define (mk-file-selector who put? multi? dir?)
(define (mk-file-selector who put? multi? dir? force-unix?)
(lambda (message parent directory filename extension style filters)
;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%)
@ -5209,7 +5209,8 @@
(string? (cadr p))))
filters))
(raise-type-error who "list of 2-string lists" filters))
(if (not (eq? (system-type) 'unix))
(if (not (or (eq? (system-type) 'unix)
force-unix?))
(let ([s (wx:file-selector message directory filename extension
(apply string-append
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
@ -5406,7 +5407,7 @@
[(message parent directory filename extension style)
(get-file message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters)
((mk-file-selector 'get-file #f #f #f) message parent directory filename extension style filters)]))
((mk-file-selector 'get-file #f #f #f #f) message parent directory filename extension style filters)]))
(define get-file-list
(case-lambda
@ -5419,7 +5420,7 @@
[(message parent directory filename extension style)
(get-file-list message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters)
((mk-file-selector 'get-file-list #f #t #f) message parent directory filename extension style filters)]))
((mk-file-selector 'get-file-list #f #t #f #f) message parent directory filename extension style filters)]))
(define put-file
(case-lambda
@ -5432,7 +5433,7 @@
[(message parent directory filename extension style)
(put-file message parent directory filename extension style default-filters)]
[(message parent directory filename extension style filters)
((mk-file-selector 'put-file #t #f #f) message parent directory filename extension style filters)]))
((mk-file-selector 'put-file #t #f #f #f) message parent directory filename extension style filters)]))
(define get-directory
(case-lambda
@ -5452,7 +5453,7 @@
message directory #f #f #f
'dir
(and parent (mred->wx parent)))
((mk-file-selector 'get-directory #f #f #t) message parent directory #f #f style null))]))
((mk-file-selector 'get-directory #f #f #t #t) message parent directory #f #f style null))]))
(define get-color-from-user
(case-lambda

1
collects/mred/private/kernel.ss
View File

@ -908,6 +908,7 @@
set-clipboard-client)
(define-function get-the-clipboard)
(define-class clipboard-client% object% ()
queue-callback
get-types
add-type
get-data