diff --git a/geesh/shell.scm b/geesh/shell.scm index cca7870..a27b2fc 100644 --- a/geesh/shell.scm +++ b/geesh/shell.scm @@ -7,6 +7,7 @@ #:use-module (srfi srfi-26) #:export (sh:exec-let sh:exec + sh:pipeline sh:subshell sh:substitute-command sh:with-redirects)) @@ -211,3 +212,58 @@ a string." ((pid . status) (waitpid pid))) (set-var! env "?" (number->string (status:exit-val status))) result))) + + +;;; Pipelines. + +(define (swap-and-shift-pairs pairs) + "Swap and shift @var{pairs} over by one. For example, the list +@code{((a . b) (c . d))} becomes @code{((#f . b) (a . d) (c . #f))}" + (let ((kons (lambda (pair acc) + (match-let (((a . b) pair)) + (match acc + ((head . rest) `(,b (,a . ,head) ,@rest)) + (() `(,b (,a . #f)))))))) + (match (fold-right kons '() pairs) + ((head . rest) `((#f . ,head) ,@rest)) + (() '())))) + +(define (make-pipes xs) + "Cons each element of @var{xs} to a pair of ports such that the first +port is an input port connected to the second port of the previous +element's pair, and the second port is an output port connected to the +first port of next element's pair. The first pair will have @code{#f} +for an input port and the last will have @code{#f} as an output port." + (match xs + (() '()) + ((x) `((,x . (#f . #f)))) + (_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs)))) + (map cons xs (swap-and-shift-pairs pipes)))))) + +(define (plumb env in out thunk) + "Run @var{thunk} in a new process with @code{current-input-port} set +to @var{in} and @code{current-output-port} set to @var{out}. If +@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port +is left unchanged." + (let* ((thunk* (lambda () + (let ((in (or in (current-input-port))) + (out (or out (current-output-port)))) + (parameterize ((current-input-port in) + (current-output-port out)) + (thunk))))) + (pid (%subshell thunk*))) + (when in (close-port in)) + (when out (close-port out)) + pid)) + +(define (sh:pipeline env . thunks) + "Run each thunk in @var{thunks} in its own process with the output +of each thunk sent to the input of the next thunk." + (let ((pids (map (match-lambda + ((thunk . (source . sink)) + (plumb env source sink thunk))) + (make-pipes thunks)))) + (unless (null? pids) + (match-let* ((pid (last pids)) + ((pid . status) (waitpid pid))) + (set-var! env "?" (number->string (status:exit-val status))))))) diff --git a/tests/shell.scm b/tests/shell.scm index 08efce2..3de70f8 100644 --- a/tests/shell.scm +++ b/tests/shell.scm @@ -442,4 +442,81 @@ (let ((env (make-environment '()))) (sh:substitute-command env noop))) + +;; Pipelines. + +(test-equal "Built-ins are connected by pipelines" + "foo" + (call-with-temporary-directory + (lambda (directory) + (let ((foo (string-append directory "/foo.txt")) + (env (make-environment '()))) + (sh:pipeline env + (lambda () + (display "foo\n")) + (lambda () + (with-output-to-file foo + (lambda () + (display (get-line (current-input-port))))))) + (call-with-input-file foo get-string-all))))) + +(test-equal "External utilities are connected by pipelines" + "foo" + (call-with-temporary-directory + (lambda (directory) + (let ((utility1 (string-append directory "utility1")) + (utility2 (string-append directory "utility2")) + (foo (string-append directory "/foo.txt")) + (env (make-environment '()))) + (make-script utility1 + (display "foo\n")) + (make-script utility2 + (use-modules (ice-9 textual-ports)) + (with-output-to-file ,foo + (lambda () + (display (get-line (current-input-port)))))) + (sh:pipeline env + (lambda () + (sh:exec env utility1)) + (lambda () + (sh:exec env utility2))) + (call-with-input-file foo get-string-all))))) + +(test-equal "Externals and built-ins are connected by pipelines" + "foo" + (call-with-temporary-directory + (lambda (directory) + (let ((utility (string-append directory "/utility")) + (foo (string-append directory "/foo.txt")) + (env (make-environment '()))) + (make-script utility + (display "foo\n")) + (sh:pipeline env + (lambda () + (sh:exec env utility)) + (lambda () + (with-output-to-file foo + (lambda () + (display (get-line (current-input-port))))))) + (call-with-input-file foo get-string-all))))) + +(test-equal "Built-ins and externals are connected by pipelines" + "foo" + (call-with-temporary-directory + (lambda (directory) + (let ((utility (string-append directory "/utility")) + (foo (string-append directory "/foo.txt")) + (env (make-environment '()))) + (make-script utility + (use-modules (ice-9 textual-ports)) + (with-output-to-file ,foo + (lambda () + (display (get-line (current-input-port)))))) + (sh:pipeline env + (lambda () + (display "foo\n")) + (lambda () + (sh:exec env utility))) + (call-with-input-file foo get-string-all))))) + (test-end)