From 13be7874d50b16ec950ee6e07e9849107314cf4d Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Mon, 1 Oct 2012 00:41:55 +0100
Subject: Implement pipe fitting

---
 scsh-process.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file 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
-- 
cgit v1.2.3