diff options
Diffstat (limited to 'scsh-process.scm')
| -rw-r--r-- | scsh-process.scm | 116 |
1 files changed, 99 insertions, 17 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index fde9186..d815e6c 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -38,16 +38,99 @@ (module scsh-process (;; procedures - exec-path fork/pipe %fork/pipe fork/pipe+ %fork/pipe+ + exec-path fork %fork fork/pipe %fork/pipe fork/pipe+ %fork/pipe+ run/collecting* run/string* run/strings* run/port* run/file* run/sexp* run/sexps* ;; macros run/collecting run/string run/strings run/port run/file run/sexp run/sexps - || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string)) + || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string) + + process?) (import chicken scheme data-structures) -(use extras utils files ports posix srfi-1) +(use extras utils files ports posix srfi-1 srfi-69) + +;;;;;;;;;;;;;;;;;;;;;;;;; +;; Process bookkeeping ;; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;; This stuff is all required so we can more cleanly and simply run +;; processes without having to wait for all of them in user code. We +;; need to keep a hash table around so that the user can still wait +;; for his own processes without the signal/chld handler interfering +;; with those. It's a bit of hack the way we overwrite the regular +;; process-wait procedure from POSIX, but this allows us to +;; transparently mark off processes which were waited on by the user. + +(define-record scsh-process pid exit-status ok?) + +(define process? scsh-process?) + +(define *scsh-pending-processes* (make-hash-table)) + +(define (add-scsh-pending-process! pid) + (let ((process (make-scsh-process pid #f #f))) + (hash-table-set! *scsh-pending-processes* pid process) + process)) + +(define (remove-scsh-pending-process! pid) + (hash-table-delete! *scsh-pending-processes* pid)) + +(let ((posix-process-wait process-wait)) + (set! process-wait + (lambda (#!optional pid-or-process) + (unless (or (not pid-or-process) + (scsh-process? pid-or-process) + (number? pid-or-process)) + (error 'process-wait + "Not a scsh-type process object or pid" + pid-or-process)) + (let ((p (if (and pid-or-process (number? pid-or-process)) + (hash-table-ref/default *scsh-pending-processes* + pid-or-process #f) + pid-or-process))) + (or (and p (scsh-process-exit-status p)) + (handle-exceptions exn + (if (and p (scsh-process-exit-status p)) ; Signal might've occurred + (values (scsh-process-exit-status p) + (scsh-process-ok? p) + (scsh-process-pid p)) + (abort exn)) + (receive (pid ok? status) + (posix-process-wait (and p (scsh-process-pid p))) + (cond + ((zero? pid) (values #f #f #f)) + (else + (when p + (scsh-process-exit-status-set! p status) + (scsh-process-ok?-set! p ok?)) + (remove-scsh-pending-process! pid) + (values status ok? pid))))))))) + + (set-signal-handler! + signal/chld + (let ((old-handler (signal-handler signal/chld))) + (lambda (signal) + (for-each (lambda (pid) + (handle-exceptions exn + ;; User might have waited manually + (begin (remove-scsh-pending-process! pid) (void)) + (receive (pid ok? status) + (posix-process-wait pid #t) + (unless (zero? pid) + (let ((p (hash-table-ref *scsh-pending-processes* pid))) + (scsh-process-exit-status-set! p status) + (scsh-process-ok?-set! p ok?) + ;; The GC can clean it up + (remove-scsh-pending-process! pid)))))) + (hash-table-keys *scsh-pending-processes*)) + (when old-handler (old-handler signal)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Execution and forking helpers ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: Perhaps expose environment, and mess around with the path so that ;; execve can be used in a sensible way? Scsh has its own PATH, so we could @@ -70,13 +153,19 @@ (thunk) (exit 0))) +(define (fork #!optional thunk) + (let ((pid (if thunk (process-fork thunk) (process-fork)))) + (and (not (zero? pid)) (add-scsh-pending-process! pid)))) + +(define %fork fork) + (define (fork/pipe+ conns #!optional thunk) ;; Blergh, this is silly overhead we don't really need (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns)) (to-fds (map last conns)) (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds)) - (pid (process-fork))) - (if (zero? pid) ; Child + (proc (fork))) + (if (not proc) ; Child (begin (for-each (lambda (p from-fds-for-this-p) ;; Close receiving ends of pipes in child. @@ -98,7 +187,7 @@ ;; No longer needed after duplication. (file-close (car p))) pipe-pairs to-fds) - pid)))) + proc)))) ;; TODO: Differentiate between fork and %fork (define %fork/pipe fork/pipe) @@ -124,14 +213,14 @@ (conns (map (lambda (from-fd temp-file) (list from-fd (port->fileno temp-file))) fds temp-files))) - (receive (p s code) + (receive (code ok? pid) (process-wait (fork/pipe+ conns thunk)) (apply values code temp-files)))) (define (run/port* thunk) (receive (in out) (create-pipe) - (process-fork + (fork (lambda () (run-final-thunk (lambda () @@ -204,18 +293,11 @@ (define-syntax & (syntax-rules () ((_ ?epf ...) - (process-fork (lambda () - (run-final-thunk (lambda () (exec-epf ?epf ...)))))))) + (fork (lambda () (run-final-thunk (lambda () (exec-epf ?epf ...)))))))) (define-syntax run (syntax-rules () - ((_ ?epf ...) - ;; We reorder the values as they make more sense this way for SCSH compat: - ;; scsh returns just the exit code, and conveniently we allow MV in single - ;; value continuations, which makes it compatible. - (receive (pid normal-exit? exit-status) - (process-wait (& ?epf ...)) - (values exit-status normal-exit? pid))))) + ((_ ?epf ...) (process-wait (& ?epf ...))))) ;; Perhaps this should really be a procedure? (define-syntax setup-redirection |