(define-option 'ls 'sort-up-key (char->ascii #\s))
(define-option 'ls 'sort-down-key (char->ascii #\S))
(define key-m 109)
(define key-u 117)
(define key-return 10)
(define (add-marks-to-special-file file-name fs-object)
(let ((info (fs-object-info fs-object)))
(cond
((not info)
(string-append " " file-name ": error during file-info!"))
((file-info-directory? info)
(string-append " " file-name "/"))
((file-info-executable? info)
(string-append "*" file-name))
((file-info-symlink? info)
(string-append "@" file-name))
(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
(cons
(cond
((have-permission? mode #o1000) "t") ; sticky
((have-permission? mode #o2000) "s") ; setgit
((have-permission? mode #o4000) "s") ; setuid
(else "-"))
(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)))))))
;; leave one line for the heading
(define (calculate-number-of-lines result-buffer)
(- (result-buffer-num-lines result-buffer)
1))
(define (make-file-select-line)
(make-select-line
(list
(make-unmarked-text-element 'file-name #f
(left-align-string 31 "File name"))
(make-unmarked-text-element 'size #f
(right-align-string 8 "Size "))
(make-unmarked-text-element 'user/group #f
(left-align-string 18 "User:Group "))
(make-unmarked-text-element 'mode #f (left-align-string 10 "Mode ")))))
(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)))
(fi (fs-object-info fsobject)))
(cut-to-size num-cols
(string-append
(fill-up-string
30 (add-marks-to-special-file file-name fsobject))
" "
(right-align-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 num-cols)
(let ((parent-dir-len (string-length parent-dir)))
(make-select-list
(cons (make-unmarked-text-element 'parent-dir #f " ..")
(map (lambda (fs-object)
(make-unmarked-text-element
fs-object #t (layout-fsobject parent-dir-len
fs-object num-cols)))
fsobjects))
num-lines)))
;;; lacks some coolness
(define (abbrev-path path length)
(if (< (string-length path) length)
path
(string-copy path
(- (string-length path) length))))
(define header-line-path
"Paths relative to ")
(define (make-header-line wdir width)
(string-append
header-line-path
(if wdir
(abbrev-path
wdir (- width (string-length header-line-path)))
"<unknown>")))
(define (paint-browser wdir select-line select-list win buffer have-focus?)
(wattron win (A-BOLD))
(mvwaddstr win 0 0
(make-header-line
wdir (result-buffer-num-cols buffer)))
(wattrset win (A-NORMAL))
(paint-select-line-at select-line 1 1 win buffer)
(paint-selection-list-at select-list 1 2 win
(result-buffer-num-cols buffer) have-focus?))
(define (find-common-parent paths)
(if (null? paths)
""
(let lp ((paths (cdr paths))
(common (car paths))
(common-len (string-length (car paths))))
(if (null? paths)
common
(let ((prefix-len (string-prefix-length common (car paths))))
(cond
((= 0 prefix-len) (error "no prefix??" common (car paths)))
((= 1 prefix-len) "/") ; search ends here
((= prefix-len common-len) ; short cut
(lp (cdr paths)
common
common-len))
(else
(lp (cdr paths)
(substring common
0
prefix-len)
prefix-len))))))))
(define (make-browser-for-dir dir buffer)
(with-cwd dir
(make-fsobjects-viewer (directory-files)
buffer
(cwd))))
(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
;; we need one line for the header
(- (result-buffer-num-lines buffer) 1)
(result-buffer-num-cols buffer)))
(select-line (make-file-select-line)))
(define (handle-return-key self selected-entry num-lines)
(cond
((eq? selected-entry 'parent-dir)
(let* ((maybe-parent (file-name-directory working-dir))
(parent (if (string=? maybe-parent "") "/" maybe-parent)))
(make-browser-for-dir parent buffer)))
(else
(let ((fi (fs-object-info selected-entry)))
(if (and fi (file-info-directory? fi))
(with-errno-handler
((errno packet)
(else
(display packet)
(newline)
self))
(make-browser-for-dir (fs-object-complete-path selected-entry)
buffer))
self)))))
(define (set-fs-objects! new-fs-objects)
(set! fs-objects new-fs-objects)
(set! select-list
(make-file-select-list
fs-objects working-dir
;; we need one line for the header
(- (result-buffer-num-lines buffer) 1)
(result-buffer-num-cols buffer))))
(define (handle-key-press self key)
(cond
((= key key-return)
(handle-return-key
self (select-list-selected-entry select-list)
(calculate-number-of-lines buffer)))
((or (= key (config 'ls 'sort-up-key))
(= key (config 'ls 'sort-down-key)))
(let ((column (select-line-selected-entry select-line)))
(receive (compare-up compare-down select)
(case column
((file-name)
;; TODO: use path stripped by parent
(values string<? string>? fs-object-complete-path))
((size)
(values <
>
(lambda (fso)
(file-info:size (fs-object-info fso)))))
((user/group)
(values string<?
string>?
(lambda (fso)
(format-user/group (fs-object-info fso)))))
((mode)
(values <
>
(lambda (fso)
(file-info:mode (fs-object-info fso)))))
(else
(error "unknown column" column)))
(let ((compare (if (= key (config 'ls 'sort-up-key))
compare-up
compare-down)))
(set-fs-objects!
(list-sort
(lambda (p1 p2)
(compare (select p1) (select p2)))
fs-objects))
self))))
((select-list-key? key)
(set! select-list
(select-list-handle-key-press select-list key))
self)
((select-line-key? key)
(select-line-handle-key-press! select-line key)
self)
(else self)))
(define (prepare-selection-for-scheme-mode file-names)
(string-append "'" (write-to-string file-names)))
;; FIXME: quote file names containing space etc
(define (prepare-selection-for-command-mode file-names)
(string-join file-names))
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
(let* ((marked (select-list-get-marked select-list))
(file-names
(map fs-object-complete-path
(if (null? marked)
(list (select-list-selected-entry select-list))
marked))))
((if for-scheme-mode?
prepare-selection-for-scheme-mode
prepare-selection-for-command-mode)
file-names)))
(define (get-selection-as-ref self focus-object-table)
(let ((marked (select-list-get-marked select-list))
(make-reference (lambda (obj)
(make-focus-object-reference
focus-object-table obj))))
(if (null? marked)
(write-to-string
(make-reference (select-list-selected-entry select-list)))
(string-append
"(list "
(string-join (map write-to-string (map make-reference marked)))
")"))))
(lambda (message)
(cond
((eq? message 'paint)
(lambda (self win buffer have-focus?)
(paint-browser working-dir select-line select-list
win buffer have-focus?)))
((eq? message 'key-press)
(lambda (self key control-x-pressed?)
(handle-key-press self key)))
((eq? message 'get-selection-as-text)
get-selection-as-text)
((eq? message 'get-selection-as-ref)
get-selection-as-ref)
(else
(error "fsobjects-viewer unknown message" message)))))))
(define (list-of-fs-objects? thing)
(and (proper-list? thing)
(every fs-object? thing)))
(register-plugin!
(make-view-plugin make-fsobjects-viewer
(lambda (thing)
(list-of-fs-objects? thing))))