65 lines
1.6 KiB
Scheme
65 lines
1.6 KiB
Scheme
(define (list-of-processes? thing)
|
|
(and (proper-list? thing)
|
|
(every process-info? thing)))
|
|
|
|
(define (string-take-max s nchars)
|
|
(if (>= nchars (string-length s))
|
|
s
|
|
(string-take s nchars)))
|
|
|
|
(define (layout-process width p)
|
|
(string-take-max
|
|
(apply format
|
|
(append
|
|
(list #f "~A ~A ~A ~A '~A ~A'~%")
|
|
(map (lambda (s) (s p))
|
|
(list process-info-pid
|
|
process-info-ppid
|
|
process-info-real-uid
|
|
process-info-%cpu
|
|
process-info-executable
|
|
process-info-command-line))))
|
|
width))
|
|
|
|
(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-element p #t (layout-process num-cols p)))
|
|
processes)
|
|
num-lines)))
|
|
|
|
(define (make-pps-viewer)
|
|
(let ((processes #f)
|
|
(select-list #f))
|
|
(lambda (message)
|
|
(cond
|
|
|
|
((eq? message 'init)
|
|
(lambda (self process-list buffer)
|
|
(let ((num-cols (result-buffer-num-cols buffer))
|
|
(num-lines (result-buffer-num-lines buffer)))
|
|
(set! processes process-list)
|
|
(set! select-list
|
|
(make-process-selection-list
|
|
num-cols num-lines processes))
|
|
self)))
|
|
|
|
((eq? message 'paint)
|
|
(lambda (self . args)
|
|
(apply paint-selection-list
|
|
(cons select-list args))))
|
|
|
|
((eq? message 'key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(set! select-list
|
|
(select-list-handle-key-press select-list key))
|
|
self))
|
|
|
|
(else
|
|
(error "pps-viewer unknown message" message))))))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-pps-viewer list-of-processes?))
|