156 lines
5.0 KiB
Scheme
156 lines
5.0 KiB
Scheme
(define (list-of-processes? thing)
|
|
(and (proper-list? thing)
|
|
(every process-info? thing)))
|
|
|
|
(define (make-header-line width)
|
|
(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))
|
|
|
|
(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-time 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-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 (make-pps-viewer processes buffer)
|
|
(let* ((processes processes)
|
|
(header-line (make-header-line (result-buffer-num-cols buffer)))
|
|
(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
|
|
(make-process-selection-list
|
|
(result-buffer-num-cols buffer)
|
|
(- (result-buffer-num-lines buffer) 1)
|
|
new-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)
|
|
(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))))
|
|
|
|
((get-selection-as-text) get-selection-as-text)
|
|
|
|
((get-selection-as-ref)
|
|
(make-get-selection-as-ref-method select-list))
|
|
|
|
(else
|
|
(error "pps-viewer unknown message" message))))))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-pps-viewer list-of-processes?))
|