New painting for select-line, new sorting for processes (by column)
part of darcs patch Sun Sep 18 21:31:38 EEST 2005 Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel
parent
4fbe6c5e51
commit
2b9854c8ff
|
|
@ -349,6 +349,7 @@
|
|||
|
||||
select-element
|
||||
(subset focus-table (make-focus-object-reference))
|
||||
layout
|
||||
tty-debug
|
||||
utils
|
||||
ncurses)
|
||||
|
|
|
|||
|
|
@ -2,15 +2,14 @@
|
|||
(and (proper-list? thing)
|
||||
(every process-info? thing)))
|
||||
|
||||
(define (make-header-line width)
|
||||
(define (make-header-line)
|
||||
(make-select-line
|
||||
(list
|
||||
(right-align-string 6 "PID ")
|
||||
(right-align-string 6 "PPID ")
|
||||
(left-align-string 9 "USER ")
|
||||
(right-align-string 6 "TIME ")
|
||||
"COMMAND")
|
||||
width))
|
||||
(make-unmarked-text-element 'pid #f (right-align-string 6 "PID "))
|
||||
(make-unmarked-text-element 'ppid #f (right-align-string 6 "PPID "))
|
||||
(make-unmarked-text-element 'user #f (left-align-string 9 "USER "))
|
||||
(make-unmarked-text-element 'time #f (right-align-string 6 "TIME "))
|
||||
(make-unmarked-text-element 'command #f "COMMAND"))))
|
||||
|
||||
(define (layout-process width p)
|
||||
(cut-to-size
|
||||
|
|
@ -40,34 +39,20 @@
|
|||
processes)
|
||||
num-lines)))
|
||||
|
||||
(define-option 'ps 'sort-user-up-key (char->ascii #\u))
|
||||
(define-option 'ps 'sort-user-down-key (char->ascii #\U))
|
||||
(define-option 'ps 'sort-pid-up-key (char->ascii #\p))
|
||||
(define-option 'ps 'sort-pid-down-key (char->ascii #\P))
|
||||
(define-option 'ps 'sort-time-up-key (char->ascii #\t))
|
||||
(define-option 'ps 'sort-time-down-key (char->ascii #\T))
|
||||
(define-option 'ps 'kill-key (char->ascii #\k))
|
||||
(define-option 'ps 'refresh-key (char->ascii #\g))
|
||||
(define-option 'ps 'sort-up-key (char->ascii #\s))
|
||||
(define-option 'ps 'sort-down-key (char->ascii #\S))
|
||||
|
||||
(define (make-pps-viewer processes buffer)
|
||||
(let* ((processes processes)
|
||||
(header-line (make-header-line (result-buffer-num-cols buffer)))
|
||||
(header-line (make-header-line))
|
||||
(select-list
|
||||
(make-process-selection-list
|
||||
(result-buffer-num-cols buffer)
|
||||
(result-buffer-num-lines buffer)
|
||||
processes)))
|
||||
|
||||
(define sorting-keys
|
||||
(map
|
||||
(cut config 'ps <>)
|
||||
(list 'sort-time-up-key
|
||||
'sort-time-down-key
|
||||
'sort-user-up-key
|
||||
'sort-user-down-key
|
||||
'sort-pid-up-key
|
||||
'sort-pid-down-key)))
|
||||
|
||||
(define (set-processes! new-processes)
|
||||
(set! processes new-processes)
|
||||
(set! select-list
|
||||
|
|
@ -94,62 +79,64 @@
|
|||
(lambda (message)
|
||||
(case message
|
||||
|
||||
((paint)
|
||||
(lambda (self win buffer have-focus?)
|
||||
(paint-select-line-at header-line 0 0 win)
|
||||
(paint-selection-list-at
|
||||
select-list 0 1 win buffer have-focus?)))
|
||||
((paint)
|
||||
(lambda (self win buffer have-focus?)
|
||||
(paint-select-line-at header-line 0 0 win buffer)
|
||||
(paint-selection-list-at
|
||||
select-list 0 1 win buffer have-focus?)))
|
||||
|
||||
((key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(cond
|
||||
((member key sorting-keys)
|
||||
(receive (compare select)
|
||||
(cond
|
||||
((= key (config 'ps 'sort-time-up-key))
|
||||
(values < process-info-time))
|
||||
((= key (config 'ps 'sort-time-down-key))
|
||||
(values > process-info-time))
|
||||
((= key (config 'ps 'sort-user-up-key))
|
||||
(values string<? process-info-logname))
|
||||
((= key (config 'ps 'sort-user-down-key))
|
||||
(values string>? process-info-logname))
|
||||
((= key (config 'ps 'sort-pid-up-key))
|
||||
(values < process-info-pid))
|
||||
((= key (config 'ps 'sort-pid-down-key))
|
||||
(values > process-info-pid)))
|
||||
(set-processes!
|
||||
(list-sort
|
||||
(lambda (p1 p2)
|
||||
(compare (select p1) (select p2)))
|
||||
processes))
|
||||
self))
|
||||
((= key (config 'ps 'kill-key))
|
||||
(let ((infos
|
||||
(select-list-get-selection select-list)))
|
||||
(for-each
|
||||
(cut signal-process <> signal/term)
|
||||
(map process-info-pid infos)))
|
||||
self)
|
||||
((= key (config 'ps 'refresh-key))
|
||||
(set-processes! (pps))
|
||||
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! header-line key)
|
||||
self)
|
||||
(else self))))
|
||||
((key-press)
|
||||
(lambda (self key control-x-pressed?)
|
||||
(cond
|
||||
((or (= key (config 'ps 'sort-up-key))
|
||||
(= key (config 'ps 'sort-down-key)))
|
||||
(let ((column (select-line-selected-entry header-line)))
|
||||
(receive (compare-up compare-down select)
|
||||
(case column
|
||||
((pid) (values < > process-info-pid))
|
||||
((ppid) (values < > process-info-ppid))
|
||||
((user) (values string<? string>?
|
||||
process-info-logname))
|
||||
((time) (values < > process-info-time))
|
||||
((command) (values string<? string>?
|
||||
process-info-executable))
|
||||
(else
|
||||
(error "unknown column" column)))
|
||||
(let ((compare (if (= key (config 'ps 'sort-up-key))
|
||||
compare-up
|
||||
compare-down)))
|
||||
(set-processes!
|
||||
(list-sort
|
||||
(lambda (p1 p2)
|
||||
(compare (select p1) (select p2)))
|
||||
processes))
|
||||
self))))
|
||||
((= key (config 'ps 'kill-key))
|
||||
(let ((infos
|
||||
(select-list-get-selection select-list)))
|
||||
(for-each
|
||||
(cut signal-process <> signal/term)
|
||||
(map process-info-pid infos)))
|
||||
self)
|
||||
((= key (config 'ps 'refresh-key))
|
||||
(set-processes! (pps))
|
||||
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! header-line key)
|
||||
self)
|
||||
(else self))))
|
||||
|
||||
((get-selection-as-text) get-selection-as-text)
|
||||
((get-selection-as-text) get-selection-as-text)
|
||||
|
||||
((get-selection-as-ref)
|
||||
(make-get-selection-as-ref-method select-list))
|
||||
((get-selection-as-ref)
|
||||
(make-get-selection-as-ref-method select-list))
|
||||
|
||||
(else
|
||||
(error "pps-viewer unknown message" message))))))
|
||||
(else
|
||||
(error "pps-viewer unknown message" message))))))
|
||||
|
||||
(register-plugin!
|
||||
(make-view-plugin make-pps-viewer list-of-processes?))
|
||||
|
|
|
|||
|
|
@ -1,34 +1,12 @@
|
|||
;(define-record-type element
|
||||
; (make-element markable? marked? value text)
|
||||
; element?
|
||||
; (markable? element-markable?)
|
||||
; (marked? element-marked?)
|
||||
; (value element-value)
|
||||
; (text element-text))
|
||||
|
||||
;(define-record-discloser :element
|
||||
; (lambda (r)
|
||||
; `(element ,(element-marked? r) ,(element-text r))))
|
||||
|
||||
;(define (make-unmarked-element value markable? text)
|
||||
; (make-element markable? #f value text))
|
||||
|
||||
;(define (make-marked-element value markable? text)
|
||||
; (make-element markable? #t value text))
|
||||
|
||||
(define (element-value x) x)
|
||||
(define (element-text x) x)
|
||||
|
||||
(define-record-type select-line :select-line
|
||||
(really-make-select-line elements cursor-index num-cols width)
|
||||
(really-make-select-line elements cursor-index num-cols)
|
||||
select-line?
|
||||
(elements select-line-elements)
|
||||
(cursor-index select-line-cursor-index set-select-line-cursor-index!)
|
||||
(num-cols select-line-num-cols)
|
||||
(width select-line-width))
|
||||
(num-cols select-line-num-cols))
|
||||
|
||||
(define (make-select-line elements width)
|
||||
(really-make-select-line elements 0 (length elements) width))
|
||||
(define (make-select-line elements)
|
||||
(really-make-select-line elements 0 (length elements)))
|
||||
|
||||
(define (select-line-key? key)
|
||||
(or (= key key-right)
|
||||
|
|
@ -53,30 +31,23 @@
|
|||
(if (< old-col (- (select-line-num-cols select-line) 1))
|
||||
(set-select-line-cursor-index! select-line (+ old-col 1)))))
|
||||
|
||||
(define (paint-select-line select-line win)
|
||||
(paint-select-line-at select-line 0 0 win))
|
||||
(define (paint-select-line select-line win result-buffer)
|
||||
(paint-select-line-at select-line 0 0 win result-buffer))
|
||||
|
||||
(define (paint-select-line-at select-line x y win)
|
||||
(let ((cursor-col (select-line-cursor-index select-line)))
|
||||
(define (paint-select-line-at select-line x y win result-buffer)
|
||||
(let ((cursor-col (select-line-cursor-index select-line))
|
||||
(width (result-buffer-num-cols result-buffer)))
|
||||
(let lp ((elts (select-line-elements select-line))
|
||||
(i 0)
|
||||
(x x))
|
||||
(cond ((null? elts)
|
||||
(values))
|
||||
((= i cursor-col)
|
||||
(let ((text (cut-to-size (- (select-line-width select-line)
|
||||
x)
|
||||
(element-text (car elts)))))
|
||||
(wattron win (A-REVERSE))
|
||||
(mvwaddstr win y x text)
|
||||
(wattrset win (A-NORMAL))
|
||||
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))
|
||||
(let ((new-x ((element-painter (car elts)) win x y width #t #f))) ; no marking for now
|
||||
(lp (cdr elts) (+ i 1) new-x)))
|
||||
(else
|
||||
(let ((text (cut-to-size (- (select-line-width select-line)
|
||||
x)
|
||||
(element-text (car elts)))))
|
||||
(mvwaddstr win y x text)
|
||||
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))))))
|
||||
(let ((new-x ((element-painter (car elts)) win x y width #f #f)))
|
||||
(lp (cdr elts) (+ i 1) new-x)))))))
|
||||
|
||||
(define (select-line-selected-entry select-line)
|
||||
(element-value
|
||||
|
|
|
|||
|
|
@ -128,9 +128,11 @@
|
|||
(define (paint-selection-list select-list win result-buffer have-focus?)
|
||||
(paint-selection-list-at select-list 0 0 win result-buffer have-focus?))
|
||||
|
||||
(define (paint-selection-list-at select-list x y win result-buffer have-focus?)
|
||||
(define (paint-selection-list-at select-list x y win result-buffer
|
||||
have-focus?)
|
||||
(let ((num-lines (select-list-num-lines select-list))
|
||||
(cursor-index (select-list-cursor-index select-list)))
|
||||
(cursor-index (select-list-cursor-index select-list))
|
||||
(width (result-buffer-num-cols result-buffer)))
|
||||
(let lp ((elts
|
||||
(select-visible-elements select-list num-lines))
|
||||
(y y)
|
||||
|
|
@ -139,13 +141,13 @@
|
|||
((null? elts)
|
||||
(values))
|
||||
((= i cursor-index)
|
||||
((element-painter (car elts)) win x y #t (element-marked? (car elts)))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
((element-painter (car elts)) win x y width #t (element-marked? (car elts)))
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
((element-marked? (car elts))
|
||||
((element-painter (car elts)) win x y #f #t)
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
((element-painter (car elts)) win x y width #f #t)
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))
|
||||
(else
|
||||
((element-painter (car elts)) win x y #f #f)
|
||||
((element-painter (car elts)) win x y width #f #f)
|
||||
(lp (cdr elts) (+ y 1) (+ i 1)))))))
|
||||
|
||||
(define (select-list-get-marked select-list)
|
||||
|
|
|
|||
Loading…
Reference in New Issue