diff --git a/scheme/browse-directory-list.scm b/scheme/browse-directory-list.scm index 231b548..9b98b52 100644 --- a/scheme/browse-directory-list.scm +++ b/scheme/browse-directory-list.scm @@ -16,25 +16,98 @@ (else (string-append " " file-name))))) +(define (have-permission? mode perm-mask) + (not (zero? (bitwise-and mode perm-mask)))) + +(define (format-permissions mode) + (apply string-append + (map (lambda (mask.symbol) + (if (have-permission? mode (car mask.symbol)) + (cdr mask.symbol) + "-")) + '((#o0400 . "r") ;; owner read + (#o0200 . "w") ;; owner write + (#o0100 . "x") ;; owner exec + (#o0040 . "r") ;; group read + (#o0020 . "w") ;; group write + (#o0010 . "x") ;; group exec + (#o0004 . "r") ;; others read + (#o0002 . "w") ;; others write + (#o0001 . "x"))))) ;; others exec + +(define (digits-left-of-comma-as-string float) + (string-drop-right + (number->string (truncate float)) 1)) + +(define (format-size/unit float unit) + (string-append (digits-left-of-comma-as-string float) " " unit)) + +(define (format-size bytes) + (let* ((kbyte 1024.0) + (mbyte (* 1024 kbyte)) + (gbyte (* 1024 mbyte))) + (cond + ((>= bytes gbyte) + (format-size/unit (/ bytes gbyte) "GB")) + ((>= bytes mbyte) + (format-size/unit (/ bytes mbyte) "MB")) + ((>= bytes kbyte) + (format-size/unit (/ bytes kbyte) "KB")) + (else + (number->string bytes))))) + +(define (format-user/group fi) + (fill-up-string 17 + (string-append + (cut-to-size 8 (->username (file-info:uid fi))) + ":" + (cut-to-size 8 (group-info:name + (group-info (file-info:gid fi))))))) + +(define (fill-up-string length string) + (if (> (string-length string) length) + (substring string 0 length) + (string-append + string (make-string (- length (string-length string)) + #\space)))) + +(define (cut-to-size length string) + (if (> (string-length string) length) + (substring string 0 length) + string)) + ;; leave one line for the heading (define (calculate-number-of-lines result-buffer) (- (result-buffer-num-lines result-buffer) 1)) -(define (layout-fsobject parent-dir-len fsobject) +(define (layout-fsobject parent-dir-len fsobject num-cols) (let ((file-name (combine-path (string-drop (fs-object-path fsobject) parent-dir-len) - (fs-object-name fsobject)))) - (add-marks-to-special-file file-name fsobject))) + (fs-object-name fsobject))) + (fi (fs-object-info fsobject))) + (cut-to-size num-cols + (string-append + (fill-up-string + 30 (add-marks-to-special-file file-name fsobject)) + " " + (fill-up-string + 7 (format-size (file-info:size fi))) + " " + (format-user/group fi) + " " + (format-permissions + (file-info:mode fi)))))) -(define (make-file-select-list fsobjects parent-dir num-lines) +(define (make-file-select-list fsobjects parent-dir num-lines num-cols) (let ((parent-dir-len (string-length parent-dir))) (make-select-list (cons (make-unmarked-element 'parent-dir #f " ..") (map (lambda (fs-object) (make-unmarked-element - fs-object #t (layout-fsobject parent-dir-len fs-object))) + fs-object #t (layout-fsobject parent-dir-len + fs-object num-cols))) fsobjects)) num-lines))) @@ -134,9 +207,10 @@ (let ((fs-objects fs-objects) (buffer buffer) (select-list - (make-file-select-list fs-objects - working-dir - (- (result-buffer-num-lines buffer) 2)))) + (make-file-select-list + fs-objects working-dir + (- (result-buffer-num-lines buffer) 2) + (result-buffer-num-cols buffer)))) (lambda (message) (cond diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index fad5459..47af7e6 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -108,7 +108,9 @@ make-fsobjects-viewer) (open (modify nuit-eval (hide string-copy)) srfi-1 - (subset srfi-13 (string-copy string-drop string-prefix-length)) + (subset srfi-13 + (string-copy string-drop + string-drop-right string-prefix-length)) signals let-opt