(define (list-of-processes? thing)
(and (proper-list? thing)
(every process-info? thing)))
(define (make-header-line)
(make-select-line
(list
(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 '%cpu #f (right-align-string 6 "%CPU "))
(make-unmarked-text-element 'command #f "COMMAND"))))
(define (column->opertions column)
(case column
((pid) (values < = > process-info-pid))
((ppid) (values < = > process-info-ppid))
((user) (values string<? string=? string>?
process-info-logname))
((time) (values < = > process-info-time))
((%cpu) (values < = > process-info-%cpu))
((command) (values string<? string=? string>?
process-info-executable))
(else
(error "unknown column" column))))
(define (layout-process width p)
(cut-to-size
width
(string-append
(right-align-string 5 (number->string (process-info-pid p)))
" "
(right-align-string 5 (number->string (process-info-ppid p)))
" "
(left-align-string 8 (process-info-logname p))
" "
(right-align-string 5 (number->string (process-info-%cpu p)))
" "
(left-align-string 100 (string-append
(process-info-executable p)
" "
(string-join
(process-info-command-line p)))))))
(define (make-process-selection-list num-cols num-lines
processes)
(let ((layout (lambda (p) (layout-process num-cols p))))
(make-select-list
(map
(lambda (p)
(make-unmarked-text-element p #t (layout-process num-cols p)))
processes)
num-lines)))
(define (make-filter-window list-viewer entries
compare-val select-val)
(define header-line "Filter by")
(define header-length (string-length header-line))
(let* ((vals
(delete-duplicates
(map select-val entries) compare-val))
(val-strings
(map display-to-string vals))
(lines 10)
(inner-width
(min (apply max header-length
(map string-length val-strings))
(COLS)))
(dialog (make-app-window (- (quotient (COLS) 2)
(quotient inner-width 2))
5
(+ 4 inner-width)
lines)))
(app-window-init-curses-win! dialog)
(let* ((dialog-win (app-window-curses-win dialog))
(select-list
(make-select-list
(map (lambda (val str)
(make-unmarked-text-element
val #f str))
vals val-strings)
(- lines 3))))
(define (paint)
(werase dialog-win)
(box dialog-win
(ascii->char 0) (ascii->char 0))
(mvwaddstr dialog-win
0
(+ 1 (quotient (- inner-width header-length) 2))
header-line)
(paint-selection-list-at select-list 2 1 dialog-win inner-width #t)
(wrefresh dialog-win))
(paint)
(lambda (key)
(cond ((= key 27)
(delete-app-window! dialog)
(close-modal-window!)
#t)
((select-list-key? key)
(set! select-list
(select-list-handle-key-press select-list key))
(paint)
#f)
((= key 10)
(let* ((val (select-list-selected-entry select-list))
(new-entries
(filter (lambda (entry)
(compare-val (select-val entry)
val)) entries)))
(send list-viewer 'set-entries! new-entries))
(delete-app-window! dialog)
(close-modal-window!)
#t)
(else #f))))))
(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-option 'ps 'filter-key (char->ascii #\f))
(define (make-pps-viewer processes buffer)
(let* ((processes processes)
(header-line (make-header-line))
(select-list
(make-process-selection-list
(result-buffer-num-cols buffer)
(result-buffer-num-lines buffer)
processes)))
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
(let* ((marked (select-list-get-marked select-list)))
(cond
((null? marked)
(number->string
(process-info-pid
(select-list-selected-entry select-list))))
(for-scheme-mode?
(string-append
"'" (write-to-string (map process-info-pid marked))))
(else
(string-join
(map number->string
(map process-info-pid marked)))))))
(lambda (message)
(case message
((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 (result-buffer-num-cols buffer)
have-focus?)))
((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-equal compare-down select)
(column->opertions column)
(let ((compare (if (= key (config 'ps 'sort-up-key))
compare-up
compare-down)))
(send self 'set-processes!
(list-sort
(lambda (p1 p2)
(compare (select p1) (select p2)))
processes))
self))))
((= key (config 'ps 'filter-key))
(receive (compare-up compare-equal compare-down select)
(column->opertions
(select-line-selected-entry header-line))
(set-modal-window!
(make-filter-window self processes compare-equal select))
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))
(send self '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-ref)
(make-get-selection-as-ref-method select-list))
((set-entries!)
(lambda (self processes)
(send self 'set-processes! processes)))
((set-processes!)
(lambda (self new-processes)
(set! processes new-processes)
(set! select-list
(make-process-selection-list
(result-buffer-num-cols buffer)
(- (result-buffer-num-lines buffer) 1)
new-processes))))
(else
(error "pps-viewer unknown message" message))))))
(register-plugin!
(make-view-plugin make-pps-viewer list-of-processes?))