Filtering of processes

part of darcs patch Wed Sep 21 20:53:22 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>

scheme/process.scm

@@ -11,6 +11,19 @@
     (make-unmarked-text-element 'time #f (right-align-string 6 "TIME "))
     (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))
+    ((command) (values string<? string=? string>? 
+                       process-info-executable))
+    (else
+     (error "unknown column" column))))
+
 (define (layout-process width p)
   (cut-to-size 
    width
@@ -39,10 +52,61 @@
       processes)
      num-lines)))
 
+(define (make-filter-window list-viewer entries
+                            compare-val select-val)
+  (let* ((vals
+          (delete-duplicates
+           (map select-val entries) compare-val))
+         (val-strings
+          (map display-to-string vals))
+         (max-width
+          (apply max (map string-length val-strings)))
+         (dialog (make-app-window 10 10 (+ 2 max-width) 10)))
+    (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)
+             7)))
+
+      (define (paint)
+        (werase dialog-win)
+        (box dialog-win
+             (ascii->char 0) (ascii->char 0))
+        (paint-selection-list-at select-list 1 1 dialog-win max-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)
+               (close-modal-window!)
+               #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)
@@ -84,26 +148,24 @@
             ((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-down select)
+               (receive (compare-up compare-equal compare-down select)
-                   (case column
+                   (column->opertions column)
-                     ((pid) (values < > process-info-pid))
-                     ((ppid) (values < > process-info-ppid))
-                     ((user) (values string<? string>? 
-                                     process-info-logname))
-                     ((time) (values < > process-info-time))
-                     ((command) (values string<? string>? 
-                                        process-info-executable))
-                     (else
-                      (error "unknown column" column)))
                  (let ((compare (if (= key (config 'ps 'sort-up-key))
                                     compare-up
                                     compare-down)))
-                   (set-processes!
+                   (send self 'set-processes!
-                    (list-sort
+                         (list-sort
-                     (lambda (p1 p2)
+                          (lambda (p1 p2)
-                       (compare (select p1) (select p2)))
+                            (compare (select p1) (select p2)))
-                     processes))
+                          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)))
@@ -112,7 +174,7 @@
                 (map process-info-pid infos)))
              self)
             ((= key (config 'ps 'refresh-key))
-             (set-processes! (pps))
+             (send self 'set-processes! (pps))
              self)
             ((select-list-key? key)
              (set! select-list
@@ -127,7 +189,19 @@
 
         ((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))))))
 

scheme/select-element.scm

@@ -0,0 +1,35 @@
+(define-record-type element :element
+  (make-element markable? marked? value painter)
+  element?
+  (markable? element-markable?)
+  (marked? element-marked?)
+  (value element-value)
+  (painter element-painter))
+
+(define-record-discloser :element
+  (lambda (r)
+    `(element ,(element-marked? r) ,(element-value r))))
+
+(define (make-unmarked-element value markable? painter)
+  (make-element markable? #f value painter))
+
+(define (make-marked-element value markable? painter)
+  (make-element markable? #t value painter))
+
+(define (make-unmarked-text-element value markable? text)
+  (make-unmarked-element value markable? (make-text-painter text)))
+
+(define (make-marked-text-element value markable? text)
+  (make-marked-element value markable? (make-text-painter text)))
+
+(define (make-text-painter text)
+  (lambda (win x y width at-cursor? marked?)
+    (if at-cursor?
+        (wattron win (A-REVERSE)))
+    (if marked?
+	(wattron win (A-BOLD)))
+    (mvwaddstr win y x text)
+    (if (or at-cursor? marked?)
+        (wattrset win (A-NORMAL)))
+    (+ x (string-length text))))
+