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

Column selector for processes 

part of darcs patch Sun Sep 25 22:19:40 MST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
mainzelm 2005-10-11 15:55:48 +00:00
parent 74c968b999
commit 1ef838007d
4 changed files with 179 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
scheme/filter-window.scm
View File

@ -60,3 +60,62 @@
#t)
(else #f))))))
(define (make-subset-window set-viewer method-name set current)
(define header-line "Please select")
(define header-length (string-length header-line))
(let* ((set-strings
(map display-to-string set))
(lines 10)
(inner-width
(min (apply max header-length
(map string-length set-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 (elem elem-str)
(if (member elem current)
(make-marked-text-element
elem #t elem-str)
(make-unmarked-text-element
elem #t elem-str)))
set set-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 ((new-set (select-list-get-marked select-list)))
(send set-viewer method-name new-set)
(delete-app-window! dialog)
#t))
(else #f))))))

4
scheme/nuit-packages.scm
View File

@ -13,6 +13,7 @@
write-to-string
on/off-option-processor
paste-selection
identity-function
set-redisplay-everything
unset-redisplay-everything
@ -418,7 +419,8 @@
(define-interface filter-window-interface
(export
make-filter-window))
make-filter-window
make-subset-window))
(define-structure filter-window filter-window-interface
(open scheme

163
scheme/process.scm
View File

@ -2,54 +2,92 @@
(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-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) (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))
((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)
(cut-to-size
(define (layout-process width p colnames)
(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)))))))
(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)
(let ((layout (lambda (p) (layout-process num-cols p))))
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-process num-cols p)))
(make-unmarked-text-element p #t (layout p)))
processes)
num-lines)))
@ -58,15 +96,22 @@
(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)
(header-line (make-header-line))
(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)))
processes
colnames)))
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
(let* ((marked (select-list-get-marked select-list)))
@ -98,25 +143,34 @@
(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* ((column (select-line-selected-entry header-line))
(colops (column->opertions column)))
(let ((compare (if (= key (config 'ps 'sort-up-key))
compare-up
compare-down)))
(colops-< colops)
(colops-> colops)))
(select (colops-select colops)))
(send self 'set-processes!
(list-sort
(lambda (p1 p2)
(compare (select p1) (select p2)))
processes))
self))))
self)))
((= key (config 'ps 'filter-key))
(receive (compare-up compare-equal compare-down select)
(column->opertions
(select-line-selected-entry header-line))
(let ((colops
(column->opertions
(select-line-selected-entry header-line))))
(set-modal-window!
(make-filter-window self processes compare-equal select))
(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)))
@ -152,7 +206,20 @@
(make-process-selection-list
(result-buffer-num-cols buffer)
(- (result-buffer-num-lines buffer) 1)
new-processes))))
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))))))

2
scheme/utils.scm
View File

@ -35,3 +35,5 @@
(define (redisplay-everything?)
*redisplay-everything*)
(define (identity-function x) x)