commander-s/scheme/process.scm

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

(define (make-header-line)
  (make-select-line
   (list
    (make-unmarked-text-element 'pid #f (right-align-string 6 "PID "))
    (make-unmarked-text-element 'ppid #f (right-align-string 6 "PPID "))
    (make-unmarked-text-element 'user #f (left-align-string 9 "USER "))
    (make-unmarked-text-element '%cpu #f (right-align-string 6 "%CPU "))
    (make-unmarked-text-element 'command #f "COMMAND"))))


(define (column->opertions column)
  (case column
    ((pid) (values < = > process-info-pid))
    ((ppid) (values < = > process-info-ppid))
    ((user) (values string<? string=? string>? 
                    process-info-logname))
    ((time) (values < = > process-info-time))
    ((%cpu) (values < = > process-info-%cpu))
    ((command) (values string<? string=? string>? 
                       process-info-executable))
    (else
     (error "unknown column" column))))

(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-%cpu 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 (make-filter-window list-viewer entries
                            compare-val select-val)
  (define header-line "Filter by")
  (define header-length (string-length header-line))
  (let* ((vals
          (delete-duplicates
           (map select-val entries) compare-val))
         (val-strings
          (map display-to-string vals))
         (lines 10)
         (inner-width
          (min (apply max header-length
                      (map string-length val-strings))
               (COLS)))
         (dialog (make-app-window (- (quotient (COLS) 2)
                                     (quotient inner-width 2))
                                  5
                                  (+ 4 inner-width)
                                  lines)))
    (app-window-init-curses-win! dialog)
    (let* ((dialog-win (app-window-curses-win dialog))
           (select-list 
            (make-select-list 
             (map (lambda (val str)
                    (make-unmarked-text-element 
                     val #f str))
                  vals val-strings)
             (- lines 3))))

      (define (paint)
        (werase dialog-win)
        (box dialog-win
             (ascii->char 0) (ascii->char 0))
        (mvwaddstr dialog-win 
                   0
                   (+ 1 (quotient (- inner-width header-length) 2))
                   header-line)
        (paint-selection-list-at select-list 2 1 dialog-win inner-width #t)
        (wrefresh dialog-win))

      (paint)
      (lambda (key)
        (cond ((= key 27)
               (delete-app-window! dialog)
               (close-modal-window!)
               #t)
              ((select-list-key? key)
               (set! select-list
                     (select-list-handle-key-press select-list key))
               (paint)
               #f)
              ((= key 10)
               (let* ((val (select-list-selected-entry select-list))
                      (new-entries 
                       (filter (lambda (entry)
                                 (compare-val (select-val entry)
                                              val)) entries)))
                 (send list-viewer 'set-entries! new-entries))
               (delete-app-window! dialog)
               #t)
              (else #f))))))

(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 (make-pps-viewer processes buffer)
  (let* ((processes processes)
         (header-line (make-header-line))
         (select-list
          (make-process-selection-list 
           (result-buffer-num-cols buffer)
           (result-buffer-num-lines buffer)
           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 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)))
               (receive (compare-up compare-equal compare-down select)
                   (column->opertions column)
                 (let ((compare (if (= key (config 'ps 'sort-up-key))
                                    compare-up
                                    compare-down)))
                   (send self 'set-processes!
                         (list-sort
                          (lambda (p1 p2)
                            (compare (select p1) (select p2)))
                          processes))
                   self))))
            ((= key (config 'ps 'filter-key))
             (receive (compare-up compare-equal compare-down select)
                 (column->opertions 
                  (select-line-selected-entry header-line))
               (set-modal-window!
                (make-filter-window self processes compare-equal select))
               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))))
        (else 
         (error "pps-viewer unknown message" message))))))

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