142 lines
3.6 KiB
Scheme
142 lines
3.6 KiB
Scheme
(define-record-type job :job
|
|
(make-job name pty-in pty-out proc status)
|
|
job?
|
|
(name job-name)
|
|
(pty-in job-pty-in)
|
|
(pty-out job-pty-out)
|
|
(proc job-proc)
|
|
(status really-job-status))
|
|
|
|
(define (make-job name pty-in pty-out proc)
|
|
(let ((job (make-job name pty-in pty-out proc
|
|
(make-placeholder))))
|
|
(spawn-job-status-surveillant job)
|
|
(add-job! job)
|
|
job))
|
|
|
|
(define (job-status-rv job)
|
|
(placeholder-value-rv (really-job-status job)))
|
|
|
|
(define (job-status job)
|
|
(sync (job-status-rv job)))
|
|
|
|
(define (spawn-job-status-surveillant job)
|
|
(let ((channel (make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
(placeholder-set!
|
|
(really-job-status job) (wait (job-proc)))))))
|
|
|
|
(define (signal-job signal job)
|
|
(signal-process-group signal (job-proc job)))
|
|
|
|
(define (stop-job job)
|
|
(signal-job signal/stop job))
|
|
|
|
(define (continue-job job)
|
|
(signal-process-group signal/cont job))
|
|
|
|
;; channels for communicating with the joblist surveillant
|
|
|
|
(define add-job-channel
|
|
(make-channel))
|
|
|
|
(define get-job-list-channel
|
|
(make-channel))
|
|
|
|
(define (add-job! job)
|
|
(send add-job-channel job))
|
|
|
|
(define (running-jobs)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'running answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (ready-jobs)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'ready answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (jobs-with-new-output)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'new-output answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (jobs-waiting-for-input)
|
|
(let ((answer-channel (make-channel)))
|
|
(send get-job-list-channel (cons 'waiting-for-input answer-channel))
|
|
(receive answer-channel)))
|
|
|
|
(define (spawn-joblist-surveillant)
|
|
(let ((statistics-channel (make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
(let lp ((running '())
|
|
(ready '())
|
|
(new-output '())
|
|
(waiting-for-input '())
|
|
(notify? #f))
|
|
(cond
|
|
(notify?
|
|
(send statistics-channel
|
|
(list (cons 'running (length running))
|
|
(cons 'ready (length ready))
|
|
(cons 'new-output (length new-output))
|
|
(cons 'waiting-for-input (length waiting-for-input))))
|
|
(lp running ready new-output waiting-for-input #f))
|
|
(else
|
|
(apply
|
|
select
|
|
(append
|
|
(list
|
|
(wrap (receive-rv add-job-channel)
|
|
(lambda (new-job)
|
|
(lp (cons new-job running)
|
|
ready new-output waiting-for-input #t)))
|
|
|
|
(wrap (receive-rv get-job-list-channel)
|
|
(lambda (state.channel)
|
|
(send (cdr state.channel)
|
|
(case (car state.channel)
|
|
((running) running)
|
|
((ready) ready)
|
|
((new-output) new-output)
|
|
((waiting-for-input) waiting-for-input)
|
|
(else
|
|
(error "joblist-surveillant" state.channel))))
|
|
(lp running ready new-output waiting-for-input #f))))
|
|
|
|
(map (lambda (job)
|
|
(wrap (job-status-rv job)
|
|
(lambda (ignore)
|
|
(lp (delete job running)
|
|
(cons job ready)
|
|
new-output
|
|
waiting-for-input #t))))
|
|
running))))))))
|
|
statistics-channel))
|
|
|
|
(define (initial-job-statistics)
|
|
(list (cons 'running 0)
|
|
(cons 'ready 0)
|
|
(cons 'new-output 0)
|
|
(cons 'waiting-for-input 0)))
|
|
|
|
;; #### unfinished
|
|
(define (install-terminal/stop-handler)
|
|
(set-interrupt-handler
|
|
interrupt/tstp
|
|
(lambda args
|
|
(display args))))
|
|
|
|
(define-syntax run-as-background-job
|
|
(syntax-rules ()
|
|
((_ epf)
|
|
(call-with-values
|
|
(lambda ()
|
|
(fork-pty-session
|
|
(lambda ()
|
|
(exec-epf epf))))
|
|
(lambda (proc pty-in pty-out tty-name)
|
|
(make-job (quote epf) pty-in pty-out proc))))))
|