;;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?))