373 lines
12 KiB
Scheme
373 lines
12 KiB
Scheme
(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 (->username/save uid/name)
|
|
(with-fatal-error-handler
|
|
(lambda (condition more)
|
|
(if (number? uid/name)
|
|
(number->string uid/name)
|
|
uid/name))
|
|
(->username uid/name)))
|
|
|
|
(define (->groupname/save gid/name)
|
|
(with-fatal-error-handler
|
|
(lambda (condition more)
|
|
(if (number? gid/name)
|
|
(number->string gid/name)
|
|
gid/name))
|
|
(->groupname gid/name)))
|
|
|
|
(define (format-user/group fi)
|
|
(fill-up-string 17
|
|
(string-append
|
|
(cut-to-size 8 (->username/save (file-info:uid fi)))
|
|
":"
|
|
(cut-to-size 8 (->groupname/save (file-info:gid fi))))))
|
|
|
|
(define today (date))
|
|
|
|
(define (format-time t)
|
|
(let ((d (date t)))
|
|
(if (= (date:year today)
|
|
(date:year d))
|
|
(format-date/wo-year d)
|
|
(format-date/w-year d))))
|
|
|
|
(define (format-date/w-year d)
|
|
(format-date "~b ~d ~Y" d))
|
|
|
|
(define (format-date/wo-year d)
|
|
(format-date "~b ~d ~H:~M" d))
|
|
|
|
;; 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 "))
|
|
(make-unmarked-text-element 'mtime #f
|
|
(left-align-string 13 " Mod time")))))
|
|
|
|
|
|
(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))
|
|
" "
|
|
(format-time
|
|
(file-info:mtime 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 (file-name->fs-object ".")
|
|
#t " .")
|
|
(cons (make-unmarked-text-element
|
|
(file-name->fs-object "..")
|
|
#t " ..")
|
|
(map (lambda (fs-object)
|
|
(make-unmarked-text-element
|
|
fs-object #t (layout-fsobject parent-dir-len
|
|
fs-object num-cols)))
|
|
fsobjects)))
|
|
num-lines
|
|
(if (null? fsobjects) 1 2))))
|
|
|
|
;;; 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)
|
|
(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 sort-up-key (config 'ls 'sort-up-key))
|
|
(define sort-down-key (config 'ls 'sort-down-key))
|
|
|
|
(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 sort-up-key)
|
|
(= key 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)))))
|
|
((mtime)
|
|
(values <
|
|
>
|
|
(lambda (fso)
|
|
(file-info:mtime (fs-object-info fso)))))
|
|
(else
|
|
(error "unknown column" column)))
|
|
(let ((compare (if (= key 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))))
|
|
|