scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Filtering of processes 

part of darcs patch Wed Sep 21 20:53:22 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel 2005-09-27 16:32:26 +00:00
parent fdd47211ac
commit 8e2a6cd437
2 changed files with 127 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
scheme/process.scm
View File

@ -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)
(case 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)))
(receive (compare-up compare-equal compare-down select)
(column->opertions column)
(let ((compare (if (= key (config 'ps 'sort-up-key))
compare-up
compare-down)))
(set-processes!
(list-sort
(lambda (p1 p2)
(compare (select p1) (select p2)))
processes))
(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)))
@ -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))))))

35
scheme/select-element.scm Normal file
View File

@ -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))))