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