diff options
| -rw-r--r-- | scsh-process.scm | 76 |
1 files changed, 69 insertions, 7 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index 74727ce..2e132f1 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -8,9 +8,10 @@ ;; ;; || wasn't changed, but it's really the zero-length symbol ;; +;; BIG FAT WARNING: Don't mix this with threading, or Bad Things will happen (module scsh-process - ((& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string) + ((& fit-pipes) (run fit-pipes) (exec-epf fit-pipes) exec-path) (import chicken scheme data-structures) @@ -78,18 +79,79 @@ ((_ ?arg0 ...) (syntax-error "Invalid redirection pattern: " `?arg0 ...)))) +(define (fit-pipes from-fds to-fds progs) + (define (make-pipes) (map (lambda _ (receive (create-pipe))) to-fds)) + (when (null? progs) (error "Can't fit a pipeline between zero programs")) + (let ((initial-pairs (make-pipes))) + ;; Close sending ends of these pipes; they're unused. + (for-each (lambda (p) (file-close (cadr p))) initial-pairs) + (let lp ((input-pairs initial-pairs) + (progs progs)) + (if (null? (cdr progs)) + (begin + ;; Fit the final input pipes to their respective fds. + (for-each (lambda (to-fd p) + (duplicate-fileno (car p) to-fd) + (file-close (car p))) + to-fds input-pairs) + ((car progs))) + ;; Subprocess output goes into fds in output-pairs. Their matching + ;; input fds are used as input for the next process in the pipeline. + (let ((output-pairs (make-pipes))) + (process-fork (lambda () + ;; Close receiving end in child and set up linkage + ;; from the output descriptors to the created pipes. + (for-each (lambda (p from-fds-for-this-p) + (file-close (car p)) + (for-each (lambda (from-fd) + (duplicate-fileno (cadr p) from-fd)) + from-fds-for-this-p)) + output-pairs from-fds) + ;; Set up input descriptors + (for-each (lambda (to-fd p) + (duplicate-fileno (car p) to-fd) + (file-close (car p))) + to-fds input-pairs) + ((car progs)))) + ;; Close sending ends of the output pairs in the parent. + (for-each (lambda (op) (file-close (cadr op))) output-pairs) + (lp output-pairs (cdr progs))))))) + ;; The most "core" syntax form (define-syntax exec-epf - (syntax-rules (begin) - ((_ (begin ?expr0 ...)) + ;; The nested let-syntaxes exist to let us pre-empt the fallthrough + ;; whenever we see one of the recognised special rules so we don't end up + ;; with the generic one if we happen to make a small mistake + (syntax-rules (pipe pipe+ begin epf) + ((_ (pipe ?pf0 ?pf1 ...)) + (exec-epf (pipe+ ((1 2 0)) ?pf0 ?pf1 ...))) + ((_ (pipe+ ?args ...)) + (let-syntax + ((exec-pipe+ + (syntax-rules ___ () + ((_ ((?from0 ?from1 ___ ?to) ___) (?prog0 ?arg0 ___) ___) + (fit-pipes `((?from0 ?from1 ___) ___) + `(?to ___) + (list (lambda () (exec-path `?prog0 `?arg0 ___)) ___)))))) + (exec-pipe+ ?args ...))) + ((_ (begin ?expr0 ?expr1 ...)) (begin (setup-redirection (= 0 (current-input-port))) (setup-redirection (= 1 (current-output-port))) (setup-redirection (= 2 (current-error-port))) - ?expr0 ...)) + ?expr0 ?expr1 ...)) + ;; epf can be used if you happen to have a program called + ;; "epf", "begin", "pipe", etc which you'd like to run. + ((_ (epf ?args ...)) + (let-syntax ((exec-epf + (syntax-rules ___ () + ((_ (?prog ?arg0 ___) ?redir0 ___) + (begin + (setup-redirection ?redir0) ___ + (exec-path `?prog `?arg0 ___)))))) + (exec-epf ?args ...))) + ;; This is purely for convenience, so you don't need the (epf ...) wrapper ((_ (?prog ?arg0 ...) ?redir0 ...) - (begin - (setup-redirection ?redir0) ... - (exec-path `?prog `?arg0 ...))))) + (exec-epf (epf (?prog ?arg0 ...) ?redir0 ...))))) ;; 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 |