2005-05-22 05:20:44 -04:00
|
|
|
(define (list-of-processes? thing)
|
|
|
|
(and (proper-list? thing)
|
|
|
|
(every process-info? thing)))
|
|
|
|
|
2005-05-20 11:20:34 -04:00
|
|
|
(define (print-processes processes)
|
|
|
|
(map (lambda (pi)
|
|
|
|
(apply format
|
|
|
|
(append
|
|
|
|
(list #f
|
|
|
|
"~A ~A ~A ~A '~A ~A'~%")
|
|
|
|
(map (lambda (s) (s pi))
|
|
|
|
(list process-info-pid
|
|
|
|
process-info-ppid
|
|
|
|
process-info-real-uid
|
|
|
|
process-info-%cpu
|
|
|
|
process-info-executable
|
|
|
|
process-info-command-line)))))
|
|
|
|
processes))
|
|
|
|
|
|
|
|
(define (pps-receiver message)
|
2005-05-22 05:20:44 -04:00
|
|
|
(debug-message "pps-receiver " message)
|
2005-05-20 11:20:34 -04:00
|
|
|
(cond
|
|
|
|
((next-command-message? message)
|
|
|
|
(pps))
|
2005-05-22 11:05:25 -04:00
|
|
|
((init-with-result-message? message)
|
|
|
|
(init-with-result-message-result message))
|
2005-05-20 11:20:34 -04:00
|
|
|
((print-message? message)
|
|
|
|
(let ((processes (message-result-object message)))
|
|
|
|
(make-print-object 1 1 (print-processes processes)
|
|
|
|
'() '())))
|
|
|
|
((key-pressed-message? message)
|
|
|
|
(pps))
|
|
|
|
((restore-message? message)
|
|
|
|
(values))
|
|
|
|
((selection-message? message)
|
|
|
|
"'()")))
|
|
|
|
|
2005-05-22 11:05:25 -04:00
|
|
|
(register-plugin!
|
|
|
|
(make-plugin "ps" pps-receiver list-of-processes?))
|