211 lines
7.3 KiB
Scheme
211 lines
7.3 KiB
Scheme
(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)
|
|
(let* ((vals
|
|
(delete-duplicates
|
|
(map select-val entries) compare-val))
|
|
(val-strings
|
|
(map display-to-string vals))
|
|
(max-width
|
|
(apply max (map string-length val-strings)))
|
|
(dialog (make-app-window 10 10 (+ 2 max-width) 10)))
|
|
(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)
|
|
7)))
|
|
|
|
(define (paint)
|
|
(werase dialog-win)
|
|
(box dialog-win
|
|
(ascii->char 0) (ascii->char 0))
|
|
(paint-selection-list-at select-list 1 1 dialog-win max-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?))
|