Fix a few bugs in fsobjects-viewer
This commit is contained in:
parent
0cb71508ef
commit
ddf1ca752b
|
@ -65,11 +65,6 @@
|
|||
(paint-selection-list-at select-list 1 2 win
|
||||
buffer have-focus?))
|
||||
|
||||
(define (make-browser-for-dir instance dir)
|
||||
(let ((new-instance (make-fsobjects-viewer)))
|
||||
(send new-instance 'init-browser-for-dir
|
||||
dir (send instance 'get-buffer))))
|
||||
|
||||
(define (find-common-parent paths)
|
||||
(if (null? paths)
|
||||
""
|
||||
|
@ -99,7 +94,7 @@
|
|||
(let* ((maybe-parent
|
||||
(file-name-directory (send instance 'get-working-dir)))
|
||||
(parent (if (string=? maybe-parent "") "/" maybe-parent)))
|
||||
(make-browser-for-dir instance parent)))
|
||||
(make-browser-for-dir parent (send instance 'get-buffer))))
|
||||
(else
|
||||
(let ((fi (fs-object-info selected-entry)))
|
||||
(if (and fi (file-info-directory? fi))
|
||||
|
@ -109,8 +104,8 @@
|
|||
(display packet)
|
||||
(newline)
|
||||
instance))
|
||||
(make-browser-for-dir instance
|
||||
(fs-object-complete-path selected-entry)))
|
||||
(make-browser-for-dir (fs-object-complete-path selected-entry)
|
||||
(send instance 'get-buffer)))
|
||||
instance)))))
|
||||
|
||||
(define (handle-key-press instance key)
|
||||
|
@ -126,58 +121,52 @@
|
|||
(select-list-handle-key-press select-list key))
|
||||
instance))))
|
||||
|
||||
(define (make-fsobjects-viewer fs-objects buffer)
|
||||
(let* ((fs-objects fs-objects)
|
||||
(buffer buffer)
|
||||
(working-dir (find-common-parent
|
||||
(map fs-object-path fs-objects)))
|
||||
(select-list
|
||||
(make-file-select-list fs-objects
|
||||
working-dir
|
||||
(result-buffer-num-lines buffer))))
|
||||
(define (make-browser-for-dir dir buffer)
|
||||
(with-cwd dir
|
||||
(make-fsobjects-viewer (directory-files)
|
||||
buffer
|
||||
(cwd))))
|
||||
|
||||
(lambda (message)
|
||||
(cond
|
||||
(define (make-fsobjects-viewer fs-objects buffer . maybe-parent)
|
||||
(let-optionals maybe-parent
|
||||
((working-dir (find-common-parent
|
||||
(map fs-object-path fs-objects))))
|
||||
(let ((fs-objects fs-objects)
|
||||
(buffer buffer)
|
||||
(select-list
|
||||
(make-file-select-list fs-objects
|
||||
working-dir
|
||||
(- (result-buffer-num-lines buffer) 2))))
|
||||
|
||||
((eq? message 'init-browser-for-dir)
|
||||
(lambda (self new-dir new-buffer)
|
||||
(with-cwd new-dir
|
||||
(let ((new-fs-objects (directory-files)))
|
||||
(set! buffer new-buffer)
|
||||
(set! fs-objects new-fs-objects)
|
||||
(set! working-dir new-dir)
|
||||
(set! select-list
|
||||
(make-file-select-list
|
||||
fs-objects (cwd) (result-buffer-num-lines new-buffer)))
|
||||
self))))
|
||||
(lambda (message)
|
||||
(cond
|
||||
((eq? message 'paint)
|
||||
(lambda (self . args)
|
||||
(apply paint-browser
|
||||
(append (list select-list working-dir) args))))
|
||||
|
||||
((eq? message 'paint)
|
||||
(lambda (self . args)
|
||||
(apply paint-browser
|
||||
(append (list select-list working-dir) args))))
|
||||
((eq? message 'key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(handle-key-press self key)))
|
||||
|
||||
((eq? message 'key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(handle-key-press self key)))
|
||||
((eq? message 'get-select-list)
|
||||
(lambda (self)
|
||||
select-list))
|
||||
|
||||
((eq? message 'get-select-list)
|
||||
(lambda (self)
|
||||
select-list))
|
||||
((eq? message 'set-select-list!)
|
||||
(lambda (self new-select-list)
|
||||
(set! select-list new-select-list)))
|
||||
|
||||
((eq? message 'set-select-list!)
|
||||
(lambda (self new-select-list)
|
||||
(set! select-list new-select-list)))
|
||||
((eq? message 'get-buffer)
|
||||
(lambda (self)
|
||||
buffer))
|
||||
|
||||
((eq? message 'get-buffer)
|
||||
(lambda (self)
|
||||
buffer))
|
||||
((eq? message 'get-working-dir)
|
||||
(lambda (self)
|
||||
working-dir))
|
||||
|
||||
((eq? message 'get-working-dir)
|
||||
(lambda (self)
|
||||
working-dir))
|
||||
|
||||
(else
|
||||
(error "fsobjects-viewer unknown message" message))))))
|
||||
(else
|
||||
(error "fsobjects-viewer unknown message" message))))))))
|
||||
|
||||
(define (list-of-fs-objects? thing)
|
||||
(and (proper-list? thing)
|
||||
|
|
|
@ -107,6 +107,7 @@
|
|||
srfi-1
|
||||
(subset srfi-13 (string-copy string-drop string-prefix-length))
|
||||
signals
|
||||
let-opt
|
||||
|
||||
objects
|
||||
layout
|
||||
|
|
Loading…
Reference in New Issue