scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix a few bugs in fsobjects-viewer

This commit is contained in:
mainzelm 2005-05-31 14:54:48 +00:00
parent 0cb71508ef
commit ddf1ca752b
2 changed files with 43 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
scheme/browse-directory-list.scm
View File

@ -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)
@ -125,59 +120,53 @@
(send instance 'set-select-list!
(select-list-handle-key-press select-list key))
instance))))
(define (make-browser-for-dir dir buffer)
(with-cwd dir
(make-fsobjects-viewer (directory-files)
buffer
(cwd))))
(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-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))))
(lambda (message)
(cond
(lambda (message)
(cond
((eq? message 'paint)
(lambda (self . args)
(apply paint-browser
(append (list select-list working-dir) args))))
((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))))
((eq? message 'key-press)
(lambda (self key control-x-pressed?)
(handle-key-press self key)))
((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 '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)

1
scheme/nuit-packages.scm
View File

@ -107,6 +107,7 @@
srfi-1
(subset srfi-13 (string-copy string-drop string-prefix-length))
signals
let-opt
objects
layout