commander-s/scheme/job-viewer.scm

(define-option 'job 'fg-key (char->ascii #\f))
(define-option 'job 'bg-key (char->ascii #\b))
(define-option 'job 'stop-job-key (char->ascii #\s))
(define-option 'job 'refresh-key (char->ascii #\g))
(define-option 'job 'kill-job-key (char->ascii #\k))

(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-jobs-select-list jobs lines width)
  (make-select-list
   (map (lambda (job)
          (make-unmarked-text-element 
           job #t (format-job job width)))
        jobs)
   lines))


(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-jobs-select-list 
           jobs 
           (- (result-buffer-num-lines buffer) 2)
           (- num-cols 2))))

    (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 (result-buffer-num-cols buffer)
            have-focus?)))

	((key-press)
	 (lambda (self key control-x-pressed?)
           (cond 
            ((= key (config 'job 'fg-key))
             (continue-job-in-foreground 
              (select-list-selected-entry select-list)))
            ((= key (config 'job 'bg-key))
             (continue-job-in-background 
              (select-list-selected-entry select-list)))
            ((= key (config 'job 'stop-job-key))
             (stop-job (select-list-selected-entry select-list)))
            
            ((= key (config 'job 'kill-job-key))
             (signal-job signal/kill
                         (select-list-selected-entry select-list)))
            
            ((= key (config 'job 'refresh-key))
             (send self 'refresh))
            (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)
	
        ((refresh)
         (lambda (self)
           (set! select-list
                 (make-jobs-select-list
                  jobs
                  (- (result-buffer-num-lines buffer) 2)
                  (- num-cols 2)))))
	(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-text-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) 3)))

    (define (handle-key-press self key control-x-pressed?)
      (cond
       ((= key (config 'job 'fg-key))
	(continue-job-in-foreground job)
	self)
       ((= key (config 'job 'bg-key))
        (continue-job-in-background job)
	self)
       ((= key (config 'job 'refresh-key))
	(set! select-list (make-job-select-list job))
	self)
       ((= key (config 'job 'stop-job-key))
        (stop-job job)
	self)
       ((= key (config 'job 'kill-job-key))
        (signal-job signal/kill 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 (result-buffer-num-cols 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?))