233 lines
7.7 KiB
Scheme
233 lines
7.7 KiB
Scheme
(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)
|
|
((= key (config 'main 'help-key))
|
|
(set-modal-window!
|
|
(make-help-window 'ps 'sort-up-key 'sort-down-key 'filter-key 'columns-key
|
|
'kill-key 'refresh-key))
|
|
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?))
|