346 lines
11 KiB
Scheme
346 lines
11 KiB
Scheme
;;This addition provides a directory-tree-browsing-functionality.
|
|
;;This means:
|
|
;;When using it you hand over a list of strings, that shall be
|
|
;;interpreted as paths and a string that represents the path, relative to
|
|
;;which the path-list is given.
|
|
;;In the result-window of the NUIT a file-browsing screen is shown
|
|
;;which you can browse in using arrow-keys and enter. You can also
|
|
;;select some items and paste them into the upper window.
|
|
|
|
;;If there are paths to files handed over that do not exist, they will not be
|
|
;;displayed in the browser!
|
|
|
|
;;If the given path does not exist you will not be able to navigate!
|
|
|
|
(define key-m 109)
|
|
(define key-u 117)
|
|
|
|
(define-record-type browse-dir-list-res-obj browse-dir-list-res-obj
|
|
(make-browse-dir-list-res-obj pos-y
|
|
pos-x
|
|
file-list
|
|
result-text
|
|
working-directory
|
|
width
|
|
initial-wd
|
|
marked-items
|
|
res-marked-items
|
|
c-x-pressed)
|
|
browse-dir-list-res-obj?
|
|
(pos-y browse-dir-list-res-obj-pos-y)
|
|
(pos-x browse-dir-list-res-obj-pos-x)
|
|
(file-list browse-dir-list-res-obj-file-list)
|
|
(result-text browse-dir-list-res-obj-result-text)
|
|
(working-directory browse-dir-list-res-obj-working-directory)
|
|
(width browse-dir-list-res-obj-width)
|
|
(initial-wd browse-dir-list-res-obj-initial-wd)
|
|
(marked-items browse-dir-list-res-obj-marked-items)
|
|
(res-marked-items browse-dir-list-res-obj-res-marked-items)
|
|
(c-x-pressed browse-dir-list-res-obj-c-x-pressed))
|
|
|
|
(define (layout-dir-list files wdir width)
|
|
(let ((marked-files (mark-special-files wdir files)))
|
|
(append
|
|
(list
|
|
(if (<= (string-length wdir) (- width 25))
|
|
(string-append "Paths relative to " wdir " :")
|
|
(let ((dir-string (substring wdir
|
|
(- (string-length wdir)
|
|
(- width 25))
|
|
(string-length wdir))))
|
|
(string-append "Paths relative to ..."
|
|
dir-string))))
|
|
marked-files)))
|
|
|
|
(define (mark-special-files dir files)
|
|
(map (lambda (file)
|
|
(let ((complete-name (string-append dir "/" file)))
|
|
(cond
|
|
((file-directory? complete-name)
|
|
(string-append " " file "/"))
|
|
((file-executable? complete-name)
|
|
(string-append "*" file))
|
|
((file-symlink? complete-name)
|
|
(string-append "@" file))
|
|
(else
|
|
(string-append " " file)))))
|
|
files))
|
|
|
|
;;selection->descend
|
|
(define selected-browse-dir-list
|
|
(lambda (model)
|
|
(let ((ln (browse-dir-list-res-obj-pos-y model))
|
|
(wd (browse-dir-list-res-obj-working-directory model)))
|
|
(if (not (file-exists? wd))
|
|
model
|
|
(begin (chdir wd)
|
|
(if (or (>= ln (+ (length
|
|
(browse-dir-list-res-obj-result-text model)) 1))
|
|
(<= ln 1))
|
|
model
|
|
(if (= ln 2)
|
|
(if (not (equal? "/" (cwd)))
|
|
(begin
|
|
(chdir "..")
|
|
(let* ((new-result (directory-files))
|
|
(width (browse-dir-list-res-obj-width model))
|
|
(new-text (layout-dir-list
|
|
new-result (cwd) width))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
2
|
|
1
|
|
new-result
|
|
new-text
|
|
(cwd)
|
|
width
|
|
(browse-dir-list-res-obj-initial-wd
|
|
model)
|
|
(browse-dir-list-res-obj-marked-items
|
|
model)
|
|
(browse-dir-list-res-obj-res-marked-items
|
|
model)
|
|
(browse-dir-list-res-obj-c-x-pressed
|
|
model))))
|
|
new-model))
|
|
model)
|
|
(let* ((text (browse-dir-list-res-obj-result-text model))
|
|
(ent (list-ref text (- ln 1)))
|
|
(len (string-length ent))
|
|
(last-char (substring ent (- len 1) len))
|
|
(rest (substring ent 1 (- len 1))))
|
|
(if (equal? last-char "/")
|
|
(begin
|
|
(chdir wd)
|
|
(chdir rest)
|
|
(let* ((new-result (directory-files))
|
|
(width (browse-dir-list-res-obj-width model))
|
|
(new-text (layout-dir-list
|
|
new-result (cwd) width))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
2
|
|
1
|
|
new-result
|
|
new-text
|
|
(cwd)
|
|
width
|
|
(browse-dir-list-res-obj-initial-wd
|
|
model)
|
|
(browse-dir-list-res-obj-marked-items
|
|
model)
|
|
(browse-dir-list-res-obj-res-marked-items
|
|
model)
|
|
(browse-dir-list-res-obj-c-x-pressed model))))
|
|
new-model))
|
|
model)))))))))
|
|
|
|
(define (init-with-list-of-files files dir width)
|
|
(make-browse-dir-list-res-obj
|
|
2 1
|
|
files (layout-dir-list files dir width) dir
|
|
width (cwd) '() '() #f))
|
|
|
|
(define browse-dir-list-receiver
|
|
(lambda (message)
|
|
(debug-message "browse-dir-list-receiver " message)
|
|
(cond
|
|
|
|
((init-with-result-message? message)
|
|
(let ((fs-objects (init-with-result-message-result message)))
|
|
(init-with-list-of-files
|
|
(map fs-object-name fs-objects) (cwd)
|
|
(result-buffer-num-cols
|
|
(init-with-result-message-buffer message)))))
|
|
|
|
((next-command-message? message)
|
|
(init-with-list-of-files (directory-files) (cwd)))
|
|
|
|
((print-message? message)
|
|
(let* ((model (message-result-object message))
|
|
(pos-y (browse-dir-list-res-obj-pos-y model))
|
|
(pos-x (browse-dir-list-res-obj-pos-x model))
|
|
(text (browse-dir-list-res-obj-result-text model))
|
|
(marked-pos (get-marked-positions-3
|
|
(browse-dir-list-res-obj-file-list model)
|
|
(browse-dir-list-res-obj-marked-items model))))
|
|
(debug-message "browse-dir-list-receiver "
|
|
"pos-y " pos-y " pos-x " pos-x
|
|
" marked-pos " marked-pos)
|
|
(make-simple-result-buffer-printer
|
|
pos-y pos-x text (list pos-y) marked-pos)))
|
|
|
|
((key-pressed-message? message)
|
|
(let* ((model (message-result-object message))
|
|
(key (key-pressed-message-key message))
|
|
(c-x-pressed (browse-dir-list-res-obj-c-x-pressed model)))
|
|
|
|
(cond
|
|
|
|
;; user pressed 'm' --- mark current entry
|
|
((= key key-m)
|
|
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
|
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
|
model))
|
|
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
|
(all-items (browse-dir-list-res-obj-file-list model)))
|
|
(if (<= actual-pos 2)
|
|
model
|
|
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
|
(actual-res-item
|
|
(if (not (string=? (cwd) "/"))
|
|
(string-append (cwd) "/" actual-item)
|
|
(string-append "/" actual-item))))
|
|
(if (member actual-res-item marked-items)
|
|
model
|
|
(let* ((new-res-marked-items (append res-marked-items
|
|
(list
|
|
actual-res-item)))
|
|
(new-marked-items (append marked-items
|
|
(list actual-item)))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
(browse-dir-list-res-obj-pos-y model)
|
|
(browse-dir-list-res-obj-pos-x model)
|
|
(browse-dir-list-res-obj-file-list
|
|
model)
|
|
(browse-dir-list-res-obj-result-text
|
|
model)
|
|
(browse-dir-list-res-obj-working-directory
|
|
model)
|
|
(browse-dir-list-res-obj-width model)
|
|
(browse-dir-list-res-obj-initial-wd
|
|
model)
|
|
new-marked-items
|
|
new-res-marked-items
|
|
#f)))
|
|
new-model))))))
|
|
|
|
;; user pressed 'u' --- unmark current entry
|
|
((= key key-u)
|
|
(let* ((marked-items (browse-dir-list-res-obj-marked-items model))
|
|
(res-marked-items (browse-dir-list-res-obj-res-marked-items
|
|
model))
|
|
(actual-pos (browse-dir-list-res-obj-pos-y model))
|
|
(all-items (browse-dir-list-res-obj-file-list model)))
|
|
(if (<= actual-pos 2)
|
|
model
|
|
(let* ((actual-item (list-ref all-items (- actual-pos 3)))
|
|
(actual-res-item (string-append (cwd) "/" actual-item))
|
|
(rest (member actual-item marked-items))
|
|
(res-rest (member actual-res-item res-marked-items)))
|
|
(if (not res-rest)
|
|
model
|
|
(let* ((after-item (length rest))
|
|
(all-items (length marked-items))
|
|
(before-item (sublist marked-items
|
|
0
|
|
(- all-items
|
|
after-item )))
|
|
(new-marked-items (append before-item
|
|
(list-tail rest 1)))
|
|
(after-res-item (length res-rest))
|
|
(all-res-items (length res-marked-items))
|
|
(before-res-item (sublist res-marked-items
|
|
0
|
|
(- all-res-items
|
|
after-res-item)))
|
|
(new-res-marked-items (append before-res-item
|
|
(list-tail res-rest
|
|
1)))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
(browse-dir-list-res-obj-pos-y model)
|
|
(browse-dir-list-res-obj-pos-x model)
|
|
(browse-dir-list-res-obj-file-list
|
|
model)
|
|
(browse-dir-list-res-obj-result-text
|
|
model)
|
|
(browse-dir-list-res-obj-working-directory
|
|
model)
|
|
(browse-dir-list-res-obj-width model)
|
|
(browse-dir-list-res-obj-initial-wd
|
|
model)
|
|
new-marked-items
|
|
new-res-marked-items
|
|
#f)))
|
|
new-model))))))
|
|
|
|
((= key key-up)
|
|
(let ((posy (browse-dir-list-res-obj-pos-y model)))
|
|
(if (<= posy 2)
|
|
model
|
|
(let* ((new-posy (- posy 1))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
new-posy
|
|
(browse-dir-list-res-obj-pos-x model)
|
|
(browse-dir-list-res-obj-file-list model)
|
|
(browse-dir-list-res-obj-result-text model)
|
|
(browse-dir-list-res-obj-working-directory
|
|
model)
|
|
(browse-dir-list-res-obj-width model)
|
|
(browse-dir-list-res-obj-initial-wd model)
|
|
(browse-dir-list-res-obj-marked-items model)
|
|
(browse-dir-list-res-obj-res-marked-items
|
|
model)
|
|
#f)))
|
|
new-model))))
|
|
|
|
((= key key-down)
|
|
(let ((posy (browse-dir-list-res-obj-pos-y model))
|
|
(num-lines (length
|
|
(browse-dir-list-res-obj-result-text model))))
|
|
(if (>= posy num-lines)
|
|
model
|
|
(let* ((new-posy (+ posy 1))
|
|
(new-model (make-browse-dir-list-res-obj
|
|
new-posy
|
|
(browse-dir-list-res-obj-pos-x model)
|
|
(browse-dir-list-res-obj-file-list model)
|
|
(browse-dir-list-res-obj-result-text model)
|
|
(browse-dir-list-res-obj-working-directory
|
|
model)
|
|
(browse-dir-list-res-obj-width model)
|
|
(browse-dir-list-res-obj-initial-wd model)
|
|
(browse-dir-list-res-obj-marked-items model)
|
|
(browse-dir-list-res-obj-res-marked-items
|
|
model)
|
|
#f)))
|
|
new-model))))
|
|
|
|
((= key 10)
|
|
(selected-browse-dir-list model))
|
|
|
|
;; user pressed C-x
|
|
((= key 24)
|
|
(make-browse-dir-list-res-obj
|
|
(browse-dir-list-res-obj-pos-y model)
|
|
(browse-dir-list-res-obj-pos-x model)
|
|
(browse-dir-list-res-obj-file-list model)
|
|
(browse-dir-list-res-obj-result-text model)
|
|
(browse-dir-list-res-obj-working-directory
|
|
model)
|
|
(browse-dir-list-res-obj-width model)
|
|
(browse-dir-list-res-obj-initial-wd model)
|
|
(browse-dir-list-res-obj-marked-items model)
|
|
(browse-dir-list-res-obj-res-marked-items
|
|
model)
|
|
(not c-x-pressed)))
|
|
|
|
(else model))))
|
|
|
|
|
|
((restore-message? message)
|
|
(let* ((model (message-result-object message))
|
|
(initial-wd (browse-dir-list-res-obj-initial-wd model)))
|
|
(chdir initial-wd)))
|
|
|
|
((selection-message? message)
|
|
(let* ((model (message-result-object message))
|
|
(marked-items (browse-dir-list-res-obj-res-marked-items model)))
|
|
(string-append "'" (exp->string marked-items)))))))
|
|
|
|
(define (list-of-fs-objects? thing)
|
|
(and (proper-list? thing)
|
|
(every fs-object? thing)))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin browse-dir-list-receiver
|
|
list-of-fs-objects?))
|