diff options
| -rw-r--r-- | scsh-process.meta | 2 | ||||
| -rw-r--r-- | scsh-process.scm | 179 | ||||
| -rw-r--r-- | test/run.scm | 38 |
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 |