Updated dialogs, added find-object, find-checkbox to MrEd test primitives
original commit: 35f38ad7b876c6b24ec3e86232e26113ff7ed321
This commit is contained in:
Paul Steckler
parent
86fc99cc5b
commit
dd10c098ed
|
|
@ -1,3 +1,6 @@
|
|||
;;; finder.ss
|
||||
|
||||
;;; Authors: Matthew Flatt, Robby Findler, Paul Steckler
|
||||
|
||||
(unit/sig mred:finder^
|
||||
(import [wx : wx^]
|
||||
|
|
@ -40,16 +43,50 @@
|
|||
#t]
|
||||
[else #f])))
|
||||
|
||||
(define get-slash
|
||||
(lambda ()
|
||||
(case wx:platform
|
||||
[(unix) "/"]
|
||||
[(windows) "\\"]
|
||||
[else ":"])))
|
||||
|
||||
(define build-updir
|
||||
(lambda (dir)
|
||||
(let ([components (mzlib:file:explode-path dir)]
|
||||
[slash (get-slash)])
|
||||
(letrec
|
||||
([loop
|
||||
(lambda (comps)
|
||||
(cond
|
||||
[(null? comps) ""]
|
||||
[(equal? (car comps) slash)
|
||||
(string-append slash (loop (cdr comps)))]
|
||||
[(eq? (length comps) 1) ""]
|
||||
[else (let ([rest (loop (cdr comps))])
|
||||
(if (string=? rest "")
|
||||
(car comps)
|
||||
(build-path (car comps) rest)))]))])
|
||||
(loop components)))))
|
||||
|
||||
(mred:preferences:set-preference-default 'mred:show-periods-in-dirlist #f
|
||||
(lambda (x)
|
||||
(or (not x)
|
||||
(eq? x #t))))
|
||||
|
||||
; the finder-dialog% class controls the user interface for dialogs
|
||||
|
||||
(define finder-dialog%
|
||||
(class mred:container:dialog-box% (save-mode? replace-ok? multi-mode?
|
||||
result-box start-dir
|
||||
start-name prompt
|
||||
file-filter file-filter-msg)
|
||||
(class mred:container:dialog-box% (parent-win
|
||||
save-mode?
|
||||
replace-ok?
|
||||
multi-mode?
|
||||
result-box
|
||||
start-dir
|
||||
start-name
|
||||
prompt
|
||||
file-filter
|
||||
file-filter-msg)
|
||||
|
||||
(inherit new-line tab fit center
|
||||
show
|
||||
popup-menu)
|
||||
|
|
@ -57,14 +94,15 @@
|
|||
(private
|
||||
[WIDTH 500]
|
||||
[HEIGHT 400]
|
||||
|
||||
dirs current-dir
|
||||
dirs
|
||||
current-dir
|
||||
last-selected
|
||||
[select-counter 0])
|
||||
|
||||
(private
|
||||
[set-directory
|
||||
(lambda (dir) ; dir is normalied
|
||||
|
||||
[set-directory ; sets directory in listbox
|
||||
(lambda (dir) ; dir is normalized
|
||||
(mred:gui-utils:show-busy-cursor
|
||||
(lambda ()
|
||||
(set! current-dir dir)
|
||||
|
|
@ -84,11 +122,6 @@
|
|||
; No more
|
||||
(values dir-list menu-list)))))])
|
||||
(set! dirs (reverse dir-list))
|
||||
(send* directory-edit
|
||||
(begin-edit-sequence)
|
||||
(erase)
|
||||
(insert dir)
|
||||
(end-edit-sequence))
|
||||
(send dir-choice clear)
|
||||
(let loop ([choices (reverse menu-list)])
|
||||
(unless (null? choices)
|
||||
|
|
@ -113,50 +146,66 @@
|
|||
(char=? (string-ref s 0) #\.))
|
||||
rest]
|
||||
[(directory-exists? (build-path dir s))
|
||||
(cons (string-append s
|
||||
(case wx:platform
|
||||
[(unix) "/"]
|
||||
[(windows) "\\"]
|
||||
[else ":"]))
|
||||
(cons (string-append s (get-slash))
|
||||
rest)]
|
||||
[(or (not file-filter)
|
||||
(mzlib:string:regexp-match-exact? file-filter s))
|
||||
(cons s rest)]
|
||||
[else rest])))))
|
||||
(if (eq? wx:platform 'unix) string<? string-ci<?)))
|
||||
(set! last-selected -1))))])
|
||||
|
||||
(send name-list set-selection-and-edit 0)
|
||||
(set! last-selected -1))))]
|
||||
|
||||
[set-edit
|
||||
(lambda ()
|
||||
(let* ([file (send name-list get-string-selection)]
|
||||
[dir-and-file
|
||||
(if (null? file)
|
||||
current-dir
|
||||
(build-path current-dir file))])
|
||||
(send* directory-edit
|
||||
(begin-edit-sequence)
|
||||
(erase)
|
||||
(insert dir-and-file)
|
||||
(end-edit-sequence))
|
||||
(when save-mode?
|
||||
(let ([fullname (build-path current-dir
|
||||
(make-relative file))])
|
||||
(send name-field set-value
|
||||
(if (directory-exists? fullname)
|
||||
""
|
||||
file))))))])
|
||||
|
||||
(public
|
||||
|
||||
[do-period-in/exclusion
|
||||
(lambda (button event)
|
||||
(mred:preferences:set-preference 'mred:show-periods-in-dirlist
|
||||
(send event checked?))
|
||||
(set-directory current-dir))]
|
||||
|
||||
[do-dir
|
||||
(lambda (choice event)
|
||||
(let ([which (send event get-selection)])
|
||||
(if (< which (length dirs))
|
||||
(set-directory (list-ref dirs which)))))]
|
||||
|
||||
|
||||
[do-name
|
||||
(lambda (text event)
|
||||
(if (eq? (send event get-event-type)
|
||||
wx:const-event-type-text-enter-command)
|
||||
(do-ok)))]
|
||||
|
||||
[do-name-list
|
||||
(lambda args #f)]
|
||||
(lambda (_ event)
|
||||
(if (and (eq? (send event get-event-type)
|
||||
wx:const-event-type-listbox-command)
|
||||
(send event is-selection?))
|
||||
(set-edit)))]
|
||||
|
||||
[do-result-list
|
||||
(lambda args #f)]
|
||||
|
||||
[do-into-dir
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
(if (string? name)
|
||||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? name)
|
||||
(set-directory (mzlib:file:normalize-path name)))))))]
|
||||
|
||||
[do-ok
|
||||
(lambda args
|
||||
(if multi-mode?
|
||||
|
|
@ -175,8 +224,12 @@
|
|||
(cond
|
||||
[(not (string? name)) 'nothing-selected]
|
||||
[(string=? name "")
|
||||
(wx:message-box "You must specify a file name"
|
||||
"Error")]
|
||||
(let ([file (send directory-edit get-text)])
|
||||
(if (directory-exists? file)
|
||||
(set-directory (mzlib:file:normalize-path file))
|
||||
(wx:message-box
|
||||
"You must specify a file name"
|
||||
"Error")))]
|
||||
[(and save-mode?
|
||||
file-filter
|
||||
(not (mzlib:string:regexp-match-exact? file-filter name)))
|
||||
|
|
@ -185,11 +238,7 @@
|
|||
(let ([file (build-path current-dir
|
||||
(make-relative name))])
|
||||
(if (directory-exists? file)
|
||||
(if save-mode?
|
||||
(wx:message-box
|
||||
"That is the name of a directory."
|
||||
"Error")
|
||||
(set-directory (mzlib:file:normalize-path file)))
|
||||
(set-directory (mzlib:file:normalize-path file))
|
||||
(if (or (not save-mode?)
|
||||
(not (file-exists? file))
|
||||
replace-ok?
|
||||
|
|
@ -212,6 +261,7 @@
|
|||
(> (send result-list find-string name) -1))
|
||||
(set! select-counter (add1 select-counter))
|
||||
(send result-list append (mzlib:file:normalize-path name))))]
|
||||
|
||||
[do-add
|
||||
(lambda args
|
||||
(let ([name (send name-list get-string-selection)])
|
||||
|
|
@ -219,6 +269,7 @@
|
|||
(let ([name (build-path current-dir
|
||||
(make-relative name))])
|
||||
(add-one name)))))]
|
||||
|
||||
[do-add-all
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
|
|
@ -229,6 +280,7 @@
|
|||
(make-relative name))])
|
||||
(add-one name)
|
||||
(loop (add1 n)))))))]
|
||||
|
||||
[do-remove
|
||||
(lambda args
|
||||
(let loop ([n 0])
|
||||
|
|
@ -246,22 +298,125 @@
|
|||
(show #f))]
|
||||
|
||||
[on-close (lambda () #f)])
|
||||
|
||||
(sequence
|
||||
(super-init () (if save-mode? "Put File" "Get File")
|
||||
#t 300 300 WIDTH HEIGHT))
|
||||
(super-init parent-win
|
||||
(if save-mode? "Put file" "Get file")
|
||||
#t
|
||||
300
|
||||
300
|
||||
WIDTH
|
||||
HEIGHT))
|
||||
|
||||
(private
|
||||
|
||||
[main-panel (make-object mred:container:vertical-panel% this)]
|
||||
|
||||
[top-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
|
||||
[_1 (make-object mred:container:message% top-panel prompt)]
|
||||
|
||||
[dir-choice (make-object mred:container:choice% top-panel do-dir '())]
|
||||
|
||||
[middle-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
[left-middle-panel (make-object mred:container:vertical-panel% middle-panel)]
|
||||
[right-middle-panel (when multi-mode? (make-object mred:container:vertical-panel% middle-panel))]
|
||||
[right-middle-panel (when multi-mode?
|
||||
(make-object mred:container:vertical-panel% middle-panel))]
|
||||
[name-list%
|
||||
|
||||
(class-asi mred:container:list-box%
|
||||
|
||||
(inherit
|
||||
get-first-item
|
||||
get-string
|
||||
get-selection
|
||||
get-string-selection
|
||||
number
|
||||
number-of-visible-items
|
||||
set-first-item
|
||||
set-selection)
|
||||
|
||||
(public
|
||||
|
||||
[set-selection-and-edit ; set selection, update edit box
|
||||
|
||||
(lambda (pos)
|
||||
|
||||
(if (> (number) 0)
|
||||
(let* ([first-item (get-first-item)]
|
||||
[last-item (sub1 (+ (number-of-visible-items)
|
||||
first-item))])
|
||||
(if (or (< pos first-item)
|
||||
(> pos last-item))
|
||||
(set-first-item pos))
|
||||
(set-selection pos)
|
||||
(set-edit))
|
||||
(send* directory-edit
|
||||
(begin-edit-sequence)
|
||||
(erase)
|
||||
(end-edit-sequence))))]
|
||||
|
||||
[pre-on-char ; set selection according to keystroke
|
||||
|
||||
(lambda (_ key)
|
||||
(let ([code (send key get-key-code)]
|
||||
[num-items (number)]
|
||||
[curr-pos (get-selection)])
|
||||
|
||||
(cond
|
||||
|
||||
[(or (= code 10) (= code 13)) ; CR or LF
|
||||
(do-ok)]
|
||||
|
||||
; look for letter at beginning of a filename
|
||||
|
||||
[(and (>= code 32) (<= code 127)) ; ASCII-dependent
|
||||
; but who uses EBCDIC?
|
||||
(letrec
|
||||
([loop
|
||||
(lambda (pos)
|
||||
(unless
|
||||
(>= pos num-items)
|
||||
(let ([first-char (string-ref (get-string pos) 0)])
|
||||
(if (eq? code (char->integer first-char))
|
||||
(set-selection-and-edit pos)
|
||||
(loop (add1 pos))))))])
|
||||
(loop (add1 curr-pos)))]
|
||||
|
||||
; movement keys
|
||||
|
||||
[(and (= code wx:const-k-up)
|
||||
(> curr-pos 0))
|
||||
(set-selection-and-edit (sub1 curr-pos))]
|
||||
|
||||
[(and (= code wx:const-k-down)
|
||||
(< curr-pos (sub1 num-items)))
|
||||
(let* ([num-vis (number-of-visible-items)]
|
||||
[curr-first (get-first-item)]
|
||||
[new-curr-pos (add1 curr-pos)]
|
||||
[new-first (if (< new-curr-pos (+ curr-first num-vis))
|
||||
curr-first ; no scroll needed
|
||||
(add1 curr-first))])
|
||||
(set-first-item new-first)
|
||||
(set-selection-and-edit new-curr-pos))]
|
||||
|
||||
[(and (= code wx:const-k-prior)
|
||||
(> curr-pos 0))
|
||||
(let* ([num-vis (number-of-visible-items)]
|
||||
[new-first (- (get-first-item) num-vis)])
|
||||
(set-first-item (max new-first 0))
|
||||
(set-selection-and-edit (max 0 (- curr-pos num-vis))))]
|
||||
|
||||
[(and (= code wx:const-k-next)
|
||||
(< curr-pos (sub1 num-items)))
|
||||
(let* ([num-vis (number-of-visible-items)]
|
||||
[new-first (+ (get-first-item) num-vis)])
|
||||
(set-first-item (min new-first (- (number) num-vis)))
|
||||
(set-selection-and-edit
|
||||
(min (sub1 num-items) (+ curr-pos num-vis))))]
|
||||
|
||||
[else #f])))]
|
||||
|
||||
[on-default-action
|
||||
(lambda ()
|
||||
(let* ([which (send name-list get-string-selection)]
|
||||
|
|
@ -274,14 +429,18 @@
|
|||
(if multi-mode?
|
||||
(do-add)
|
||||
(do-ok))))))]))]
|
||||
|
||||
[name-list (make-object name-list%
|
||||
left-middle-panel do-name-list
|
||||
() wx:const-single
|
||||
-1 -1
|
||||
(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
|
||||
(if multi-mode? (/ WIDTH 2) WIDTH) 300
|
||||
() wx:const-needed-sb)]
|
||||
|
||||
[save-panel (when save-mode? (make-object mred:container:horizontal-panel% main-panel))]
|
||||
|
||||
[directory-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
|
||||
[directory-edit (make-object (class-asi mred:edit:media-edit%
|
||||
(rename [super-on-local-char on-local-char])
|
||||
(public
|
||||
|
|
@ -292,12 +451,14 @@
|
|||
[code (send key get-key-code)])
|
||||
(if (or (= code cr-code)
|
||||
(= code lf-code))
|
||||
(do-go)
|
||||
(do-ok)
|
||||
(super-on-local-char key))))])))]
|
||||
|
||||
[period-panel (when (eq? 'unix wx:platform)
|
||||
[dot-panel (when (eq? 'unix wx:platform)
|
||||
(make-object mred:container:horizontal-panel% main-panel))]
|
||||
|
||||
[bottom-panel (make-object mred:container:horizontal-panel% main-panel)]
|
||||
|
||||
[result-list
|
||||
(when multi-mode?
|
||||
(make-object mred:container:list-box%
|
||||
|
|
@ -307,51 +468,60 @@
|
|||
wx:const-extended
|
||||
wx:const-multiple)
|
||||
-1 -1
|
||||
(* 1/2 WIDTH) 300
|
||||
(/ WIDTH 2) 300
|
||||
() wx:const-needed-sb))]
|
||||
[add-panel (when multi-mode? (make-object mred:container:horizontal-panel% left-middle-panel))]
|
||||
[remove-panel (when multi-mode? (make-object mred:container:horizontal-panel% right-middle-panel))]
|
||||
[do-go
|
||||
(lambda ()
|
||||
(let ([t (send directory-edit get-text)])
|
||||
(cond
|
||||
[(file-exists? t)
|
||||
(set-box! result-box (mzlib:file:normalize-path t))
|
||||
(show #f)]
|
||||
[(directory-exists? t)
|
||||
(set-directory (mzlib:file:normalize-path t))]
|
||||
[else (wx:message-box (format "~a doesn't exist" t))])))])
|
||||
[add-panel
|
||||
(when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% left-middle-panel))]
|
||||
|
||||
[remove-panel
|
||||
(when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% right-middle-panel))]
|
||||
|
||||
[do-updir
|
||||
(lambda ()
|
||||
(set-directory (build-updir current-dir)))
|
||||
])
|
||||
|
||||
(sequence
|
||||
|
||||
(when (eq? wx:platform 'unix)
|
||||
(make-object mred:container:check-box% period-panel
|
||||
(make-object mred:container:check-box% dot-panel
|
||||
do-period-in/exclusion
|
||||
"Show files and directories that begin with a period")
|
||||
(send period-panel stretchable-in-y #f))
|
||||
"Show files and directories that begin with a dot")
|
||||
(send dot-panel stretchable-in-y #f))
|
||||
|
||||
(send directory-panel stretchable-in-y #f)
|
||||
|
||||
(let ([canvas (make-object mred:canvas:one-line-canvas% directory-panel -1 -1 -1 20 ""
|
||||
(+ wx:const-mcanvas-hide-h-scroll
|
||||
wx:const-mcanvas-hide-v-scroll))])
|
||||
|
||||
(send* canvas
|
||||
(set-media directory-edit)
|
||||
(set-focus)
|
||||
(user-min-height 20)))
|
||||
(make-object mred:container:button% directory-panel
|
||||
(lambda (button evt) (do-go))
|
||||
"Go")
|
||||
(set-media directory-edit)
|
||||
(set-focus)
|
||||
(user-min-height 20)))
|
||||
|
||||
(when multi-mode?
|
||||
(send add-panel stretchable-in-y #f)
|
||||
(send remove-panel stretchable-in-y #f)
|
||||
(send result-list stretchable-in-x #t))
|
||||
(send add-panel stretchable-in-y #f)
|
||||
(send remove-panel stretchable-in-y #f)
|
||||
(send result-list stretchable-in-x #t))
|
||||
|
||||
(make-object mred:container:button% top-panel
|
||||
(lambda (button evt) (do-updir))
|
||||
"Up")
|
||||
|
||||
(send name-list stretchable-in-x #t)
|
||||
|
||||
(send top-panel stretchable-in-y #f)
|
||||
|
||||
(send bottom-panel stretchable-in-y #f)
|
||||
|
||||
(when save-mode?
|
||||
(send save-panel stretchable-in-y #f)))
|
||||
|
||||
(private
|
||||
|
||||
[name-field
|
||||
(when save-mode?
|
||||
(let* ([% (class-asi mred:container:text%
|
||||
|
|
@ -370,10 +540,7 @@
|
|||
(send v set-value start-name))
|
||||
(new-line)
|
||||
v))]
|
||||
[into-dir-button
|
||||
(when save-mode?
|
||||
(make-object mred:container:button%
|
||||
save-panel do-into-dir "Open Directory"))]
|
||||
|
||||
[add-button (when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% add-panel)
|
||||
(make-object mred:container:button%
|
||||
|
|
@ -383,7 +550,7 @@
|
|||
(begin0
|
||||
(make-object mred:container:button%
|
||||
add-panel do-add-all
|
||||
"Add All")
|
||||
"Add all")
|
||||
(make-object mred:container:horizontal-panel% add-panel)))]
|
||||
[remove-button (when multi-mode?
|
||||
(make-object mred:container:horizontal-panel% remove-panel)
|
||||
|
|
@ -418,15 +585,17 @@
|
|||
|
||||
(show #t))))
|
||||
|
||||
; make-common takes a dialog function
|
||||
|
||||
(define make-common
|
||||
(lambda (box-value make-dialog)
|
||||
(lambda (make-dialog)
|
||||
(let ([s (make-semaphore 1)]
|
||||
[v (box box-value)]
|
||||
[d #f])
|
||||
[v (box #f)]
|
||||
[d #f]) ; d is a flag, what does it mean?
|
||||
(lambda x
|
||||
(semaphore-wait s)
|
||||
(if d
|
||||
(let ([my-d d]
|
||||
(if d
|
||||
(let ([my-d d] ; this case isn't used currently
|
||||
[my-v v])
|
||||
(set! d #f)
|
||||
(set! v #f)
|
||||
|
|
@ -439,54 +608,92 @@
|
|||
(semaphore-post s)))
|
||||
(begin
|
||||
(semaphore-post s)
|
||||
(let* ([my-v (box box-value)]
|
||||
(let* ([my-v (box #f)]
|
||||
[my-d (apply make-dialog my-v x)])
|
||||
(semaphore-wait s)
|
||||
(unless d
|
||||
(unless d ; I don't understand this, since d, v not used - PAS
|
||||
(set! d my-d)
|
||||
(set! v my-v))
|
||||
(begin0 (unbox my-v)
|
||||
(semaphore-post s)))))))))
|
||||
|
||||
; the common versions of these functions have their visual
|
||||
; interfaces under Scheme control
|
||||
|
||||
(define common-put-file
|
||||
(make-common
|
||||
#f
|
||||
(opt-lambda (box
|
||||
[name ()][directory ()][replace? #f]
|
||||
[prompt "Select File"][filter #f]
|
||||
[filter-msg "That name does not have the right form"])
|
||||
(let* ([directory (if (and (null? directory)
|
||||
(string? name))
|
||||
(or (mzlib:file:path-only name) null)
|
||||
directory)]
|
||||
[name (or (and (string? name)
|
||||
(mzlib:file:file-name-from-path name))
|
||||
name)])
|
||||
(make-object finder-dialog% #t replace? #f box
|
||||
directory name prompt filter filter-msg)))))
|
||||
[parent-win null]
|
||||
[name ()]
|
||||
[directory ()]
|
||||
[replace? #f]
|
||||
[prompt "Select file"]
|
||||
[filter #f]
|
||||
[filter-msg "Invalid form"])
|
||||
(let* ([directory (if (and (null? directory)
|
||||
(string? name))
|
||||
(or (mzlib:file:path-only name) null)
|
||||
directory)]
|
||||
[name (or (and (string? name)
|
||||
(mzlib:file:file-name-from-path name))
|
||||
name)])
|
||||
(make-object finder-dialog%
|
||||
parent-win
|
||||
#t
|
||||
replace?
|
||||
#f
|
||||
box
|
||||
directory
|
||||
name
|
||||
prompt
|
||||
filter
|
||||
filter-msg)))))
|
||||
|
||||
(define common-get-file
|
||||
(define common-get-file
|
||||
(make-common
|
||||
#f
|
||||
(opt-lambda
|
||||
(box [directory ()][prompt "Select File"][filter #f]
|
||||
(box [parent-win null]
|
||||
[directory ()]
|
||||
[prompt "Select file"]
|
||||
[filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(make-object finder-dialog% #f #f #f box directory '() prompt
|
||||
filter filter-msg))))
|
||||
(make-object finder-dialog%
|
||||
parent-win ; parent window
|
||||
#f ; save-mode?
|
||||
#f ; replace-ok?
|
||||
#f ; multi-mode?
|
||||
box ; result-box
|
||||
directory ; start-dir
|
||||
'() ; start-name
|
||||
prompt ; prompt
|
||||
filter ; file-filter
|
||||
filter-msg ; file-filter-msg
|
||||
))))
|
||||
|
||||
(define common-get-file-list
|
||||
(make-common
|
||||
null
|
||||
(opt-lambda (box [directory ()][prompt "Select Files"][filter #f]
|
||||
(opt-lambda (box [directory ()][prompt "Select files"][filter #f]
|
||||
[filter-msg "Bad name"])
|
||||
(make-object finder-dialog% #f #f #t box directory '() prompt
|
||||
filter filter-msg))))
|
||||
|
||||
; the std- versions of these functions rely on wx: for their
|
||||
; visible interfaces
|
||||
|
||||
; 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?
|
||||
|
||||
(define std-put-file
|
||||
(opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
|
||||
[filter #f]
|
||||
[filter-msg
|
||||
"That filename does not have the right form."])
|
||||
(opt-lambda ([name ()]
|
||||
[directory ()]
|
||||
[replace? #f]
|
||||
[prompt "Select file"]
|
||||
[filter #f]
|
||||
[filter-msg "That filename does not have the right form."]
|
||||
|
||||
; quick-and-dirty solution ... probably should be first arg
|
||||
|
||||
[parent-win null])
|
||||
(let* ([directory (if (and (null? directory)
|
||||
(string? name))
|
||||
(or (mzlib:file:path-only name) null)
|
||||
|
|
@ -494,12 +701,14 @@
|
|||
[name (or (and (string? name)
|
||||
(mzlib:file:file-name-from-path name))
|
||||
name)]
|
||||
[f (wx:file-selector prompt directory name
|
||||
'()
|
||||
(if (eq? wx:platform 'windows)
|
||||
"*.*"
|
||||
"*")
|
||||
wx:const-save)])
|
||||
[f (wx:file-selector
|
||||
prompt
|
||||
directory
|
||||
name
|
||||
'()
|
||||
(if (eq? wx:platform 'windows) "*.*" "*")
|
||||
wx:const-save
|
||||
parent-win)])
|
||||
(if (or (null? f)
|
||||
(and filter
|
||||
(not (filter-match? filter
|
||||
|
|
@ -519,10 +728,22 @@
|
|||
[else f]))))))
|
||||
|
||||
(define std-get-file
|
||||
(opt-lambda ([directory ()][prompt "Select File"][filter #f]
|
||||
[filter-msg
|
||||
"That filename does not have the right form."])
|
||||
(let ([f (wx:file-selector prompt directory)])
|
||||
(opt-lambda ([directory ()]
|
||||
[prompt "Select file"]
|
||||
[filter #f]
|
||||
[filter-msg "That filename does not have the right form."]
|
||||
|
||||
; quick-and-dirty solution ... probably should be 1st arg
|
||||
|
||||
[parent-win null])
|
||||
(let ([f (wx:file-selector
|
||||
prompt
|
||||
directory
|
||||
null
|
||||
null
|
||||
"*"
|
||||
0
|
||||
parent-win)])
|
||||
(if (null? f)
|
||||
#f
|
||||
(if (or (not filter) (filter-match? filter f filter-msg))
|
||||
|
|
@ -533,7 +754,7 @@
|
|||
"That is a directory name.")
|
||||
#f]
|
||||
[(not (file-exists? f))
|
||||
(wx:message-box "That file does not exist.")
|
||||
(wx:message-box "File does not exist.")
|
||||
#f]
|
||||
[else f]))
|
||||
#f)))))
|
||||
|
|
@ -546,15 +767,23 @@
|
|||
(or (eq? x 'common)
|
||||
(eq? x 'std))))
|
||||
|
||||
; external interfaces to file functions
|
||||
|
||||
(define put-file
|
||||
(lambda args
|
||||
(apply (case (mred:preferences:get-preference 'mred:file-dialogs)
|
||||
(let ([actual-fun
|
||||
(case (mred:preferences:get-preference 'mred:file-dialogs)
|
||||
[(std) std-put-file]
|
||||
[(common) common-put-file])
|
||||
args)))
|
||||
[(common) common-put-file])])
|
||||
(apply actual-fun args))))
|
||||
|
||||
(define get-file
|
||||
(lambda args
|
||||
(apply (case (mred:preferences:get-preference 'mred:file-dialogs)
|
||||
(let ([actual-fun
|
||||
(case (mred:preferences:get-preference 'mred:file-dialogs)
|
||||
[(std) std-get-file]
|
||||
[(common) common-get-file])
|
||||
args))))
|
||||
[(common) common-get-file])])
|
||||
(apply actual-fun args)))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user