* Makefile.am (ice9_sources): Add popen.scm to list.

* Makefile.in: Regenerated.
* popen.scm: applied fixes from Greg Harvey.  use a guardian
and a gc-thunk so that cleanup is done if a pipe is garbage
collected or closed with close-port.  use a weak hash-table instead of
an alist.
* boot-9.scm (reopen-file): deleted.
* popen.scm (open-output-pipe, open-input-pipe): moved from
boot-9.scm.
* popen.scm: new file.

diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index 2c05d8a..7a689fd 100644 (file)
--- a/ice-9/Makefile.am
+++ b/ice-9/Makefile.am
@@ -26,8 +26,8 @@ ice9_sources = \
        and-let*.scm boot-9.scm calling.scm common-list.scm debug.scm   \
        emacs.scm expect.scm format.scm getopt-gnu-style.scm            \
        getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm         \
-       optargs.scm poe.scm psyntax.pp psyntax.ss q.scm r4rs.scm        \
-       readline.scm regex.scm runq.scm session.scm slib.scm            \
+       optargs.scm poe.scm popen.scm psyntax.pp psyntax.ss q.scm       \
+       r4rs.scm readline.scm regex.scm runq.scm session.scm slib.scm   \
        string-fun.scm syncase.scm tags.scm threads.scm
 
 # These should be installed, but not distributed.

diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
index 713fb58..19bbe4a 100644 (file)
--- a/ice-9/Makefile.in
+++ b/ice-9/Makefile.in
@@ -94,7 +94,7 @@ qtmds_s = @qtmds_s@
 AUTOMAKE_OPTIONS = foreign
 
 # These should be installed and distributed.
-ice9_sources =         and-let*.scm boot-9.scm calling.scm common-list.scm debug.scm           emacs.scm expect.scm format.scm getopt-gnu-style.scm                    getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm                 optargs.scm poe.scm psyntax.pp psyntax.ss q.scm r4rs.scm                readline.scm regex.scm runq.scm session.scm slib.scm                    string-fun.scm syncase.scm tags.scm threads.scm
+ice9_sources =         and-let*.scm boot-9.scm calling.scm common-list.scm debug.scm           emacs.scm expect.scm format.scm getopt-gnu-style.scm                    getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm                 optargs.scm poe.scm popen.scm psyntax.pp psyntax.ss q.scm               r4rs.scm readline.scm regex.scm runq.scm session.scm slib.scm           string-fun.scm syncase.scm tags.scm threads.scm
 
 
 # These should be installed, but not distributed.

diff --git a/ice-9/popen.scm b/ice-9/popen.scm
new file mode 100644 (file)
index 0000000..0c93615
--- /dev/null
+++ b/ice-9/popen.scm
@@ -0,0 +1,83 @@
+;; popen emulation, for non-stdio based ports.
+
+(define-module (ice-9 popen))
+
+;;    (define-module (guile popen)
+;;      :use-module (guile posix))
+
+;; a guardian to ensure the cleanup is done correctly when
+;; an open pipe is gc'd or a close-port is used.
+(define pipe-guardian (make-guardian))
+
+;; a weak hash-table to store the process ids.
+(define port/pid-table (make-weak-key-hash-table 31))
+
+;; run a process connected to an input or output port.
+;; mode: OPEN_READ or OPEN_WRITE.
+;; returns port/pid pair.
+(define (open-process mode prog . args)
+  (let ((p (pipe))
+       (reading (string=? mode OPEN_READ)))
+    (setvbuf (cdr p) _IONBF)
+    (let ((pid (primitive-fork)))
+      (cond ((= pid 0)
+            ;; child
+            (set-batch-mode?! #t)
+            (if reading
+                (close-port (car p))
+                (close-port (cdr p)))
+            (move->fdes (if reading (cdr p) (car p))
+                        (if reading 1 0))
+            (apply execlp prog prog args))
+           (else
+            ;; parent
+            (if reading
+                (close-port (cdr p))
+                (close-port (car p)))
+            (cons (if reading
+                      (car p)
+                      (cdr p))
+                  pid))))))
+
+(define-public (open-pipe command mode)
+  (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
+        (port (car port/pid)))
+    (pipe-guardian port)
+    (hashq-set! port/pid-table port (cdr port/pid))
+    port))
+
+(define (fetch-pid port)
+  (let ((pid (hashq-ref port/pid-table port)))
+    (hashq-remove! port/pid-table port)
+    pid))
+
+(define (close-process port/pid)
+  (close-port (car port/pid))
+  (cdr (waitpid (cdr port/pid))))
+
+(define-public (close-pipe p)
+  (let ((pid (fetch-pid p)))
+    (if (not pid)
+        (error "close-pipe: pipe not in table"))
+    (close-process (cons p pid))))
+
+(define reap-pipes
+  (lambda ()
+    (let loop ((p (pipe-guardian)))
+      (cond (p 
+            ;; maybe removed already by close-pipe.
+            (let ((pid (fetch-pid p)))
+              (if pid
+                  (close-process (cons p pid))))
+            (loop (pipe-guardian)))))))
+
+(set! gc-thunk 
+      (let ((old-thunk gc-thunk))
+       (lambda ()
+         (if old-thunk (old-thunk))
+         (reap-pipes))))
+
+;; (add-hook! after-gc-hook reap-pipes)
+
+(define-public (open-input-pipe command) (open-pipe command OPEN_READ))
+(define-public (open-output-pipe command) (open-pipe command OPEN_WRITE))