reorganize code to make it easier to improve the unix file dialog
svn: r3063
This commit is contained in:
Eli Barzilay
parent
6f6516e9db
commit
479db765e7
206
collects/mred/private/file-getter.ss
Normal file
206
collects/mred/private/file-getter.ss
Normal file
|
|
@ -0,0 +1,206 @@
|
|||
(module file-getter mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(prefix wx: "kernel.ss")
|
||||
"helper.ss"
|
||||
"mrtop.ss"
|
||||
"mritem.ss"
|
||||
"mrpanel.ss"
|
||||
"mrtextfield.ss"
|
||||
"messagebox.ss")
|
||||
(provide file-getter)
|
||||
|
||||
(define last-visted-directory #f)
|
||||
|
||||
(define (file-getter put? multi? dir? message parent directory filename)
|
||||
(define ok? #f)
|
||||
(define typed-name #f)
|
||||
(define dir
|
||||
(or (and directory
|
||||
(if (string? directory) (string->path directory) directory))
|
||||
last-visted-directory
|
||||
(current-directory)))
|
||||
(define f
|
||||
(make-object dialog%
|
||||
(if dir? "Select Directory" (if put? "Save" "Open")) parent 500 300))
|
||||
(define __
|
||||
(when message
|
||||
(let ([p (make-object vertical-pane% f)])
|
||||
(send p stretchable-height #f)
|
||||
(make-object message% (protect& message) p))))
|
||||
(define dir-pane (instantiate horizontal-pane% (f) (stretchable-height #f)))
|
||||
(define m (make-object message% (protect& (path->string dir)) dir-pane))
|
||||
(define lp (make-object horizontal-pane% f))
|
||||
(define (change-dir d)
|
||||
(let ([sd (send d get-string-selection)])
|
||||
(when sd
|
||||
(set! dir (simplify-path (build-path dir sd)))
|
||||
(reset-directory))))
|
||||
(define dirs
|
||||
(make-object
|
||||
(class list-box%
|
||||
(define/override (on-subwindow-char w e)
|
||||
(cond [(and (send e get-meta-down) (eq? (send e get-key-code) 'down))
|
||||
(change-dir w)]
|
||||
[(and (send e get-meta-down) (eq? (send e get-key-code) 'up))
|
||||
(send dirs set-selection 0)
|
||||
(change-dir dirs)]
|
||||
[else (super on-subwindow-char w e)]))
|
||||
(super-instantiate ()))
|
||||
#f null lp
|
||||
(lambda (d e)
|
||||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick) (change-dir d)))))
|
||||
(define dir-paths null)
|
||||
(define files
|
||||
(make-object
|
||||
list-box% #f null lp
|
||||
(lambda (d e)
|
||||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick) (done)))
|
||||
(if multi? '(multiple) '(single))))
|
||||
(define file-paths null)
|
||||
(define (do-text-name)
|
||||
(let ([v (send dir-text get-value)])
|
||||
(if (or dir? (directory-exists? v))
|
||||
(begin (set! dir (string->path v)) (reset-directory))
|
||||
;; Maybe specifies a file:
|
||||
(let-values ([(super file)
|
||||
(with-handlers ([void #f])
|
||||
(let-values ([(base name dir?) (split-path v)])
|
||||
(let ([super (and (not dir?)
|
||||
(or (and (path? base)
|
||||
(directory-exists? base)
|
||||
base)
|
||||
(and (eq? base 'relative)
|
||||
(directory-exists? dir)
|
||||
dir)))])
|
||||
(if super
|
||||
(values super name)
|
||||
(values #f #f)))))])
|
||||
(if super
|
||||
(begin (set! dir super) (set! typed-name file) (done))
|
||||
(begin (set! dir (string->path v)) (reset-directory)))))))
|
||||
(define dir-text
|
||||
(make-object text-field% #f f
|
||||
(lambda (t e)
|
||||
(if (eq? (send e get-event-type) 'text-field-enter)
|
||||
(do-text-name)
|
||||
(begin ; typing in the box; disable the lists and enable ok
|
||||
(send dirs enable #f)
|
||||
(send files enable #f)
|
||||
(when create-button
|
||||
(send create-button enable #t))
|
||||
(send ok-button enable #t))))))
|
||||
(define bp (make-object horizontal-pane% f))
|
||||
(define dot-check
|
||||
(make-object check-box% "Show files/directories that start with \".\"" bp
|
||||
(lambda (b e) (reset-directory))))
|
||||
(define spacer (make-object vertical-pane% bp))
|
||||
(define create-button
|
||||
(and dir?
|
||||
(make-object button% "Create" bp
|
||||
(lambda (b e)
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
(message-box "Error"
|
||||
(exn-message exn)
|
||||
f
|
||||
'(ok stop)))])
|
||||
(make-directory (send dir-text get-value))
|
||||
(do-text-name))))))
|
||||
(define cancel-button
|
||||
(make-object button% "Cancel" bp
|
||||
(lambda (b e) (set! ok? #f) (send f show #f))))
|
||||
(define ok-button
|
||||
(make-object button% (if dir? "Goto" "OK") bp
|
||||
(lambda (b e)
|
||||
(if (send (if dir? dirs files) is-enabled?)
|
||||
;; normal mode
|
||||
(if dir?
|
||||
(change-dir dirs)
|
||||
(done))
|
||||
;; handle typed text
|
||||
(do-text-name)))
|
||||
'(border)))
|
||||
(define (update-ok)
|
||||
(send ok-button enable
|
||||
(not (null? (send (if dir? dirs files) get-selections)))))
|
||||
(define select-this-dir
|
||||
(and dir? (make-object button% "<- &Select" dir-pane
|
||||
(lambda (b e) (send f show #f) (done)))))
|
||||
(define (path-string-locale<? p1 p2)
|
||||
(string-locale<? (path->string p1) (path->string p2)))
|
||||
(define (reset-directory)
|
||||
(wx:begin-busy-cursor)
|
||||
(let ([dir-exists? (directory-exists? dir)])
|
||||
(send m set-label
|
||||
(protect&
|
||||
(if dir-exists?
|
||||
(begin (unless directory (set! last-visted-directory dir))
|
||||
(path->string dir))
|
||||
(string-append "BAD DIRECTORY: " (path->string dir)))))
|
||||
(when select-this-dir (send select-this-dir enable dir-exists?))
|
||||
(when create-button (send create-button enable (not dir-exists?))))
|
||||
(send dir-text set-value (path->string dir))
|
||||
(let ([l (with-handlers ([void (lambda (x) null)]) (directory-list dir))]
|
||||
[dot? (send dot-check get-value)])
|
||||
(let-values ([(ds fs)
|
||||
(let loop ([l l][ds null][fs null])
|
||||
(cond
|
||||
[(null? l)
|
||||
(values (cons (string->path "..")
|
||||
(sort ds path-string-locale<?))
|
||||
(sort fs path-string-locale<?))]
|
||||
[(and (not dot?)
|
||||
(char=? (string-ref (path->string (car l)) 0)
|
||||
#\.))
|
||||
(loop (cdr l) ds fs)]
|
||||
[(file-exists? (build-path dir (car l)))
|
||||
(loop (cdr l) ds (cons (car l) fs))]
|
||||
[else (loop (cdr l) (cons (car l) ds) fs)]))])
|
||||
(set! dir-paths ds)
|
||||
(send dirs set (map path->string ds))
|
||||
(set! file-paths fs)
|
||||
(send files set (map path->string fs))
|
||||
(send dirs enable #t)
|
||||
(unless dir?
|
||||
(send files enable #t))
|
||||
(update-ok)
|
||||
(wx:end-busy-cursor))))
|
||||
(define (get-filename)
|
||||
(if dir?
|
||||
dir
|
||||
(let* ([mk (lambda (f) (simplify-path (build-path dir f)))]
|
||||
[l (map mk (if typed-name
|
||||
(list typed-name)
|
||||
(map (lambda (p)
|
||||
(list-ref (if dir? dir-paths file-paths) p))
|
||||
(send (if dir? dirs files) get-selections))))])
|
||||
(if multi? l (car l)))))
|
||||
(define (done)
|
||||
(let ([name (get-filename)])
|
||||
(unless (and put? (file-exists? name)
|
||||
(eq? (message-box
|
||||
"Warning"
|
||||
(format "Replace ~s?" (path->string name))
|
||||
f '(yes-no))
|
||||
'no)
|
||||
(set! typed-name #f))
|
||||
(set! ok? #t)
|
||||
(send f show #f))))
|
||||
(send bp stretchable-height #f)
|
||||
(send m stretchable-width #t)
|
||||
(reset-directory)
|
||||
(when filename
|
||||
(when (string? filename)
|
||||
(set! filename (string->path filename)))
|
||||
(let ([d (send dir-text get-value)])
|
||||
(send dir-text set-value (path->string (build-path d filename)))
|
||||
(set! typed-name filename)
|
||||
(send ok-button enable #t)))
|
||||
(when put? (send dir-text focus))
|
||||
(when dir? (send files enable #f))
|
||||
(send f center)
|
||||
(send f show #t)
|
||||
(and ok? (get-filename))))
|
||||
|
|
@ -1,31 +1,19 @@
|
|||
(module filedialog mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "class100.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(prefix wx: "kernel.ss")
|
||||
"lock.ss"
|
||||
"wx.ss"
|
||||
"cycle.ss"
|
||||
"check.ss"
|
||||
"helper.ss"
|
||||
"editor.ss"
|
||||
"mrtop.ss"
|
||||
"mrcanvas.ss"
|
||||
"mrpopup.ss"
|
||||
"mrmenu.ss"
|
||||
"mritem.ss"
|
||||
"mrpanel.ss"
|
||||
"mrtextfield.ss"
|
||||
"messagebox.ss")
|
||||
"file-getter.ss")
|
||||
|
||||
(provide get-file
|
||||
get-file-list
|
||||
put-file
|
||||
get-directory)
|
||||
|
||||
(define last-visted-directory #f)
|
||||
|
||||
(define (files->list s)
|
||||
(let ([s (open-input-bytes s)])
|
||||
(let loop ()
|
||||
|
|
@ -57,265 +45,47 @@
|
|||
(string? (cadr p))))
|
||||
filters))
|
||||
(raise-type-error who "list of 2-string lists" filters))
|
||||
(if (not (or (eq? (system-type) 'unix)
|
||||
force-unix?))
|
||||
(let ([s (wx:file-selector message directory filename extension
|
||||
;; file types:
|
||||
(apply string-append
|
||||
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
|
||||
filters))
|
||||
;; style:
|
||||
(cons
|
||||
(cond
|
||||
[dir? 'dir]
|
||||
[put? 'put]
|
||||
[multi? 'multi]
|
||||
[else 'get])
|
||||
style)
|
||||
;; parent:
|
||||
(and parent (mred->wx parent)))])
|
||||
(if (and multi? s)
|
||||
(map bytes->path (files->list (path->bytes s)))
|
||||
s))
|
||||
(letrec ([ok? #f]
|
||||
[typed-name #f]
|
||||
[dir (or (and directory (if (string? directory)
|
||||
(string->path directory)
|
||||
directory))
|
||||
last-visted-directory
|
||||
(current-directory))]
|
||||
[f (make-object dialog% (if dir? "Select Directory" (if put? "Save" "Open")) parent 500 300)]
|
||||
[__ (when message
|
||||
(let ([p (make-object vertical-pane% f)])
|
||||
(send p stretchable-height #f)
|
||||
(make-object message% (protect& message) p)))]
|
||||
[dir-pane (instantiate horizontal-pane% (f) (stretchable-height #f))]
|
||||
[m (make-object message% (protect& (path->string dir)) dir-pane)]
|
||||
[lp (make-object horizontal-pane% f)]
|
||||
[change-dir (lambda (d) (let ([sd (send d get-string-selection)])
|
||||
(when sd
|
||||
(set! dir (simplify-path (build-path dir sd)))
|
||||
(reset-directory))))]
|
||||
[dirs (make-object (class list-box%
|
||||
(define/override (on-subwindow-char w e)
|
||||
(cond
|
||||
[(and (send e get-meta-down)
|
||||
(eq? (send e get-key-code) 'down))
|
||||
(change-dir w)]
|
||||
[(and (send e get-meta-down)
|
||||
(eq? (send e get-key-code) 'up))
|
||||
(send dirs set-selection 0)
|
||||
(change-dir dirs)]
|
||||
[else
|
||||
(super on-subwindow-char w e)]))
|
||||
(super-instantiate ()))
|
||||
#f null lp (lambda (d e)
|
||||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(change-dir d))))]
|
||||
[dir-paths null]
|
||||
[files (make-object list-box% #f null lp (lambda (d e)
|
||||
(update-ok)
|
||||
(when (eq? (send e get-event-type) 'list-box-dclick)
|
||||
(done)))
|
||||
(if multi? '(multiple) '(single)))]
|
||||
[file-paths null]
|
||||
[do-text-name (lambda ()
|
||||
(let ([v (send dir-text get-value)])
|
||||
(if (or dir? (directory-exists? v))
|
||||
(begin
|
||||
(set! dir (string->path v))
|
||||
(reset-directory))
|
||||
;; Maybe specifies a file:
|
||||
(let-values ([(super file)
|
||||
(with-handlers ([void #f])
|
||||
(let-values ([(base name dir?) (split-path v)])
|
||||
(let ([super (and (not dir?)
|
||||
(or (and (path? base)
|
||||
(directory-exists? base)
|
||||
base)
|
||||
(and (eq? base 'relative)
|
||||
(directory-exists? dir) dir)))])
|
||||
(if super
|
||||
(values super name)
|
||||
(values #f #f)))))])
|
||||
(if super
|
||||
(begin
|
||||
(set! dir super)
|
||||
(set! typed-name file)
|
||||
(done))
|
||||
(begin
|
||||
(set! dir (string->path v))
|
||||
(reset-directory)))))))]
|
||||
[dir-text (make-object text-field% #f f (lambda (t e)
|
||||
(if (eq? (send e get-event-type) 'text-field-enter)
|
||||
(do-text-name)
|
||||
(begin
|
||||
; typing in the box; disable the lists and enable ok
|
||||
(send dirs enable #f)
|
||||
(send files enable #f)
|
||||
(when create-button
|
||||
(send create-button enable #t))
|
||||
(send ok-button enable #t)))))]
|
||||
[bp (make-object horizontal-pane% f)]
|
||||
[dot-check (make-object check-box% "Show files/directories that start with \".\"" bp (lambda (b e) (reset-directory)))]
|
||||
[spacer (make-object vertical-pane% bp)]
|
||||
[create-button (and dir? (make-object button% "Create" bp
|
||||
(lambda (b e)
|
||||
(with-handlers ([void
|
||||
(lambda (exn)
|
||||
(message-box "Error"
|
||||
(exn-message exn)
|
||||
f
|
||||
'(ok stop)))])
|
||||
(make-directory (send dir-text get-value))
|
||||
(do-text-name)))))]
|
||||
[cancel-button (make-object button% "Cancel" bp (lambda (b e) (set! ok? #f) (send f show #f)))]
|
||||
[ok-button (make-object button%
|
||||
(if dir? "Goto" "OK")
|
||||
bp (lambda (b e)
|
||||
(if (send (if dir? dirs files) is-enabled?)
|
||||
;; normal mode
|
||||
(if dir?
|
||||
(change-dir dirs)
|
||||
(done))
|
||||
;; handle typed text
|
||||
(do-text-name)))
|
||||
'(border))]
|
||||
[update-ok (lambda () (send ok-button enable (not (null? (send (if dir? dirs files) get-selections)))))]
|
||||
[select-this-dir (and dir?
|
||||
(make-object button% "<- &Select" dir-pane
|
||||
(lambda (b e)
|
||||
(send f show #f)
|
||||
(done))))]
|
||||
[path-string-locale<? (lambda (p1 p2)
|
||||
(string-locale<? (path->string p1) (path->string p2)))]
|
||||
[reset-directory (lambda ()
|
||||
(wx:begin-busy-cursor)
|
||||
(let ([dir-exists? (directory-exists? dir)])
|
||||
(send m set-label (protect&
|
||||
(if dir-exists?
|
||||
(begin
|
||||
(unless directory
|
||||
(set! last-visted-directory dir))
|
||||
(path->string dir))
|
||||
(string-append "BAD DIRECTORY: " (path->string dir)))))
|
||||
(when select-this-dir
|
||||
(send select-this-dir enable dir-exists?))
|
||||
(when create-button
|
||||
(send create-button enable (not dir-exists?))))
|
||||
(send dir-text set-value (path->string dir))
|
||||
(let ([l (with-handlers ([void (lambda (x) null)])
|
||||
(directory-list dir))]
|
||||
[dot? (send dot-check get-value)])
|
||||
(let-values ([(ds fs)
|
||||
(let loop ([l l][ds null][fs null])
|
||||
(cond
|
||||
[(null? l) (values (cons (string->path "..")
|
||||
(sort ds path-string-locale<?))
|
||||
(sort fs path-string-locale<?))]
|
||||
[(and (not dot?)
|
||||
(char=? (string-ref (path->string (car l)) 0) #\.))
|
||||
(loop (cdr l) ds fs)]
|
||||
[(file-exists? (build-path dir (car l))) (loop (cdr l) ds (cons (car l) fs))]
|
||||
[else (loop (cdr l) (cons (car l) ds) fs)]))])
|
||||
(set! dir-paths ds)
|
||||
(send dirs set (map path->string ds))
|
||||
(set! file-paths fs)
|
||||
(send files set (map path->string fs))
|
||||
(send dirs enable #t)
|
||||
(unless dir?
|
||||
(send files enable #t))
|
||||
(update-ok)
|
||||
(wx:end-busy-cursor))))]
|
||||
[get-filename (lambda ()
|
||||
(if dir?
|
||||
dir
|
||||
(let ([mk (lambda (f) (simplify-path (build-path dir f)))])
|
||||
(let ([l (map mk (if typed-name
|
||||
(list typed-name)
|
||||
(map (lambda (p) (list-ref (if dir? dir-paths file-paths) p))
|
||||
(send (if dir? dirs files) get-selections))))])
|
||||
(if multi? l (car l))))))]
|
||||
[done (lambda ()
|
||||
(let ([name (get-filename)])
|
||||
(unless (and put? (file-exists? name)
|
||||
(eq? (message-box "Warning"
|
||||
(format "Replace ~s?" (path->string name) )
|
||||
f '(yes-no))
|
||||
'no)
|
||||
(set! typed-name #f))
|
||||
(set! ok? #t)
|
||||
(send f show #f))))])
|
||||
(send bp stretchable-height #f)
|
||||
(send m stretchable-width #t)
|
||||
(reset-directory)
|
||||
(when filename
|
||||
(when (string? filename)
|
||||
(set! filename (string->path filename)))
|
||||
(let ([d (send dir-text get-value)])
|
||||
(send dir-text set-value (path->string (build-path d filename)))
|
||||
(set! typed-name filename)
|
||||
(send ok-button enable #t)))
|
||||
(when put?
|
||||
(send dir-text focus))
|
||||
(when dir?
|
||||
(send files enable #f))
|
||||
(send f center)
|
||||
(send f show #t)
|
||||
(and ok? (get-filename))))))
|
||||
|
||||
; We duplicate the case-lambda for `get-file', `get-file-list', and `put-file' so that they have the
|
||||
; right arities and names
|
||||
(if (or (eq? (system-type) 'unix) force-unix?)
|
||||
(file-getter put? multi? dir? message parent directory filename)
|
||||
(let ([s (wx:file-selector
|
||||
message directory filename extension
|
||||
;; file types:
|
||||
(apply string-append
|
||||
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
|
||||
filters))
|
||||
;; style:
|
||||
(cons (cond [dir? 'dir]
|
||||
[put? 'put]
|
||||
[multi? 'multi]
|
||||
[else 'get])
|
||||
style)
|
||||
;; parent:
|
||||
(and parent (mred->wx parent)))])
|
||||
(if (and multi? s)
|
||||
(map bytes->path (files->list (path->bytes s)))
|
||||
s)))))
|
||||
|
||||
(define default-filters '(("Any" "*.*")))
|
||||
|
||||
(define get-file
|
||||
(case-lambda
|
||||
[() (get-file #f #f #f #f #f null)]
|
||||
[(message) (get-file message #f #f #f #f null)]
|
||||
[(message parent) (get-file message parent #f #f #f null)]
|
||||
[(message parent directory) (get-file message parent directory #f #f null)]
|
||||
[(message parent directory filename) (get-file message parent directory filename #f null)]
|
||||
[(message parent directory filename extension) (get-file message parent directory filename extension null)]
|
||||
[(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 #f) message parent directory filename extension style filters)]))
|
||||
;; We duplicate the case-lambda for `get-file', `get-file-list', and
|
||||
;; `put-file' so that they have the right arities and names
|
||||
|
||||
(define get-file-list
|
||||
(case-lambda
|
||||
[() (get-file-list #f #f #f #f #f null)]
|
||||
[(message) (get-file-list message #f #f #f #f null)]
|
||||
[(message parent) (get-file-list message parent #f #f #f null)]
|
||||
[(message parent directory) (get-file-list message parent directory #f #f null)]
|
||||
[(message parent directory filename) (get-file-list message parent directory filename #f null)]
|
||||
[(message parent directory filename extension) (get-file-list message parent directory filename extension null)]
|
||||
[(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 #f) message parent directory filename extension style filters)]))
|
||||
(define-syntax define-file-selector
|
||||
(syntax-rules ()
|
||||
[(_ name put? multi?)
|
||||
(define name
|
||||
(opt-lambda ([message #f] [parent #f] [directory #f] [filename #f]
|
||||
[extension #f] [style null] [filters default-filters])
|
||||
((mk-file-selector 'name put? multi? #f #f)
|
||||
message parent directory filename extension style filters)))]))
|
||||
|
||||
(define put-file
|
||||
(case-lambda
|
||||
[() (put-file #f #f #f #f #f null)]
|
||||
[(message) (put-file message #f #f #f #f null)]
|
||||
[(message parent) (put-file message parent #f #f #f null)]
|
||||
[(message parent directory) (put-file message parent directory #f #f null)]
|
||||
[(message parent directory filename) (put-file message parent directory filename #f null)]
|
||||
[(message parent directory filename extension) (put-file message parent directory filename extension null)]
|
||||
[(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 #f) message parent directory filename extension style filters)]))
|
||||
(define-file-selector get-file #f #f)
|
||||
(define-file-selector get-file-list #f #t)
|
||||
(define-file-selector put-file #t #f)
|
||||
|
||||
(define get-directory
|
||||
(case-lambda
|
||||
[() (get-directory #f #f #f null)]
|
||||
[(message) (get-directory message #f #f null)]
|
||||
[(message parent) (get-directory message parent #f null)]
|
||||
[(message parent directory) (get-directory message parent directory null)]
|
||||
[(message parent directory style)
|
||||
((mk-file-selector 'get-directory #f #f #t #f) message parent directory #f #f style null)]))
|
||||
(opt-lambda ([message #f] [parent #f] [directory #f] [style null])
|
||||
((mk-file-selector 'get-directory #f #f #t #f)
|
||||
message parent directory #f #f style null)))
|
||||
|
||||
(set-get-file! get-file))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user