jobcontrol WIP
This commit is contained in:
parent
3431779da2
commit
68767152ec
89
sh/pipe.scm
89
sh/pipe.scm
|
@ -1,16 +1,19 @@
|
||||||
(define-module (sh pipe)
|
(define-module (sh pipe)
|
||||||
:use-module (ice-9 popen)
|
:use-module (ice-9 popen)
|
||||||
|
:use-module (srfi srfi-1)
|
||||||
:use-module (srfi srfi-8)
|
:use-module (srfi srfi-8)
|
||||||
|
:use-module (srfi srfi-9)
|
||||||
|
:use-module (srfi srfi-26)
|
||||||
:export (pipeline))
|
:export (pipeline))
|
||||||
|
|
||||||
(define (pipe*)
|
(define (pipe*)
|
||||||
(let ((p (pipe)))
|
(let ((p (pipe)))
|
||||||
(values (car p) (cdr p))))
|
(values (car p) (cdr p))))
|
||||||
|
|
||||||
;; lhs rhs
|
;; lhs rhs
|
||||||
;; [source] w -> r [filter] w -> r [sink]
|
;; [source] w -> r [filter] w -> r [sink]
|
||||||
|
|
||||||
(define (exec* command)
|
(define (exec* command) ;; list of strings
|
||||||
(apply execlp (cons (car command) command)))
|
(apply execlp (cons (car command) command)))
|
||||||
|
|
||||||
(define (spawn-source command)
|
(define (spawn-source command)
|
||||||
|
@ -53,4 +56,86 @@
|
||||||
(cdr commands))))
|
(cdr commands))))
|
||||||
(apply system* (car commands))))
|
(apply system* (car commands))))
|
||||||
|
|
||||||
|
;;(pipeline (list "ls" "/")
|
||||||
;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e"))
|
;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e"))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (stdout . o)
|
||||||
|
(map display o)
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(define (stderr . o)
|
||||||
|
(map (cut display <> (current-error-port)) o)
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(define-record-type <job>
|
||||||
|
(make-job id pid pgid command status )
|
||||||
|
job?
|
||||||
|
(id job-id)
|
||||||
|
(pid job-pid)
|
||||||
|
(pgid job-pgid)
|
||||||
|
(command job-command)
|
||||||
|
(status job-status set-job-status!)) ;; '(running stopped completed terminated)
|
||||||
|
|
||||||
|
(define job-table '())
|
||||||
|
|
||||||
|
(define (job-control-init)
|
||||||
|
(let* ((interactive? (isatty? (current-input-port)))
|
||||||
|
(pid (getpid))
|
||||||
|
(pgid pid))
|
||||||
|
(when interactive?
|
||||||
|
(map (cut sigaction <> SIG_IGN)
|
||||||
|
(list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))
|
||||||
|
(setpgid pid pgid)
|
||||||
|
(tcsetpgrp (current-input-port) pid))))
|
||||||
|
|
||||||
|
(define (job-launch command fg?)
|
||||||
|
(let* ((interactive? (isatty? (current-input-port)))
|
||||||
|
(pgid (getpid))
|
||||||
|
(pid (primitive-fork)))
|
||||||
|
(if (= 0 pid)
|
||||||
|
(when interactive?
|
||||||
|
(setpgid pid pgid)
|
||||||
|
(if fg? (tcsetpgrp (current-input-port) pgid))
|
||||||
|
(map (cut sigaction <> SIG_DFL)
|
||||||
|
(list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD))
|
||||||
|
(map move->fdes
|
||||||
|
(list (current-input-port) (current-output-port) (current-error-port))
|
||||||
|
(iota 4))
|
||||||
|
(exec* command)
|
||||||
|
(exit 1))
|
||||||
|
(when interactive?
|
||||||
|
(setpgid pid pgid)
|
||||||
|
(set! job-table
|
||||||
|
(acons pid
|
||||||
|
(make-job (length job-table) pid pgid command 'running)
|
||||||
|
job-table))
|
||||||
|
(when fg?
|
||||||
|
(waitpid pid WUNTRACED)
|
||||||
|
(tcsetpgrp (current-input-port) (getpid)))))))
|
||||||
|
|
||||||
|
(define (set-job-stopped! job-table pid)
|
||||||
|
(set-job-status! (assoc-ref job-table pid) 'stopped))
|
||||||
|
|
||||||
|
(define (update-job-status job-table)
|
||||||
|
(let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG)))
|
||||||
|
(pid (car pid-status))
|
||||||
|
(status (cdr pid-status)))
|
||||||
|
(if (and (not (= 0 pid))
|
||||||
|
(status:stop-sig status))
|
||||||
|
(set-job-stopped! pid job-table))))
|
||||||
|
|
||||||
|
;(define (handle-children sig))
|
||||||
|
|
||||||
|
(define (background job-id)
|
||||||
|
(let ((job (if (< job-id (length job-table)) (list-ref job-table job-id) #f)))
|
||||||
|
(if (and job (eq? 'stopped job-status))
|
||||||
|
(kill (- (job-pgid job)) SIGCONT))))
|
||||||
|
|
||||||
|
;; (define (foreground job)
|
||||||
|
;; ())
|
||||||
|
|
||||||
|
;; (init)
|
||||||
|
|
||||||
|
;; (launch (list "sleep" "10") #t)
|
||||||
|
|
Loading…
Reference in New Issue