269 lines
7.0 KiB
Scheme
269 lines
7.0 KiB
Scheme
(define key-f (char->ascii #\f))
|
|
(define key-s (char->ascii #\s))
|
|
(define key-g (char->ascii #\g))
|
|
(define key-b (char->ascii #\b))
|
|
|
|
(define fg-key key-f)
|
|
(define bg-key key-b)
|
|
(define stop-job-key key-s)
|
|
(define refresh-key key-g)
|
|
|
|
(define (job-name->string name)
|
|
(let ((port (open-output-string)))
|
|
(display name port)
|
|
(get-output-string port)))
|
|
|
|
(define (short-date date)
|
|
(fill-up-string 10
|
|
(format-date "~H:~M:~S" date)))
|
|
|
|
(define (format-job-run-state job)
|
|
(fill-up-string 12
|
|
(cond
|
|
((job-running? job) "running")
|
|
((job-ready? job) "ready")
|
|
((job-waiting-for-input? job) "wait/input")
|
|
((job-has-new-output? job) "wait/output")
|
|
((job-stopped? job) "stopped")
|
|
(else "run/output"))))
|
|
|
|
(define (format-job job num-cols)
|
|
(cut-to-size num-cols
|
|
(string-append
|
|
(fill-up-string
|
|
20 (job-name->string (job-name job)))
|
|
" "
|
|
(format-job-run-state job)
|
|
" "
|
|
(short-date (job-start-time job))
|
|
" "
|
|
(if (job-end-time job)
|
|
(short-date (job-end-time job))
|
|
(fill-up-string 12 "-"))
|
|
" "
|
|
(fill-up-string
|
|
6 (if (job-end-time job)
|
|
(number->string (job-status job))
|
|
"-")))))
|
|
|
|
(define (make-joblist-headline num-cols)
|
|
(cut-to-size
|
|
num-cols
|
|
(string-append
|
|
(fill-up-string 20 "NAME")
|
|
" "
|
|
(fill-up-string 12 "RUN STATUS")
|
|
" "
|
|
(fill-up-string 10 "START")
|
|
" "
|
|
(fill-up-string 10 "END")
|
|
" "
|
|
(fill-up-string 6 "STATUS"))))
|
|
|
|
(define (make-joblist-viewer jobs buffer)
|
|
(let* ((jobs jobs)
|
|
(num-cols (- (result-buffer-num-cols buffer) 1))
|
|
(headline (make-joblist-headline num-cols))
|
|
(select-list
|
|
(make-select-list
|
|
(map (lambda (job)
|
|
(make-unmarked-element
|
|
job #t (format-job job num-cols)))
|
|
jobs)
|
|
(- (result-buffer-num-lines buffer) 1))))
|
|
|
|
(define get-selection-as-ref
|
|
(make-get-selection-as-ref-method select-list))
|
|
|
|
(define (get-selection-as-text self for-scheme-mode? focus-object-table)
|
|
(if for-scheme-mode?
|
|
(send self 'get-selection-as-ref focus-object-table)
|
|
(let ((marked (select-list-get-marked select-list)))
|
|
(if (null? marked)
|
|
(number->string
|
|
(proc:pid (job-proc (select-list-selected-entry select-list))))
|
|
(string-join (map (lambda (job)
|
|
(number->string
|
|
(proc:pid (job-proc job))))
|
|
marked))))))
|
|
|
|
(lambda (message)
|
|
|
|
(case message
|
|
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(mvwaddstr win 0 0 headline)
|
|
(paint-selection-list-at
|
|
select-list 0 1 win buffer have-focus?)))
|
|
|
|
((key-press)
|
|
(lambda (self key control-x-pressed?)
|
|
(cond
|
|
((= key fg-key)
|
|
(continue-job-in-foreground (select-list-selected-entry select-list)))
|
|
((= key bg-key)
|
|
(continue-job-in-background (select-list-selected-entry select-list)))
|
|
((= key stop-job-key)
|
|
(stop-job (select-list-selected-entry select-list)))
|
|
((= key refresh-key)
|
|
#f) ;; TODO
|
|
(else
|
|
(set! select-list
|
|
(select-list-handle-key-press select-list key))))
|
|
self))
|
|
|
|
((get-selection-as-text) get-selection-as-text)
|
|
|
|
((get-selection-as-ref) get-selection-as-ref)
|
|
|
|
(else
|
|
(error "joblist-viewer unknown message" message))))))
|
|
|
|
(define (list-of-jobs? thing)
|
|
(and (proper-list? thing) (every job? thing)))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-joblist-viewer list-of-jobs?))
|
|
|
|
(define format-signal-no
|
|
(let ((signal/name-alist
|
|
`((,signal/alrm . signal/alrm)
|
|
(,signal/int . signal/int)
|
|
(,signal/chld . signal/chld)
|
|
(,signal/cont . signal/cont)
|
|
(,signal/hup . signal/hup)
|
|
(,signal/quit . signal/quit)
|
|
(,signal/term . signal/term)
|
|
(,signal/tstp . signal/tstp)
|
|
(,signal/usr1 . signal/usr1)
|
|
(,signal/usr2 . signal/usr2)
|
|
(,signal/stop . signal/stop)
|
|
(,signal/kill . signal/kill)
|
|
(,signal/abrt . signal/abrt)
|
|
(,signal/fpe . signal/fpe)
|
|
(,signal/ill . signal/ill)
|
|
(,signal/pipe . signal/pipe)
|
|
(,signal/segv . signal/segv)
|
|
(,signal/ttin . signal/ttin)
|
|
(,signal/ttou . signal/ttou))))
|
|
(lambda (no)
|
|
(cond
|
|
((assoc no signal/name-alist)
|
|
=> (lambda (p)
|
|
(symbol->string (cdr p))))
|
|
(else "some non-POSIX signal")))))
|
|
|
|
(define (format-job-status job)
|
|
(let ((status (job-status job)))
|
|
(debug-message "format-job-status " status)
|
|
(cond
|
|
((status:exit-val status)
|
|
=> (lambda (code)
|
|
(string-append "exited normally with code "
|
|
(number->string code))))
|
|
((status:stop-sig status)
|
|
=> (lambda (signal-no)
|
|
(string-append "suspended by signal "
|
|
(format-signal-no signal-no))))
|
|
((status:term-sig status)
|
|
=> (lambda (signal-no)
|
|
(string-append "terminated by signal "
|
|
(format-signal-no signal-no)))))))
|
|
|
|
;;; viewer for a single job viewer
|
|
|
|
(define (make-job-viewer job buffer)
|
|
(let ((select-list #f)
|
|
(num-cols
|
|
(- (result-buffer-num-cols buffer) 1))
|
|
(console-viewer
|
|
(if (job-with-console? job)
|
|
(make-console-viewer (job-console job) buffer)
|
|
#f)))
|
|
|
|
(define (make-job-select-list job)
|
|
(make-select-list
|
|
(map
|
|
(lambda (args)
|
|
(make-unmarked-element
|
|
(car args) #f
|
|
(cut-to-size
|
|
num-cols
|
|
(apply string-append
|
|
(append
|
|
(list (fill-up-string 15 (cadr args)))
|
|
(cddr args))))))
|
|
`((,job
|
|
"name:" ,(job-name->string (job-name job)))
|
|
|
|
(,(if (job-end-time job) (job-status job) #f)
|
|
"status:"
|
|
,(if (job-end-time job)
|
|
(format-job-status job)
|
|
"n/a"))
|
|
|
|
(,(job-start-time job)
|
|
"start:"
|
|
,(short-date (job-start-time job)))
|
|
(,(job-end-time job)
|
|
"end:"
|
|
,(if (job-end-time job)
|
|
(short-date (job-end-time job))
|
|
"-"))
|
|
(#f "run status:"
|
|
,(format-job-run-state job))
|
|
,@(if (job-with-console? job)
|
|
`((,console-viewer "<View Console>" ""))
|
|
'())))
|
|
(- (result-buffer-num-lines buffer) 1)))
|
|
|
|
(define (handle-key-press self key control-x-pressed?)
|
|
(cond
|
|
((= key fg-key)
|
|
(continue-job-in-foreground job)
|
|
self)
|
|
((= key bg-key)
|
|
(continue-job-in-background job)
|
|
self)
|
|
((= key refresh-key)
|
|
(set! select-list (make-job-select-list job))
|
|
self)
|
|
((= key stop-job-key)
|
|
(stop-job job)
|
|
self)
|
|
((and (= key 10)
|
|
(procedure? (select-list-selected-entry select-list)))
|
|
(select-list-selected-entry select-list))
|
|
(else
|
|
(set! select-list
|
|
(select-list-handle-key-press select-list key))
|
|
self)))
|
|
|
|
(set! select-list (make-job-select-list job))
|
|
|
|
(lambda (message)
|
|
(case message
|
|
|
|
((paint)
|
|
(lambda (self win buffer have-focus?)
|
|
(mvwaddstr
|
|
win 0 0 (cut-to-size num-cols "Viewing job"))
|
|
(paint-selection-list-at
|
|
select-list 0 1 win buffer have-focus?)))
|
|
|
|
((key-press) handle-key-press)
|
|
|
|
((get-selection-as-ref)
|
|
(make-get-selection-as-ref-method select-list))
|
|
|
|
((get-selection-as-text)
|
|
(lambda (self focus? focus-table)
|
|
((make-get-selection-as-ref-method select-list)
|
|
self focus-table)))
|
|
|
|
(else
|
|
(error "job viewer unknown message" message))))))
|
|
|
|
(register-plugin!
|
|
(make-view-plugin make-job-viewer job?)) |