Sorting for file-system viewer
part of darcs patch Mon Sep 19 21:06:27 EEST 2005 Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel
parent
f9e74ee38b
commit
40e260f78d
|
|
@ -1,3 +1,6 @@
|
|||
(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)
|
||||
|
|
@ -21,19 +24,25 @@
|
|||
|
||||
(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
|
||||
(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
|
||||
|
|
@ -69,6 +78,18 @@
|
|||
(- (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)
|
||||
|
|
@ -80,8 +101,7 @@
|
|||
(fill-up-string
|
||||
30 (add-marks-to-special-file file-name fsobject))
|
||||
" "
|
||||
(fill-up-string
|
||||
7 (format-size (file-info:size fi)))
|
||||
(right-align-string 7 (format-size (file-info:size fi)))
|
||||
" "
|
||||
(format-user/group fi)
|
||||
" "
|
||||
|
|
@ -117,12 +137,13 @@
|
|||
wdir (- width (string-length header-line-path)))
|
||||
"<unknown>")))
|
||||
|
||||
(define (paint-browser select-list wdir win buffer have-focus?)
|
||||
(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
|
||||
buffer have-focus?))
|
||||
|
||||
|
|
@ -162,11 +183,12 @@
|
|||
(let ((fs-objects fs-objects)
|
||||
(buffer buffer)
|
||||
(select-list
|
||||
(make-file-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))))
|
||||
(result-buffer-num-cols buffer)))
|
||||
(select-line (make-file-select-line)))
|
||||
|
||||
(define (handle-return-key self selected-entry num-lines)
|
||||
(cond
|
||||
|
|
@ -187,16 +209,63 @@
|
|||
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)))
|
||||
(else
|
||||
((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)))
|
||||
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)))
|
||||
|
|
@ -233,9 +302,9 @@
|
|||
(lambda (message)
|
||||
(cond
|
||||
((eq? message 'paint)
|
||||
(lambda (self . args)
|
||||
(apply paint-browser
|
||||
(append (list select-list working-dir) args))))
|
||||
(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?)
|
||||
|
|
|
|||
|
|
@ -217,13 +217,16 @@
|
|||
string-drop-right string-prefix-length))
|
||||
signals
|
||||
let-opt
|
||||
sorting
|
||||
|
||||
configuration
|
||||
focus-table
|
||||
objects
|
||||
layout
|
||||
utils
|
||||
fs-object
|
||||
select-list
|
||||
select-line
|
||||
select-element
|
||||
plugin
|
||||
ncurses
|
||||
|
|
|
|||
Loading…
Reference in New Issue