;;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-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)) ;;Layout of the directory-tree-browser (define layout-result-browse-dir-list (lambda (result-str result width directory) (begin (let ((printed-file-list (print-file-list-1 result directory)) (heading "")) (begin (if (<= (string-length directory) (- width 25)) (set! heading (string-append "Paths relative to " directory " :")) (let ((dir-string (substring directory (- (string-length directory) (- width 25)) (string-length directory)))) (set! heading (string-append "Paths relative to ..." dir-string)))) (append (list heading) (list " <-") printed-file-list)))))) ;;One File per-line ;;In case the object is a directory "/" is added (define print-file-list-1 (lambda (file-list dir) (let loop ((old file-list) (new '())) (if (equal? '() old) new (let* ((hd (list-ref old 0)) (hd-path (string-append dir "/" hd)) (tl (cdr old))) (if (file-exists? hd-path) (if (file-directory? hd-path) (let ((new-str (string-append " " hd "/"))) (loop tl (append new (list new-str)))) (loop tl (append new (list (string-append " " hd))))) (loop tl new))))))) ;;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 (evaluate "(directory-files)")) (new-result-string (exp->string new-result)) (width (browse-dir-list-res-obj-width model)) (new-text (layout-result-browse-dir-list new-result-string new-result width (cwd))) (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 (evaluate "(directory-files)")) (new-result-string (exp->string new-result)) (width (browse-dir-list-res-obj-width model)) (new-text (layout-result-browse-dir-list new-result-string new-result width (cwd))) (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 browse-dir-list-receiver (lambda (message) (cond ((next-command-message? message) (let* ((command (next-command-string message)) (parameters (next-command-message-parameters message)) (result #f) (width (next-command-message-width message))) (if (< (length parameters) 2) (begin (set! result (list "forgot parameters?")) (let* ((text (layout-result-standard "forgot parameters?" result width)) (browse-obj (make-browse-dir-list-res-obj 1 1 result text (cwd) width (cwd) '() '() #f))) browse-obj)) (let* ((file-list (evaluate (list-ref parameters 0))) (dir (evaluate (list-ref parameters 1))) (result-string (exp->string file-list)) (width (next-command-message-width message)) (text (layout-result-browse-dir-list result-string file-list width dir)) (browse-obj (make-browse-dir-list-res-obj 2 1 file-list text dir width (cwd) '() '() #f))) browse-obj)))) ((print-message? message) (let* ((model (print-message-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)))) (make-print-object pos-y pos-x text (list pos-y) marked-pos))) ((key-pressed-message? message) (let* ((model (key-pressed-message-result-model message)) (key (key-pressed-message-key message)) (c-x-pressed (browse-dir-list-res-obj-c-x-pressed model))) (if c-x-pressed (cond ;;Ctrl+x s -> Auswahl ((= key 115) (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 #f)) (begin (if (not (equal? (cwd) "/")) (set! actual-res-item (string-append (cwd) "/" actual-item)) (set! actual-res-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))))))) ;;Ctrl+x u -> unselect ((= key 117) (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)))))) (else (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)))) (cond ;;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))) ((= 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)) (else model))))) ((restore-message? message) (let* ((model (restore-message-object message)) (initial-wd (browse-dir-list-res-obj-initial-wd model))) (chdir initial-wd))) ((selection-message? message) (let* ((model (selection-message-object message)) (marked-items (browse-dir-list-res-obj-res-marked-items model))) (string-append "'" (exp->string marked-items))))))) (define browse-dir-list-rec (make-receiver "browse-dir-list" browse-dir-list-receiver)) (set! receivers (cons browse-dir-list-rec receivers))