Make job control work
This commit is contained in:
		
							parent
							
								
									34761f66d2
								
							
						
					
					
						commit
						fe9bfbf1a0
					
				| 
						 | 
				
			
			@ -48,32 +48,31 @@
 | 
			
		|||
  (sync (job-status-rv job)))
 | 
			
		||||
 | 
			
		||||
(define (spawn-job-status-surveillant job)
 | 
			
		||||
  (let ((channel (make-channel)))
 | 
			
		||||
    (spawn
 | 
			
		||||
     (lambda ()
 | 
			
		||||
       (let ((status (wait (job-proc job) wait/stopped-children)))
 | 
			
		||||
	 (cond 
 | 
			
		||||
	  ((status:exit-val status) 
 | 
			
		||||
	   => (lambda (i)
 | 
			
		||||
		(debug-message "spawn-job-status-surveillant exit-val")
 | 
			
		||||
		(set-job-run-status! job 'ready)
 | 
			
		||||
		(set-job-end-time! job (date))))
 | 
			
		||||
	   ((status:stop-sig status)
 | 
			
		||||
	    => (lambda (signal)
 | 
			
		||||
		 (debug-message "spawn-job-status-surveillant stop-sig")
 | 
			
		||||
		 (cond
 | 
			
		||||
		  ((= signal signal/ttin)
 | 
			
		||||
		   (set-job-run-status! job 'waiting-for-input))
 | 
			
		||||
		  ((= signal signal/ttou)
 | 
			
		||||
		   (set-job-run-status! job 'new-output))
 | 
			
		||||
		  (else
 | 
			
		||||
		   (set-job-run-status! job 'stopped)))))
 | 
			
		||||
	   ((status:term-sig status)
 | 
			
		||||
	    => (lambda (i)
 | 
			
		||||
		 (debug-message "spawn-job-status-surveillant term-sig")
 | 
			
		||||
		 (set-job-run-status! job 'stopped))))
 | 
			
		||||
	 (placeholder-set! 
 | 
			
		||||
	  (really-job-status job) status))))))
 | 
			
		||||
  (spawn
 | 
			
		||||
   (lambda ()
 | 
			
		||||
     (let ((status (wait (job-proc job) wait/stopped-children)))
 | 
			
		||||
       (cond 
 | 
			
		||||
	((status:exit-val status) 
 | 
			
		||||
	 => (lambda (i)
 | 
			
		||||
	      (debug-message "spawn-job-status-surveillant exit-val")
 | 
			
		||||
	      (set-job-run-status! job 'ready)
 | 
			
		||||
	      (set-job-end-time! job (date))))
 | 
			
		||||
	((status:stop-sig status)
 | 
			
		||||
	 => (lambda (signal)
 | 
			
		||||
	      (debug-message "spawn-job-status-surveillant stop-sig")
 | 
			
		||||
	      (cond
 | 
			
		||||
	       ((= signal signal/ttin)
 | 
			
		||||
		(set-job-run-status! job 'waiting-for-input))
 | 
			
		||||
	       ((= signal signal/ttou)
 | 
			
		||||
		(set-job-run-status! job 'new-output))
 | 
			
		||||
	       (else
 | 
			
		||||
		(set-job-run-status! job 'stopped)))))
 | 
			
		||||
	((status:term-sig status)
 | 
			
		||||
	 => (lambda (i)
 | 
			
		||||
	      (debug-message "spawn-job-status-surveillant term-sig")
 | 
			
		||||
	      (set-job-run-status! job 'stopped))))
 | 
			
		||||
       (placeholder-set! 
 | 
			
		||||
	(really-job-status job) status)))))
 | 
			
		||||
 | 
			
		||||
(define (job-running? job)
 | 
			
		||||
  (eq? (job-run-status job) 'running))
 | 
			
		||||
| 
						 | 
				
			
			@ -101,7 +100,8 @@
 | 
			
		|||
  (set-job-run-status! job 'running)
 | 
			
		||||
  (signal-process-group 
 | 
			
		||||
   (proc:pid (job-proc job)) signal/cont)
 | 
			
		||||
  (spawn-job-status-surveillant job))
 | 
			
		||||
  (spawn-job-status-surveillant job)
 | 
			
		||||
  (send notify-continue/foreground-channel job))
 | 
			
		||||
 | 
			
		||||
(define (pause-job-output job)
 | 
			
		||||
  (pause-console-output (job-console job)))
 | 
			
		||||
| 
						 | 
				
			
			@ -138,6 +138,9 @@
 | 
			
		|||
(define clear-ready-jobs-channel
 | 
			
		||||
  (make-channel))
 | 
			
		||||
 | 
			
		||||
(define notify-continue/foreground-channel
 | 
			
		||||
  (make-channel))
 | 
			
		||||
 | 
			
		||||
(define (add-job! job)
 | 
			
		||||
  (send add-job-channel job))
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -196,6 +199,14 @@
 | 
			
		|||
		      (lp (cons new-job running)
 | 
			
		||||
			  ready stopped new-output waiting-for-input #t)))
 | 
			
		||||
 | 
			
		||||
	      (wrap (receive-rv notify-continue/foreground-channel)
 | 
			
		||||
		    (lambda (job)
 | 
			
		||||
		      (lp (cons job running)
 | 
			
		||||
			  ready 
 | 
			
		||||
			  (delete job stopped)
 | 
			
		||||
			  (delete job new-output)
 | 
			
		||||
			  (delete job waiting-for-input) #t)))
 | 
			
		||||
 | 
			
		||||
	      (wrap (receive-rv clear-ready-jobs-channel)
 | 
			
		||||
		    (lambda (ignore)
 | 
			
		||||
		      (lp running '() stopped new-output waiting-for-input #t)))
 | 
			
		||||
| 
						 | 
				
			
			@ -306,29 +317,17 @@
 | 
			
		|||
(define-syntax go/bg
 | 
			
		||||
  (syntax-rules ()
 | 
			
		||||
    ((_ epf)
 | 
			
		||||
     (let* ((orig (tty-info (current-output-port)))
 | 
			
		||||
	    (child (copy-tty-info orig)))
 | 
			
		||||
     (begin
 | 
			
		||||
       (obtain-lock paint-lock)
 | 
			
		||||
       (endwin)
 | 
			
		||||
       (drain-tty (current-output-port))
 | 
			
		||||
;       (set-tty-process-group (current-output-port) (pid))
 | 
			
		||||
       (set-tty-info:local-flags 
 | 
			
		||||
	child
 | 
			
		||||
	(bitwise-and (tty-info:local-flags child)
 | 
			
		||||
		     ttyl/ttou-signal))
 | 
			
		||||
       (set-tty-info/now (current-output-port) child)
 | 
			
		||||
       (set-tty-process-group (current-output-port) (pid))
 | 
			
		||||
       (let ((proc
 | 
			
		||||
 	      (fork
 | 
			
		||||
 	       (lambda ()
 | 
			
		||||
		 (set-process-group (pid) (pid))
 | 
			
		||||
 		 (exec-epf epf)))))
 | 
			
		||||
 	 (let ((job (make-job-sans-console (quote epf) proc)))
 | 
			
		||||
	   (set-tty-info/now (current-output-port) orig)
 | 
			
		||||
	   (release-lock paint-lock)
 | 
			
		||||
 	   job))))))
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
;	   (set-tty-info/now (current-input-port) info)))))))
 | 
			
		||||
 | 
			
		||||
;;; EOF
 | 
			
		||||
 | 
			
		||||
;;; EOF
 | 
			
		||||
| 
						 | 
				
			
			@ -257,7 +257,9 @@
 | 
			
		|||
  (for-each 
 | 
			
		||||
   (lambda (signal)
 | 
			
		||||
     (set-interrupt-handler signal #f))
 | 
			
		||||
   (list interrupt/int interrupt/quit interrupt/tstp))
 | 
			
		||||
   (list interrupt/int 
 | 
			
		||||
	 ;interrupt/quit 
 | 
			
		||||
	 interrupt/tstp))
 | 
			
		||||
  (set-interrupt-handler signal/ttin terminal-input-handler)
 | 
			
		||||
  (set-interrupt-handler signal/ttou terminal-output-handler))
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -265,7 +267,7 @@
 | 
			
		|||
  (let ((info (copy-tty-info (tty-info port))))
 | 
			
		||||
    (set-tty-info:local-flags
 | 
			
		||||
     info
 | 
			
		||||
     (bitwise-and (tty-info:local-flags info)
 | 
			
		||||
     (bitwise-ior (tty-info:local-flags info)
 | 
			
		||||
		  ttyl/ttou-signal))
 | 
			
		||||
    (set-tty-info/now port info)))
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -275,6 +277,9 @@
 | 
			
		|||
;; handle input
 | 
			
		||||
(define (run)
 | 
			
		||||
  (save-initial-tty-info! (current-input-port))
 | 
			
		||||
 | 
			
		||||
  (autoreap-policy #f)
 | 
			
		||||
 | 
			
		||||
  (init-screen)
 | 
			
		||||
  (init-windows!)
 | 
			
		||||
  (clear)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue