commander-s/scheme/process.scm

(define (list-of-processes? thing)
  (and (proper-list? thing)
       (every process-info? thing)))

(define-record-type colops :colops
  (make-colops < = > select align size to-string header)
  colops?
  (< colops-<)
  (= colops-=)
  (> colops->)
  (select colops-select)
  (align colops-align)
  (size colops-size)
  (to-string colops-to-string)
  (header colops-header))

(define (make-number-colops select align size header)
  (make-colops < = > select align size number->string header))

(define (make-string-colops select align size header)
  (make-colops string<? string=? string>?
               select align size identity-function header))

(define pid-colops
  (make-number-colops process-info-pid right-align-string 5 "PID"))

(define ppid-colops
  (make-number-colops process-info-ppid right-align-string 5 "PPID"))

(define user-colops
  (make-string-colops  process-info-logname
               left-align-string 8 "USER"))

(define time-colops
  (make-number-colops process-info-time right-align-string 5 "TIME"))

(define %cpu-colops
  (make-number-colops process-info-%cpu right-align-string 5 "%CPU"))

(define command-colops ;; actually, we used to display the
		       ;; command-line here as well
  (make-string-colops process-info-executable left-align-string 10
                            "COMMAND"))


(define (column->opertions column)
  (case column
    ((pid) pid-colops)
    ((ppid) ppid-colops)
    ((user) user-colops)
    ((time) time-colops)
    ((%cpu) %cpu-colops)
    ((command) command-colops)
    (else
     (error "unknown column" column))))

(define (layout-process width p colnames)
  (cut-to-size
   width
   (string-join
    (map (cut layout-column <> p) 
         (map column->opertions colnames)))))

(define (layout-column colops p)
  ((colops-align colops)
   (colops-size colops)
   ((colops-to-string colops)
    ((colops-select colops) p))))

(define (make-header-line colnames)
  (make-select-line
   (map
    (lambda (colname)
      (let ((colops (column->opertions colname)))
        (make-unmarked-text-element colname
                                    #f
                                    (string-append
                                     ((colops-align colops)
                                      (colops-size colops)
                                      (colops-header colops))
                                     " "))))
    colnames)))

(define (make-process-selection-list num-cols num-lines 
                                     processes colnames)
  (let ((layout (lambda (p) (layout-process num-cols p colnames))))
    (make-select-list
     (map 
      (lambda (p)
        (make-unmarked-text-element p #t (layout p)))
      processes)
     num-lines)))

(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-option 'ps 'columns-key (char->ascii #\c))

(define all-colnames '(pid ppid user time %cpu command))
(define-option 'ps 'standard-colnames 
  '(pid ppid user %cpu command))

(define (make-pps-viewer processes buffer)
  (let* ((processes processes)
         (colnames (config 'ps 'standard-colnames))
         (header-line (make-header-line colnames))
         (select-list
          (make-process-selection-list 
           (result-buffer-num-cols buffer)
           (result-buffer-num-lines buffer)
           processes
           colnames)))

    (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))
                    (colops (column->opertions column)))
                 (let ((compare (if (= key (config 'ps 'sort-up-key))
                                    (colops-< colops)
                                    (colops-> colops)))
                       (select (colops-select colops)))
                   
                   (send self 'set-processes!
                         (list-sort
                          (lambda (p1 p2)
                            (compare (select p1) (select p2)))
                          processes))
                   self)))
            ((= key (config 'ps 'filter-key))
             (let ((colops 
                    (column->opertions 
                     (select-line-selected-entry header-line))))
               (set-modal-window!
                (make-filter-window self 
                                    processes
                                    (colops-= colops)
                                    (colops-select colops)))
               self))
            ((= key (config 'ps 'columns-key))
             (set-modal-window!
              (make-subset-window self 'set-columns! all-colnames
                                  colnames))
             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
                  colnames))))

        ((set-columns!)
         (lambda (self new-colnames)
           (set! colnames new-colnames)
           (set! header-line (make-header-line colnames))
           (set! select-list
                 (make-process-selection-list 
                  (result-buffer-num-cols buffer)
                  (- (result-buffer-num-lines buffer) 1)
                  processes
                  colnames))))

        (else 
         (error "pps-viewer unknown message" message))))))

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