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

New painting for select-line, new sorting for processes (by column) 

part of darcs patch Sun Sep 18 21:31:38 EEST 2005  Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
This commit is contained in:
eknauel 2005-09-27 16:30:57 +00:00
parent 4fbe6c5e51
commit 2b9854c8ff
4 changed files with 86 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scheme/nuit-packages.scm
View File

@ -349,6 +349,7 @@
select-element select-element
(subset focus-table (make-focus-object-reference)) (subset focus-table (make-focus-object-reference))
layout
tty-debug tty-debug
utils utils
ncurses) ncurses)

139
scheme/process.scm
View File

@ -2,15 +2,14 @@
(and (proper-list? thing) (and (proper-list? thing)
(every process-info? thing))) (every process-info? thing)))
(define (make-header-line width) (define (make-header-line)
(make-select-line (make-select-line
(list (list
(right-align-string 6 "PID ") (make-unmarked-text-element 'pid #f (right-align-string 6 "PID "))
(right-align-string 6 "PPID ") (make-unmarked-text-element 'ppid #f (right-align-string 6 "PPID "))
(left-align-string 9 "USER ") (make-unmarked-text-element 'user #f (left-align-string 9 "USER "))
(right-align-string 6 "TIME ") (make-unmarked-text-element 'time #f (right-align-string 6 "TIME "))
"COMMAND") (make-unmarked-text-element 'command #f "COMMAND"))))
width))
(define (layout-process width p) (define (layout-process width p)
(cut-to-size (cut-to-size
@ -40,34 +39,20 @@
processes) processes)
num-lines))) num-lines)))
(define-option 'ps 'sort-user-up-key (char->ascii #\u))
(define-option 'ps 'sort-user-down-key (char->ascii #\U))
(define-option 'ps 'sort-pid-up-key (char->ascii #\p))
(define-option 'ps 'sort-pid-down-key (char->ascii #\P))
(define-option 'ps 'sort-time-up-key (char->ascii #\t))
(define-option 'ps 'sort-time-down-key (char->ascii #\T))
(define-option 'ps 'kill-key (char->ascii #\k)) (define-option 'ps 'kill-key (char->ascii #\k))
(define-option 'ps 'refresh-key (char->ascii #\g)) (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 (make-pps-viewer processes buffer) (define (make-pps-viewer processes buffer)
(let* ((processes processes) (let* ((processes processes)
(header-line (make-header-line (result-buffer-num-cols buffer))) (header-line (make-header-line))
(select-list (select-list
(make-process-selection-list (make-process-selection-list
(result-buffer-num-cols buffer) (result-buffer-num-cols buffer)
(result-buffer-num-lines buffer) (result-buffer-num-lines buffer)
processes))) processes)))
(define sorting-keys
(map
(cut config 'ps <>)
(list 'sort-time-up-key
'sort-time-down-key
'sort-user-up-key
'sort-user-down-key
'sort-pid-up-key
'sort-pid-down-key)))
(define (set-processes! new-processes) (define (set-processes! new-processes)
(set! processes new-processes) (set! processes new-processes)
(set! select-list (set! select-list
@ -94,62 +79,64 @@
(lambda (message) (lambda (message)
(case message (case message
((paint) ((paint)
(lambda (self win buffer have-focus?) (lambda (self win buffer have-focus?)
(paint-select-line-at header-line 0 0 win) (paint-select-line-at header-line 0 0 win buffer)
(paint-selection-list-at (paint-selection-list-at
select-list 0 1 win buffer have-focus?))) select-list 0 1 win buffer have-focus?)))
((key-press) ((key-press)
(lambda (self key control-x-pressed?) (lambda (self key control-x-pressed?)
(cond (cond
((member key sorting-keys) ((or (= key (config 'ps 'sort-up-key))
(receive (compare select) (= key (config 'ps 'sort-down-key)))
(cond (let ((column (select-line-selected-entry header-line)))
((= key (config 'ps 'sort-time-up-key)) (receive (compare-up compare-down select)
(values < process-info-time)) (case column
((= key (config 'ps 'sort-time-down-key)) ((pid) (values < > process-info-pid))
(values > process-info-time)) ((ppid) (values < > process-info-ppid))
((= key (config 'ps 'sort-user-up-key)) ((user) (values string<? string>?
(values string<? process-info-logname)) process-info-logname))
((= key (config 'ps 'sort-user-down-key)) ((time) (values < > process-info-time))
(values string>? process-info-logname)) ((command) (values string<? string>?
((= key (config 'ps 'sort-pid-up-key)) process-info-executable))
(values < process-info-pid)) (else
((= key (config 'ps 'sort-pid-down-key)) (error "unknown column" column)))
(values > process-info-pid))) (let ((compare (if (= key (config 'ps 'sort-up-key))
(set-processes! compare-up
(list-sort compare-down)))
(lambda (p1 p2) (set-processes!
(compare (select p1) (select p2))) (list-sort
processes)) (lambda (p1 p2)
self)) (compare (select p1) (select p2)))
((= key (config 'ps 'kill-key)) processes))
(let ((infos self))))
(select-list-get-selection select-list))) ((= key (config 'ps 'kill-key))
(for-each (let ((infos
(cut signal-process <> signal/term) (select-list-get-selection select-list)))
(map process-info-pid infos))) (for-each
self) (cut signal-process <> signal/term)
((= key (config 'ps 'refresh-key)) (map process-info-pid infos)))
(set-processes! (pps)) self)
self) ((= key (config 'ps 'refresh-key))
((select-list-key? key) (set-processes! (pps))
(set! select-list self)
(select-list-handle-key-press select-list key)) ((select-list-key? key)
self) (set! select-list
((select-line-key? key) (select-list-handle-key-press select-list key))
(select-line-handle-key-press! header-line key) self)
self) ((select-line-key? key)
(else self)))) (select-line-handle-key-press! header-line key)
self)
(else self))))
((get-selection-as-text) get-selection-as-text) ((get-selection-as-text) get-selection-as-text)
((get-selection-as-ref) ((get-selection-as-ref)
(make-get-selection-as-ref-method select-list)) (make-get-selection-as-ref-method select-list))
(else (else
(error "pps-viewer unknown message" message)))))) (error "pps-viewer unknown message" message))))))
(register-plugin! (register-plugin!
(make-view-plugin make-pps-viewer list-of-processes?)) (make-view-plugin make-pps-viewer list-of-processes?))

55
scheme/select-line.scm
View File

@ -1,34 +1,12 @@
;(define-record-type element
; (make-element markable? marked? value text)
; element?
; (markable? element-markable?)
; (marked? element-marked?)
; (value element-value)
; (text element-text))
;(define-record-discloser :element
; (lambda (r)
; `(element ,(element-marked? r) ,(element-text r))))
;(define (make-unmarked-element value markable? text)
; (make-element markable? #f value text))
;(define (make-marked-element value markable? text)
; (make-element markable? #t value text))
(define (element-value x) x)
(define (element-text x) x)
(define-record-type select-line :select-line (define-record-type select-line :select-line
(really-make-select-line elements cursor-index num-cols width) (really-make-select-line elements cursor-index num-cols)
select-line? select-line?
(elements select-line-elements) (elements select-line-elements)
(cursor-index select-line-cursor-index set-select-line-cursor-index!) (cursor-index select-line-cursor-index set-select-line-cursor-index!)
(num-cols select-line-num-cols) (num-cols select-line-num-cols))
(width select-line-width))
(define (make-select-line elements width) (define (make-select-line elements)
(really-make-select-line elements 0 (length elements) width)) (really-make-select-line elements 0 (length elements)))
(define (select-line-key? key) (define (select-line-key? key)
(or (= key key-right) (or (= key key-right)
@ -53,30 +31,23 @@
(if (< old-col (- (select-line-num-cols select-line) 1)) (if (< old-col (- (select-line-num-cols select-line) 1))
(set-select-line-cursor-index! select-line (+ old-col 1))))) (set-select-line-cursor-index! select-line (+ old-col 1)))))
(define (paint-select-line select-line win) (define (paint-select-line select-line win result-buffer)
(paint-select-line-at select-line 0 0 win)) (paint-select-line-at select-line 0 0 win result-buffer))
(define (paint-select-line-at select-line x y win) (define (paint-select-line-at select-line x y win result-buffer)
(let ((cursor-col (select-line-cursor-index select-line))) (let ((cursor-col (select-line-cursor-index select-line))
(width (result-buffer-num-cols result-buffer)))
(let lp ((elts (select-line-elements select-line)) (let lp ((elts (select-line-elements select-line))
(i 0) (i 0)
(x x)) (x x))
(cond ((null? elts) (cond ((null? elts)
(values)) (values))
((= i cursor-col) ((= i cursor-col)
(let ((text (cut-to-size (- (select-line-width select-line) (let ((new-x ((element-painter (car elts)) win x y width #t #f))) ; no marking for now
x) (lp (cdr elts) (+ i 1) new-x)))
(element-text (car elts)))))
(wattron win (A-REVERSE))
(mvwaddstr win y x text)
(wattrset win (A-NORMAL))
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))
(else (else
(let ((text (cut-to-size (- (select-line-width select-line) (let ((new-x ((element-painter (car elts)) win x y width #f #f)))
x) (lp (cdr elts) (+ i 1) new-x)))))))
(element-text (car elts)))))
(mvwaddstr win y x text)
(lp (cdr elts) (+ i 1) (+ x (string-length text)))))))))
(define (select-line-selected-entry select-line) (define (select-line-selected-entry select-line)
(element-value (element-value

16
scheme/select-list.scm
View File

@ -128,9 +128,11 @@
(define (paint-selection-list select-list win result-buffer have-focus?) (define (paint-selection-list select-list win result-buffer have-focus?)
(paint-selection-list-at select-list 0 0 win result-buffer have-focus?)) (paint-selection-list-at select-list 0 0 win result-buffer have-focus?))
(define (paint-selection-list-at select-list x y win result-buffer have-focus?) (define (paint-selection-list-at select-list x y win result-buffer
have-focus?)
(let ((num-lines (select-list-num-lines select-list)) (let ((num-lines (select-list-num-lines select-list))
(cursor-index (select-list-cursor-index select-list))) (cursor-index (select-list-cursor-index select-list))
(width (result-buffer-num-cols result-buffer)))
(let lp ((elts (let lp ((elts
(select-visible-elements select-list num-lines)) (select-visible-elements select-list num-lines))
(y y) (y y)
@ -139,13 +141,13 @@
((null? elts) ((null? elts)
(values)) (values))
((= i cursor-index) ((= i cursor-index)
((element-painter (car elts)) win x y #t (element-marked? (car elts))) ((element-painter (car elts)) win x y width #t (element-marked? (car elts)))
(lp (cdr elts) (+ y 1) (+ i 1))) (lp (cdr elts) (+ y 1) (+ i 1)))
((element-marked? (car elts)) ((element-marked? (car elts))
((element-painter (car elts)) win x y #f #t) ((element-painter (car elts)) win x y width #f #t)
(lp (cdr elts) (+ y 1) (+ i 1))) (lp (cdr elts) (+ y 1) (+ i 1)))
(else (else
((element-painter (car elts)) win x y #f #f) ((element-painter (car elts)) win x y width #f #f)
(lp (cdr elts) (+ y 1) (+ i 1))))))) (lp (cdr elts) (+ y 1) (+ i 1)))))))
(define (select-list-get-marked select-list) (define (select-list-get-marked select-list)