Provide a more complete set of primitives, and convert fit-pipes to fork/pipe+ chain

3 files changed, 158 insertions, 61 deletions

diff --git a/scsh-process.meta b/scsh-process.meta
index f38b7dc..edc6eab 100644
--- a/scsh-process.meta
+++ b/scsh-process.meta
@@ -6,5 +6,5 @@
  (license "BSD")
  (doc-from-wiki)
  ;(depends)
- ;(test-depends test)
+ (test-depends test)
  (files "scsh-process.meta" "scsh-process.setup" "scsh-process.scm"))
diff --git a/scsh-process.scm b/scsh-process.scm
index 2e132f1..9d92ac1 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -11,12 +11,115 @@
 ;; BIG FAT WARNING: Don't mix this with threading, or Bad Things will happen
 
 (module scsh-process
-  ((& fit-pipes) (run fit-pipes) (exec-epf fit-pipes)
-   exec-path)
+  (;; procedures
+   exec-path 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
+   (& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string))
 
 (import chicken scheme data-structures)
 
-(use posix)
+(use extras utils files ports posix srfi-1)
+
+;; 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
+;; use something similar to that, but it's more work.
+(define (exec-path prog . args)
+  ;; Args can include numbers and such, too!  That's why we're using ->string
+  (process-execute (maybe-symbol->string prog) (map ->string args)))
+
+;; TODO: continue-threads argument
+(define (fork/pipe #!optional thunk)
+  (fork/pipe+ '((1 2 0)) thunk))
+
+(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
+        (begin
+          (for-each (lambda (p from-fds-for-this-p)
+                      ;; Close receiving ends of pipes in child.
+                      (file-close (car p))
+                      ;; Set up linkage from output fds to created pipes.
+                      (for-each (lambda (from-fd)
+                                  (duplicate-fileno (cadr p) from-fd))
+                                from-fds-for-this-p))
+                    pipe-pairs from-fds)
+          (if thunk (thunk) pid))
+        (begin                          ; Parent
+          (for-each (lambda (p to-fd)
+                      ;; Close sending end in parent.
+                      (file-close (cadr p))
+                      ;; Set up linkage from created pipes to the input fds.
+                      (duplicate-fileno (car p) to-fd))
+                    pipe-pairs to-fds)
+          pid))))
+
+;; TODO: Differentiate between fork and %fork
+(define %fork/pipe fork/pipe)
+(define %fork/pipe+ fork/pipe+)
+
+(define (maybe-symbol->string s)
+  (if (symbol? s) (symbol->string s) s))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Baroque procedural interface ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Documented under http://www.scsh.net/docu/html/man-Z-H-3.html#node_sec_2.4.2
+(define (run/collecting* fds thunk)
+  (let* ((temp-files (map (lambda () (open-input-file (create-temporary-file)))
+                          fds))
+         (conns (map (lambda (temp-fd from-fd)
+                       (list from-fd (open-input-file* temp-fd)))
+                     temp-files fds)))
+    (apply values (fork/pipe+ conns thunk) temp-files)))
+
+(define (run/port* thunk)
+  (fork/pipe (lambda () (with-output-to-port (open-output-file* 1) thunk)))
+  (open-input-file* 0))
+(define (run/file* thunk)
+  (error "not yet implemented"))
+(define (run/string* thunk)
+  (read-string #f (run/port* thunk)))
+(define (run/strings* thunk)
+  (read-lines (run/port* thunk)))
+(define (run/sexp* thunk)
+  (read (run/port* thunk)))
+(define (run/sexps* thunk)
+  (read-all (run/port* thunk)))
+
+;;;;;;;;;;;;
+;; Syntax ;;
+;;;;;;;;;;;;
+
+(define-syntax run/collecting
+  (syntax-rules ()
+    ((_ ?fds ?epf ...) (run/collecting* `?fds (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/file
+  (syntax-rules ()
+    ((_ ?epf ...) (run/file* (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/port
+  (syntax-rules ()
+    ((_ ?epf ...) (run/port* (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/string
+  (syntax-rules ()
+    ((_ ?epf ...) (run/string* (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/strings
+  (syntax-rules ()
+    ((_ ?epf ...) (run/strings* (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/sexp
+  (syntax-rules ()
+    ((_ ?epf ...) (run/sexp* (lambda () (exec-epf ?epf ...))))))
+(define-syntax run/sexps
+  (syntax-rules ()
+    ((_ ?epf ...) (run/sexps* (lambda () (exec-epf ?epf ...))))))
 
 (define-syntax &
   (syntax-rules ()
@@ -39,9 +142,6 @@
        (process-wait (& ?epf ...))
        (values exit-status normal-exit? pid)))))
 
-(define (maybe-symbol->string s)
-  (if (symbol? s) (symbol->string s) s))
-
 ;; Perhaps this should really be a procedure?
 (define-syntax setup-redirection
   (syntax-rules (< > << >> = - stdports)
@@ -79,66 +179,30 @@
     ((_ ?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
   ;; 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 ...))
+    ((_ (pipe ?pf0 ...) ?redir0 ...)
+     (exec-epf (pipe+ ((1 2 0)) ?pf0 ...) ?redir0 ...))
+    ((_ (pipe+ ?args ...) ?redir0 ...)
      (let-syntax
-         ((exec-pipe+
+         ((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 ...))
+             ((_ ((?from0 ?from1 ___ ?to) ___) ?pf0 ___ ?last-pf)
+              (let ((conns `((?from0 ?from1 ___ ?to) ___)))
+                 (setup-redirection ?redir0) ...
+                (begin (fork/pipe+ conns (lambda () (exec-epf (epf ?pf0))))
+                       ___
+                       (exec-epf (epf ?last-pf))))))))
+       (pipe+ ?args ...)))
+    ((_ (begin ?expr0 ...))
      (begin (setup-redirection (= 0 (current-input-port)))
             (setup-redirection (= 1 (current-output-port)))
             (setup-redirection (= 2 (current-error-port)))
-            ?expr0 ?expr1 ...))
+            ?expr0 ...))
     ;; epf can be used if you happen to have a program called
     ;; "epf", "begin", "pipe", etc which you'd like to run.
     ((_ (epf ?args ...))
@@ -153,9 +217,4 @@
     ((_ (?prog ?arg0 ...) ?redir0 ...)
      (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
-;; use something similar to that, but it's more work.
-(define (exec-path prog . args)
-  (process-execute (maybe-symbol->string prog) (map maybe-symbol->string args)))
 )
\ No newline at end of file
diff --git a/test/run.scm b/test/run.scm
new file mode 100644
index 0000000..1256845
--- /dev/null
+++ b/test/run.scm
@@ -0,0 +1,38 @@
+(include "../scsh-process.scm")
+(import scsh-process)
+
+(use test posix)
+
+(test-group "Procedural interface"
+  (test "Fork/pipe \"hello world\" example from SCSH reference manual"
+        "Hello, world."
+        (begin (fork/pipe
+                (lambda ()
+                  (with-output-to-port (open-output-file* 1)
+                    (lambda () (display "Hello, world.\n") (exit 0)))))
+               (read-line (open-input-file* 0))))
+  (test "run/string* returns a string output in a subprocess"
+        "This is a test"
+        (run/string* (lambda () (display "This is a test") (exit 0)))))
+
+(test-group "Macro (EPF) interface"
+ (delete-file* "outfile")               ; Leftovers
+ (let ((outfile "outfile"))
+   (test "Subprocess writing to a file"
+         "hi, there\n"
+         (begin (run (echo "hi, there") (> ,outfile))
+                (read-all "outfile"))))
+ 
+ (delete-file* "outfile")
+ (let ((echo-command 'echo))
+   (test "Subprocess piped to another process, writing to a file"
+         "1235\n"
+         (begin (run (pipe (,echo-command "1234" + 1) ("bc")) (> outfile))
+                (read-all "outfile"))))
+ (delete-file* "outfile")
+
+ (test "Simple run/string"
+       "hi, there\n"
+       (run/string (echo "hi, there"))))
+
+(test-exit)
\ No newline at end of file