commander-s/scheme/process.scm

(define-record-type plugin-state :plugin-state
  (make-plugin-state processes selection-list cursor-x)
  plugin-state?
  (processes plugin-state-processes)
  (selection-list plugin-state-selection-list)
  (cursor-x plugin-state-cursor-x))

(define-record-discloser :plugin-state
  (lambda (r)
    `(plugin-state ,(plugin-state-selection-list r))))

(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 (pps-receiver message)
  (debug-message "pps-receiver " message)
  (cond

   ((init-with-result-message? message)
    (let* ((processes (init-with-result-message-result message))
	   (buffer (init-with-result-message-buffer message))
	   (num-cols (result-buffer-num-cols buffer))
	   (num-lines (result-buffer-num-lines buffer)))
      (make-plugin-state 
       processes 
       (make-process-selection-list num-cols num-lines processes) 1)))

   ((print-message? message)
    (paint-selection-list
     (plugin-state-selection-list
      (message-result-object message))))

   ((key-pressed-message? message)
    (let ((old-state (message-result-object message)))
      (make-plugin-state 
       (plugin-state-processes old-state)
       (select-list-handle-key-press
	(plugin-state-selection-list old-state)
	message)
       (plugin-state-cursor-x old-state))))

   ((restore-message? message)
    (values))

   ((selection-message? message)
    "'()")))

(register-plugin! 
 (make-view-plugin pps-receiver list-of-processes?))