265 lines
7.7 KiB
Scheme
265 lines
7.7 KiB
Scheme
(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
|
|
(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 (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))
|
|
" "
|
|
(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 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 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 select-list wdir 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-selection-list-at select-list 1 2 win
|
|
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
|
|
(- (result-buffer-num-lines buffer) 2)
|
|
(result-buffer-num-cols buffer))))
|
|
|
|
(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 (handle-key-press self key)
|
|
(cond
|
|
((= key key-return)
|
|
(handle-return-key
|
|
self (select-list-selected-entry select-list)
|
|
(calculate-number-of-lines buffer)))
|
|
(else
|
|
(set! select-list
|
|
(select-list-handle-key-press select-list key))
|
|
self)))
|
|
|
|
(define (prepare-selection-for-scheme-mode file-names)
|
|
(string-append "'" (exp->string file-names)))
|
|
|
|
(define (prepare-selection-for-command-mode file-names)
|
|
(string-join
|
|
(map (lambda (file-name)
|
|
(string-append "\"" file-name "\""))
|
|
file-names)))
|
|
|
|
(define (get-selection self for-scheme-mode?)
|
|
(let* ((marked (select-list-get-selection 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 (make-focus-object-reference table obj)
|
|
(let ((id (add-focus-object table obj)))
|
|
`(focus-value ,id)))
|
|
|
|
(define (get-focus-object self focus-object-table)
|
|
(let ((marked (select-list-get-selection select-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(if (null? marked)
|
|
(exp->string
|
|
(make-reference (select-list-selected-entry select-list)))
|
|
(string-append
|
|
"(list "
|
|
(string-join (map exp->string (map make-reference marked)))
|
|
")"))))
|
|
|
|
(lambda (message)
|
|
(cond
|
|
((eq? message 'paint)
|
|
(lambda (self . args)
|
|
(apply paint-browser
|
|
(append (list select-list working-dir) args))))
|
|
|
|
((eq? message 'key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(handle-key-press self key)))
|
|
|
|
((eq? message 'get-selection)
|
|
get-selection)
|
|
|
|
((eq? message 'get-focus-object)
|
|
get-focus-object)
|
|
|
|
(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
|
|
list-of-fs-objects?))
|