unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* guile pipeline do-over
@ 2020-03-06  9:52 Rutger van Beusekom
  2020-03-07 15:46 ` Ludovic Courtès
  0 siblings, 1 reply; 8+ messages in thread
From: Rutger van Beusekom @ 2020-03-06  9:52 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 1421 bytes --]

Hi,

I submitted a previous version of this patch yesterday, only to find
that making last minute changes is a big fat no no. Anyhow, having fixed
the two problems I found, I also added the tests I should have written
and run before sending my patch.

Best,
Rutger

Content of previous email below:

This patch replaces open-process with piped-process in posix.c and
reimplement open-process with piped-process in popen.scm. This allows
setting up a pipeline in guile scheme using the new pipeline procedure
in popen.scm and enables its use on operating systems which happen to
lack the capability to fork, but do offer the capability captured by
start_child (see posix.c).

The snippet below demonstrates the backwards compatibility of this patch
as well as the feature it offers:

(use-modules (ice-9 popen))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 receive))

(receive (from to pid)
    ((@@ (ice-9 popen) open-process) OPEN_BOTH "rev")
  (display "dlrow olleh" to) (close to)
  (display (read-string from)) (newline)
  (display (status:exit-val (cdr (waitpid pid)))) (newline))

(receive (from to pids)
    (pipeline '(("echo" "dlrow olleh") ("rev")))
  (display (read-string from))
  (display (map waitpid pids)) (newline))

(let ((p (pipe)))
  (piped-process "echo" '("foo" "bar")
                 (cons (port->fdes (car p))
                       (port->fdes (cdr p))))
  (display (read-string (car p))))


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: PATCH --]
[-- Type: text/x-diff, Size: 9293 bytes --]

From 3c8f5d534419418234cfe7d3eda8227951bc208a Mon Sep 17 00:00:00 2001
From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
Date: Mon, 2 Mar 2020 10:38:57 +0100
Subject: [PATCH] Allow client code to create pipe pairs when opening a
 process.

* libguile/posix.c (scm_piped_process): Replace open_process by piped_process.
* module/ice-9/popen.scm (pipe->fdes): Convert pipe pair to fdes pair.
(open-process): Implement open-process with piped-process.
(pipeline): Implement a pipeline with piped-process.
---
 libguile/posix.c            | 89 ++++++++++++++++---------------------
 module/ice-9/popen.scm      | 32 ++++++++++++-
 test-suite/tests/popen.test | 34 ++++++++++++++
 3 files changed, 104 insertions(+), 51 deletions(-)

diff --git a/libguile/posix.c b/libguile/posix.c
index a1520abc4..81f5ebde2 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1368,55 +1368,56 @@ start_child (const char *exec_file, char **exec_argv,
 
 #ifdef HAVE_START_CHILD
 static SCM
-scm_open_process (SCM mode, SCM prog, SCM args)
-#define FUNC_NAME "open-process"
+scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
+#define FUNC_NAME "piped-process"
+/* SCM_DEFINE (scm_piped_process, "piped-process", 2, 2, 0, */
+/*            (SCM prog, SCM args, SCM from, SCM to), */
+/* "Execute the command indicated by @var{prog} with arguments @var(args),\n" */
+/* "optionally connected by an input and an output pipe.\n" */
+/* "@var(from) and @var(to) are either #f or a valid file descriptor\n" */
+/* "of an input and an output pipe, respectively.\n" */
+/* "\n" */
+/* "This function returns the PID of the process executing @var(prog)." */
+/* "\n" */
+/* "Example:\n" */
+/* "(let ((p (pipe)))\n" */
+/* "  (piped-process \"echo\" '(\"foo\" \"bar\")\n" */
+/* "                 (cons (port->fdes (car p))\n" */
+/* "                       (port->fdes (cdr p))))\n" */
+/* "  (display (read-string (car p))))\n" */
+/* "(let ((p (pipe)))\n" */
+/* "  (read-string (piped-process \"echo\" '(\"foo\" \"bar\")\n" */
+/* "                              (port->fdes (car p)))))\n") */
+/* #define FUNC_NAME scm_piped_process */
 {
-  long mode_bits;
   int reading, writing;
-  int c2p[2]; /* Child to parent.  */
-  int p2c[2]; /* Parent to child.  */
+  int c2p[2] = {}; /* Child to parent.  */
+  int p2c[2] = {}; /* Parent to child.  */
   int in = -1, out = -1, err = -1;
   int pid;
   char *exec_file;
   char **exec_argv;
-  SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
 
-  mode_bits = scm_i_mode_bits (mode);
-  reading = mode_bits & SCM_RDNG;
-  writing = mode_bits & SCM_WRTNG;
+  reading = scm_is_pair (from);
+  writing = scm_is_pair (to);
 
   if (reading)
     {
-      if (pipe (c2p))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      c2p[0] = scm_to_int (scm_car (from));
+      c2p[1] = scm_to_int (scm_cdr (from));
       out = c2p[1];
     }
-  
+
   if (writing)
     {
-      if (pipe (p2c))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          if (reading)
-            {
-              close (c2p[0]);
-              close (c2p[1]);
-            }
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      p2c[0] = scm_to_int (scm_car (to));
+      p2c[1] = scm_to_int (scm_cdr (to));
       in = p2c[0];
     }
-  
+
   {
     SCM port;
 
@@ -1449,23 +1450,12 @@ scm_open_process (SCM mode, SCM prog, SCM args)
       SCM_SYSERROR;
     }
 
-  /* There is no sense in catching errors on close().  */
   if (reading)
-    {
-      close (c2p[1]);
-      read_port = scm_i_fdes_to_port (c2p[0], scm_mode_bits ("r0"),
-                                      sym_read_pipe,
-                                      SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (c2p[1]);
   if (writing)
-    {
-      close (p2c[0]);
-      write_port = scm_i_fdes_to_port (p2c[1], scm_mode_bits ("w0"),
-                                       sym_write_pipe,
-                                       SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (p2c[0]);
 
-  return scm_values_3 (read_port, write_port, scm_from_int (pid));
+  return scm_from_int (pid);
 }
 #undef FUNC_NAME
 
@@ -1510,8 +1500,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 "Example: (system* \"echo\" \"foo\" \"bar\")")
 #define FUNC_NAME s_scm_system_star
 {
-  SCM prog, res;
-  int pid, status, wait_result;
+  SCM prog, pid;
+  int status, wait_result;
 
   if (scm_is_null (args))
     SCM_WRONG_NUM_ARGS ();
@@ -1529,9 +1519,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
                          SCM_UNDEFINED);
 #endif
 
-  res = scm_open_process (scm_nullstr, prog, args);
-  pid = scm_to_int (scm_c_value_ref (res, 2));
-  SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
+  pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED);
+  SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0));
   if (wait_result == -1)
     SCM_SYSERROR;
 
@@ -2371,7 +2360,7 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 static void
 scm_init_popen (void)
 {
-  scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+  scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process);
 }
 #endif /* HAVE_START_CHILD */
 
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 2afe45701..ad1f64c7c 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -22,9 +22,10 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
-            open-output-pipe open-input-output-pipe))
+            open-output-pipe open-input-output-pipe pipe->fdes piped-process pipeline))
 
 (eval-when (expand load eval)
   (load-extension (string-append "libguile-" (effective-version))
@@ -84,6 +85,17 @@
 (define port/pid-table (make-weak-key-hash-table))
 (define port/pid-table-mutex (make-mutex))
 
+(define (pipe->fdes)
+  (let ((p (pipe)))
+   (cons (port->fdes (car p))
+         (port->fdes (cdr p)))))
+
+(define (open-process mode command . args)
+  (let* ((from (and (or (equal? mode OPEN_READ) (equal? mode OPEN_BOTH)) (pipe->fdes)))
+         (to (and (or (equal? mode OPEN_WRITE) (equal? mode OPEN_BOTH)) (pipe->fdes)))
+         (pid (piped-process command args from to)))
+    (values (and from (fdes->inport (car from))) (and to (fdes->outport (cdr to))) pid)))
+
 (define (open-pipe* mode command . args)
   "Executes the program @var{command} with optional arguments
 @var{args} (all strings) in a subprocess.
@@ -176,3 +188,21 @@ information on how to interpret this value."
   "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
   (open-pipe command OPEN_BOTH))
 
+
+(define (pipeline procs)
+  "Execute a pipeline of @code(procs) -- where a proc is a list of a
+command and its arguments as strings -- returning an input port to the
+end of the pipeline, an output port to the beginning of the pipeline and
+a list of PIDs of the @code(procs)"
+  (let* ((to (pipe->fdes))
+         (pipes (map (lambda _ (pipe->fdes)) procs))
+	 (pipeline (fold (lambda (from proc prev)
+                           (let* ((to (car prev))
+                                  (pids (cdr prev)))
+                             (cons from (cons (piped-process (car proc) (cdr proc) from to) pids))))
+                         `(,to)
+                         pipes
+                         procs))
+	 (from (car pipeline))
+	 (pids (cdr pipeline)))
+    (values (fdes->inport (car from)) (fdes->outport (cdr to)) pids)))
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 2c0877484..94f2d2f20 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -211,3 +211,37 @@ exec 2>~a; read REPLY"
      (let ((st (close-pipe (open-output-pipe "exit 1"))))
        (and (status:exit-val st)
             (= 1 (status:exit-val st)))))))
+
+
+;;
+;; pipeline related tests
+;;
+
+(use-modules (ice-9 receive))
+(use-modules (ice-9 rdelim))
+
+(pass-if "open-process"
+    (receive (from to pid)
+     ((@@ (ice-9 popen) open-process) OPEN_BOTH "rev")
+   (display "dlrow olleh" to) (close to)
+   (and (equal? "hello world" (read-string from))
+        (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "piped-process"
+  (= 42 (status:exit-val
+        (cdr (waitpid ((@@ (ice-9 popen) piped-process) "./meta/guile" '("-c" "(exit 42)")))))))
+
+(pass-if "piped-process: with output"
+  (let* ((p (pipe))
+         (pid (piped-process "echo" '("foo" "bar")
+                             (cons (port->fdes (car p))
+                                   (port->fdes (cdr p))))))
+
+    (and (equal? "foo bar\n" (read-string (car p)))
+         (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "pipeline"
+  (receive (from to pids)
+      (pipeline '(("echo" "dlrow olleh") ("rev")))
+    (and (equal? "hello world\n" (read-string from))
+         (equal? '(0 0) (map (compose status:exit-val cdr waitpid) pids)))))
-- 
2.25.1


^ permalink raw reply related	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-06  9:52 guile pipeline do-over Rutger van Beusekom
@ 2020-03-07 15:46 ` Ludovic Courtès
  2020-03-10  7:35   ` Rutger van Beusekom
  0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2020-03-07 15:46 UTC (permalink / raw)
  To: Rutger van Beusekom; +Cc: Guile Devel

Hi Rutger!

Rutger van Beusekom <rutger.van.beusekom@verum.com> skribis:

> This patch replaces open-process with piped-process in posix.c and
> reimplement open-process with piped-process in popen.scm. This allows
> setting up a pipeline in guile scheme using the new pipeline procedure
> in popen.scm and enables its use on operating systems which happen to
> lack the capability to fork, but do offer the capability captured by
> start_child (see posix.c).

Nice!  That’s definitely very useful to have.  We’ll need to check what
Andy thinks, but I think it can be added in the 3.0 series.

> From 3c8f5d534419418234cfe7d3eda8227951bc208a Mon Sep 17 00:00:00 2001
> From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
> Date: Mon, 2 Mar 2020 10:38:57 +0100
> Subject: [PATCH] Allow client code to create pipe pairs when opening a
>  process.
>
> * libguile/posix.c (scm_piped_process): Replace open_process by piped_process.

Could you mention functions renamed/removed here?  The ChangeLog format
is about boringly listing all the language-entity-level changes.  :-)

> * module/ice-9/popen.scm (pipe->fdes): Convert pipe pair to fdes pair.
> (open-process): Implement open-process with piped-process.
> (pipeline): Implement a pipeline with piped-process.
>  static SCM
> -scm_open_process (SCM mode, SCM prog, SCM args)
> -#define FUNC_NAME "open-process"
> +scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
> +#define FUNC_NAME "piped-process"
> +/* SCM_DEFINE (scm_piped_process, "piped-process", 2, 2, 0, */
> +/*            (SCM prog, SCM args, SCM from, SCM to), */
> +/* "Execute the command indicated by @var{prog} with arguments @var(args),\n" */
> +/* "optionally connected by an input and an output pipe.\n" */
> +/* "@var(from) and @var(to) are either #f or a valid file descriptor\n" */
> +/* "of an input and an output pipe, respectively.\n" */
> +/* "\n" */
> +/* "This function returns the PID of the process executing @var(prog)." */
> +/* "\n" */
> +/* "Example:\n" */
> +/* "(let ((p (pipe)))\n" */
> +/* "  (piped-process \"echo\" '(\"foo\" \"bar\")\n" */
> +/* "                 (cons (port->fdes (car p))\n" */
> +/* "                       (port->fdes (cdr p))))\n" */
> +/* "  (display (read-string (car p))))\n" */
> +/* "(let ((p (pipe)))\n" */
> +/* "  (read-string (piped-process \"echo\" '(\"foo\" \"bar\")\n" */
> +/* "                              (port->fdes (car p)))))\n") */
> +/* #define FUNC_NAME scm_piped_process */

I guess you can remove the commented-out bits…

> -  int c2p[2]; /* Child to parent.  */
> -  int p2c[2]; /* Parent to child.  */
> +  int c2p[2] = {}; /* Child to parent.  */
> +  int p2c[2] = {}; /* Parent to child.  */

… and this hunk, to minimize change.

> +++ b/module/ice-9/popen.scm
> @@ -22,9 +22,10 @@
>    #:use-module (rnrs bytevectors)
>    #:use-module (ice-9 binary-ports)
>    #:use-module (ice-9 threads)
> +  #:use-module (srfi srfi-1)
>    #:use-module (srfi srfi-9)
>    #:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
> -            open-output-pipe open-input-output-pipe))
> +            open-output-pipe open-input-output-pipe pipe->fdes piped-process pipeline))

I would not export ‘pipe->fdes’.  I’m not sure about exporting
‘piped-process’: it’s a bit low-level and we might want to reserve
ourselves the possibility to change it, like this patch does actually.

WDYT?

> +(define (open-process mode command . args)
> +  (let* ((from (and (or (equal? mode OPEN_READ) (equal? mode OPEN_BOTH)) (pipe->fdes)))
> +         (to (and (or (equal? mode OPEN_WRITE) (equal? mode OPEN_BOTH)) (pipe->fdes)))
> +         (pid (piped-process command args from to)))
> +    (values (and from (fdes->inport (car from))) (and to (fdes->outport (cdr to))) pid)))

Please wrap lines to 80 chars.

I suggest using ‘string=?’ above instead of ‘equal?’.  Also, could you
add a docstring?

> +(define (pipeline procs)
> +  "Execute a pipeline of @code(procs) -- where a proc is a list of a
> +command and its arguments as strings -- returning an input port to the
> +end of the pipeline, an output port to the beginning of the pipeline and
> +a list of PIDs of the @code(procs)"

Perhaps s/procs/commands/ would be clearer?  Also, @var{commands}
instead of @code.

Could you also add an entry in doc/ref/*.texi, in the “Pipes” node,
perhaps with one of the examples you gave?

> +++ b/test-suite/tests/popen.test
> @@ -211,3 +211,37 @@ exec 2>~a; read REPLY"
>       (let ((st (close-pipe (open-output-pipe "exit 1"))))
>         (and (status:exit-val st)
>              (= 1 (status:exit-val st)))))))
> +
> +
> +;;
> +;; pipeline related tests
> +;;
> +
> +(use-modules (ice-9 receive))
> +(use-modules (ice-9 rdelim))

Please move these to the top-level ‘define-module’ form.

One last thing: we’d need you to assign copyright to the FSF for this.
We can discuss it off-line if you want.

Thank you for this great and long overdue addition!

Ludo’.



^ permalink raw reply	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-07 15:46 ` Ludovic Courtès
@ 2020-03-10  7:35   ` Rutger van Beusekom
  2020-03-10  8:54     ` Linus Björnstam
  2020-03-26  9:09     ` Ludovic Courtès
  0 siblings, 2 replies; 8+ messages in thread
From: Rutger van Beusekom @ 2020-03-10  7:35 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: Guile Devel

[-- Attachment #1: Type: text/plain, Size: 1732 bytes --]


Hi Ludo,

I have processed your feedback in this version of the patch.

Ludovic Courtès writes:

> Hi Rutger!
>
>> ...
> Nice!  That’s definitely very useful to have.  We’ll need to check what
> Andy thinks, but I think it can be added in the 3.0 series.
>
>
>> ...
> Could you mention functions renamed/removed here?  The ChangeLog format
> is about boringly listing all the language-entity-level changes.  :-)
>
Done.
>
>> ...
> I guess you can remove the commented-out bits…
>
Yep.
>
>> ...
> … and this hunk, to minimize change.
>
Check.
>
>> ...
> I would not export ‘pipe->fdes’.  I’m not sure about exporting
> ‘piped-process’: it’s a bit low-level and we might want to reserve
> ourselves the possibility to change it, like this patch does actually.
>
> WDYT?
>
I agree.
>> ...
>
> Please wrap lines to 80 chars.
>
Taken care of.
>
>> ...
>
> I suggest using ‘string=?’ above instead of ‘equal?’.  Also, could you
> add a docstring?
>
Yes and yes.
>
>> ...
>
> Perhaps s/procs/commands/ would be clearer?  Also, @var{commands}
> instead of @code.
>
Yep.
>
> Could you also add an entry in doc/ref/*.texi, in the “Pipes” node,
> perhaps with one of the examples you gave?
>
Wrote a new example. WDYT?
>
>> ...
>
> Please move these to the top-level ‘define-module’ form.
>
Done.
>
> One last thing: we’d need you to assign copyright to the FSF for this.
> We can discuss it off-line if you want.
>
Can you help me there? I already have a verbal commitment from the
company, we just need to formalize it.
>
> Thank you for this great and long overdue addition!
>
Happy to add it.
>
> Ludo’.
>
Rutger


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: PATCH --]
[-- Type: text/x-diff, Size: 11004 bytes --]

From d351c0a5ecde62e63368bec0e1f15108495a1a71 Mon Sep 17 00:00:00 2001
From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
Date: Mon, 2 Mar 2020 10:38:57 +0100
Subject: [PATCH] Add pipeline procedure.

* libguile/posix.c (scm_open_process): Remove.
(scm_piped_process): Add to replace open_process.
* module/ice-9/popen.scm (pipe->fdes): Add to convert pipe pair to fdes pair.
(open-process): Add open-process for backwards compatibility.
(pipeline): Add to implement a pipeline using piped-process.
---
 doc/ref/posix.texi          | 27 +++++++++++++++
 libguile/posix.c            | 66 ++++++++++---------------------------
 module/ice-9/popen.scm      | 46 +++++++++++++++++++++++++-
 test-suite/tests/popen.test | 37 ++++++++++++++++++++-
 4 files changed, 126 insertions(+), 50 deletions(-)

diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 2c85f803a..d10f6531e 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2370,6 +2370,33 @@ processes, and a system-wide limit on the number of pipes, so pipes
 should be closed explicitly when no longer needed, rather than letting
 the garbage collector pick them up at some later time.
 
+@findex pipeline
+@deffn (Scheme Procedure) pipeline commands
+Execute a @code{pipeline} of @var{commands} -- where each command is a
+list of a program and its arguments as strings -- returning an input
+port to the end of the pipeline, an output port to the beginning of the
+pipeline and a list of PIDs of the processes executing the @var{commands}.
+
+@example
+(let ((commands '(("git" "ls-files")
+                   ("tar" "-cf-" "-T-")
+                   ("sha1sum" "-")))
+       (pipe-fail? (compose not
+                            zero?
+                            status:exit-val
+                            cdr
+                            waitpid)))
+   (receive (from to pids) (pipeline commands)
+     (let* ((sha1 (read-delimited " " from))
+            (index (list-index pipe-fail? (reverse pids))))
+       (close to)
+       (close from)
+       (if (not index) sha1
+           (string-append "pipeline failed in command: "
+                          (string-join (list-ref commands index)))))))
+@result{} "52f99d234503fca8c84ef94b1005a3a28d8b3bc1"
+@end example
+@end deffn
 
 @node Networking
 @subsection Networking
diff --git a/libguile/posix.c b/libguile/posix.c
index a1520abc4..dac4197e9 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1368,10 +1368,9 @@ start_child (const char *exec_file, char **exec_argv,
 
 #ifdef HAVE_START_CHILD
 static SCM
-scm_open_process (SCM mode, SCM prog, SCM args)
-#define FUNC_NAME "open-process"
+scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
+#define FUNC_NAME "piped-process"
 {
-  long mode_bits;
   int reading, writing;
   int c2p[2]; /* Child to parent.  */
   int p2c[2]; /* Parent to child.  */
@@ -1379,44 +1378,27 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
-  SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
 
-  mode_bits = scm_i_mode_bits (mode);
-  reading = mode_bits & SCM_RDNG;
-  writing = mode_bits & SCM_WRTNG;
+  reading = scm_is_pair (from);
+  writing = scm_is_pair (to);
 
   if (reading)
     {
-      if (pipe (c2p))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      c2p[0] = scm_to_int (scm_car (from));
+      c2p[1] = scm_to_int (scm_cdr (from));
       out = c2p[1];
     }
-  
+
   if (writing)
     {
-      if (pipe (p2c))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          if (reading)
-            {
-              close (c2p[0]);
-              close (c2p[1]);
-            }
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      p2c[0] = scm_to_int (scm_car (to));
+      p2c[1] = scm_to_int (scm_cdr (to));
       in = p2c[0];
     }
-  
+
   {
     SCM port;
 
@@ -1449,23 +1431,12 @@ scm_open_process (SCM mode, SCM prog, SCM args)
       SCM_SYSERROR;
     }
 
-  /* There is no sense in catching errors on close().  */
   if (reading)
-    {
-      close (c2p[1]);
-      read_port = scm_i_fdes_to_port (c2p[0], scm_mode_bits ("r0"),
-                                      sym_read_pipe,
-                                      SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (c2p[1]);
   if (writing)
-    {
-      close (p2c[0]);
-      write_port = scm_i_fdes_to_port (p2c[1], scm_mode_bits ("w0"),
-                                       sym_write_pipe,
-                                       SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (p2c[0]);
 
-  return scm_values_3 (read_port, write_port, scm_from_int (pid));
+  return scm_from_int (pid);
 }
 #undef FUNC_NAME
 
@@ -1510,8 +1481,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 "Example: (system* \"echo\" \"foo\" \"bar\")")
 #define FUNC_NAME s_scm_system_star
 {
-  SCM prog, res;
-  int pid, status, wait_result;
+  SCM prog, pid;
+  int status, wait_result;
 
   if (scm_is_null (args))
     SCM_WRONG_NUM_ARGS ();
@@ -1529,9 +1500,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
                          SCM_UNDEFINED);
 #endif
 
-  res = scm_open_process (scm_nullstr, prog, args);
-  pid = scm_to_int (scm_c_value_ref (res, 2));
-  SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
+  pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED);
+  SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0));
   if (wait_result == -1)
     SCM_SYSERROR;
 
@@ -2371,7 +2341,7 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 static void
 scm_init_popen (void)
 {
-  scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+  scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process);
 }
 #endif /* HAVE_START_CHILD */
 
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 2afe45701..5ab93f275 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -22,9 +22,10 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
-            open-output-pipe open-input-output-pipe))
+            open-output-pipe open-input-output-pipe pipeline))
 
 (eval-when (expand load eval)
   (load-extension (string-append "libguile-" (effective-version))
@@ -84,6 +85,28 @@
 (define port/pid-table (make-weak-key-hash-table))
 (define port/pid-table-mutex (make-mutex))
 
+(define (pipe->fdes)
+  (let ((p (pipe)))
+   (cons (port->fdes (car p))
+         (port->fdes (cdr p)))))
+
+(define (open-process mode command . args)
+  "Backwards compatible implementation of the former procedure in
+libguile/posix.c (scm_open_process) replaced by
+scm_piped_process. Executes the program @var{command} with optional
+arguments @var{args} (all strings) in a subprocess.  A port to the
+process (based on pipes) is created and returned.  @var{mode} specifies
+whether an input, an output or an input-output port to the process is
+created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE}
+or @code{OPEN_BOTH}."
+  (let* ((from (and (or (string=? mode OPEN_READ)
+                        (string=? mode OPEN_BOTH)) (pipe->fdes)))
+         (to (and (or (string=? mode OPEN_WRITE)
+                      (string=? mode OPEN_BOTH)) (pipe->fdes)))
+         (pid (piped-process command args from to)))
+    (values (and from (fdes->inport (car from)))
+            (and to (fdes->outport (cdr to))) pid)))
+
 (define (open-pipe* mode command . args)
   "Executes the program @var{command} with optional arguments
 @var{args} (all strings) in a subprocess.
@@ -176,3 +199,24 @@ information on how to interpret this value."
   "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
   (open-pipe command OPEN_BOTH))
 
+(define (pipeline commands)
+  "Execute a pipeline of @var(commands) -- where each command is a list of a
+program and its arguments as strings -- returning an input port to the
+end of the pipeline, an output port to the beginning of the pipeline and
+a list of PIDs of the processes executing the @var(commands)."
+  (let* ((to (pipe->fdes))
+         (pipes (map (lambda _ (pipe->fdes)) commands))
+	 (pipeline (fold (lambda (from proc prev)
+                           (let* ((to (car prev))
+                                  (pids (cdr prev))
+                                  (pid (piped-process (car proc)
+                                                      (cdr proc)
+                                                      from
+                                                      to)))
+                             (cons from (cons pid pids))))
+                         `(,to)
+                         pipes
+                         commands))
+	 (from (car pipeline))
+	 (pids (cdr pipeline)))
+    (values (fdes->inport (car from)) (fdes->outport (cdr to)) pids)))
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 2c0877484..c780de9a7 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -17,7 +17,10 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite test-ice-9-popen)
-  #:use-module (test-suite lib))
+  #:use-module (test-suite lib)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 rdelim))
+
 
 ;; read from PORT until eof is reached, return what's read as a string
 (define (read-string-to-eof port)
@@ -211,3 +214,35 @@ exec 2>~a; read REPLY"
      (let ((st (close-pipe (open-output-pipe "exit 1"))))
        (and (status:exit-val st)
             (= 1 (status:exit-val st)))))))
+
+
+;;
+;; pipeline related tests
+;;
+
+(pass-if "open-process"
+    (receive (from to pid)
+     ((@@ (ice-9 popen) open-process) OPEN_BOTH "rev")
+   (display "dlrow olleh" to) (close to)
+   (and (equal? "hello world" (read-string from))
+        (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "piped-process"
+  (= 42 (status:exit-val
+         (cdr (waitpid ((@@ (ice-9 popen) piped-process)
+                        "./meta/guile" '("-c" "(exit 42)")))))))
+
+(pass-if "piped-process: with output"
+  (let* ((p (pipe))
+         (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar")
+                             (cons (port->fdes (car p))
+                                   (port->fdes (cdr p))))))
+
+    (and (equal? "foo bar\n" (read-string (car p)))
+         (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "pipeline"
+  (receive (from to pids)
+      (pipeline '(("echo" "dlrow olleh") ("rev")))
+    (and (string=? "hello world\n" (read-string from))
+         (equal? '(0 0) (map (compose status:exit-val cdr waitpid) pids)))))
-- 
2.25.1


^ permalink raw reply related	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-10  7:35   ` Rutger van Beusekom
@ 2020-03-10  8:54     ` Linus Björnstam
  2020-03-10 10:37       ` Rutger van Beusekom
  2020-03-26  9:09     ` Ludovic Courtès
  1 sibling, 1 reply; 8+ messages in thread
From: Linus Björnstam @ 2020-03-10  8:54 UTC (permalink / raw)
  To: Rutger van Beusekom, Ludovic Courtès; +Cc: Guile Devel

I have a question about the interface. It uses the shell now, it seems. (I could be wrong). The guile system call has a (system cmd ) which uses the shell and a system* call which takes (system* cmd arg ...) So that it does not rely on the shell. Maybe a similar interface could be useful (and more secure) for the pipeline as well.

Thank you for this patch.
  Linus Björnstam

On Tue, 10 Mar 2020, at 08:35, Rutger van Beusekom wrote:
> 
> Hi Ludo,
> 
> I have processed your feedback in this version of the patch.
> 
> Ludovic Courtès writes:
> 
> > Hi Rutger!
> >
> >> ...
> > Nice!  That’s definitely very useful to have.  We’ll need to check what
> > Andy thinks, but I think it can be added in the 3.0 series.
> >
> >
> >> ...
> > Could you mention functions renamed/removed here?  The ChangeLog format
> > is about boringly listing all the language-entity-level changes.  :-)
> >
> Done.
> >
> >> ...
> > I guess you can remove the commented-out bits…
> >
> Yep.
> >
> >> ...
> > … and this hunk, to minimize change.
> >
> Check.
> >
> >> ...
> > I would not export ‘pipe->fdes’.  I’m not sure about exporting
> > ‘piped-process’: it’s a bit low-level and we might want to reserve
> > ourselves the possibility to change it, like this patch does actually.
> >
> > WDYT?
> >
> I agree.
> >> ...
> >
> > Please wrap lines to 80 chars.
> >
> Taken care of.
> >
> >> ...
> >
> > I suggest using ‘string=?’ above instead of ‘equal?’.  Also, could you
> > add a docstring?
> >
> Yes and yes.
> >
> >> ...
> >
> > Perhaps s/procs/commands/ would be clearer?  Also, @var{commands}
> > instead of @code.
> >
> Yep.
> >
> > Could you also add an entry in doc/ref/*.texi, in the “Pipes” node,
> > perhaps with one of the examples you gave?
> >
> Wrote a new example. WDYT?
> >
> >> ...
> >
> > Please move these to the top-level ‘define-module’ form.
> >
> Done.
> >
> > One last thing: we’d need you to assign copyright to the FSF for this.
> > We can discuss it off-line if you want.
> >
> Can you help me there? I already have a verbal commitment from the
> company, we just need to formalize it.
> >
> > Thank you for this great and long overdue addition!
> >
> Happy to add it.
> >
> > Ludo’.
> >
> Rutger
> 
> 
> Attachments:
> * 0001-Add-pipeline-procedure.patch



^ permalink raw reply	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-10  8:54     ` Linus Björnstam
@ 2020-03-10 10:37       ` Rutger van Beusekom
  0 siblings, 0 replies; 8+ messages in thread
From: Rutger van Beusekom @ 2020-03-10 10:37 UTC (permalink / raw)
  To: Linus Björnstam
  Cc: Rutger van Beusekom, Ludovic Courtès, Guile Devel


Hi Linus,

pipeline is implemented with piped-process, which is implemented with
scm_start_child, which does not use the shell. In your pipeline you can
use a shell explicitly if you wanted to. I do not think I should follow
the asterisk convention in procedure naming for pipeline. What do you
think?

Rutger

Linus Björnstam writes:

> I have a question about the interface. It uses the shell now, it seems. (I could be wrong). The guile system call has a (system cmd ) which uses the shell and a system* call which takes (system* cmd arg ...) So that it does not rely on the shell. Maybe a similar interface could be useful (and more secure) for the pipeline as well.
>
> Thank you for this patch.
>   Linus Björnstam
>
> ...



^ permalink raw reply	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-10  7:35   ` Rutger van Beusekom
  2020-03-10  8:54     ` Linus Björnstam
@ 2020-03-26  9:09     ` Ludovic Courtès
  2020-04-04  8:01       ` Rutger van Beusekom
  1 sibling, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2020-03-26  9:09 UTC (permalink / raw)
  To: Rutger van Beusekom; +Cc: Andy Wingo, Guile Devel

Hi Rutger,

(+Cc: Andy.)

Rutger van Beusekom <rutger.van.beusekom@verum.com> skribis:

> From d351c0a5ecde62e63368bec0e1f15108495a1a71 Mon Sep 17 00:00:00 2001
> From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
> Date: Mon, 2 Mar 2020 10:38:57 +0100
> Subject: [PATCH] Add pipeline procedure.
>
> * libguile/posix.c (scm_open_process): Remove.
> (scm_piped_process): Add to replace open_process.
> * module/ice-9/popen.scm (pipe->fdes): Add to convert pipe pair to fdes pair.
> (open-process): Add open-process for backwards compatibility.
> (pipeline): Add to implement a pipeline using piped-process.

There are a couple super minor issues that I comment on below, but
otherwise LGTM!  If Andy agrees, we can apply it once the copyright
assignment is on file, so maybe it won’t be in 3.0.2, we’ll see!

> +@deffn (Scheme Procedure) pipeline commands
          ^                ^
Should be braces.

> +Execute a @code{pipeline} of @var{commands} -- where each command is a
> +list of a program and its arguments as strings -- returning an input

s/--/---/ so we get an em dash and not an en dash (I’m a typography
nitpicker :-)).

> +port to the end of the pipeline, an output port to the beginning of the
> +pipeline and a list of PIDs of the processes executing the @var{commands}.
> +
> +@example
> +(let ((commands '(("git" "ls-files")
> +                   ("tar" "-cf-" "-T-")
> +                   ("sha1sum" "-")))
                     ^
There’s an extra space on these lines

> +       (pipe-fail? (compose not
> +                            zero?
> +                            status:exit-val
> +                            cdr
> +                            waitpid)))

I don’t think we should encourage this style, which could also look
obscure to newcomers.  I’d just make it a regular lambda.

That’s all for me.

Thanks again, Rutger!

Ludo’.



^ permalink raw reply	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-03-26  9:09     ` Ludovic Courtès
@ 2020-04-04  8:01       ` Rutger van Beusekom
  2020-05-16 20:38         ` Ludovic Courtès
  0 siblings, 1 reply; 8+ messages in thread
From: Rutger van Beusekom @ 2020-04-04  8:01 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: Rutger van Beusekom, Andy Wingo, Guile Devel

[-- Attachment #1: Type: text/plain, Size: 2343 bytes --]


Hi Ludo,

Ludovic Courtès writes:

> Hi Rutger,
>
> (+Cc: Andy.)
>
> Rutger van Beusekom <rutger.van.beusekom@verum.com> skribis:
>
>> From d351c0a5ecde62e63368bec0e1f15108495a1a71 Mon Sep 17 00:00:00 2001
>> From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
>> Date: Mon, 2 Mar 2020 10:38:57 +0100
>> Subject: [PATCH] Add pipeline procedure.
>>
>> * libguile/posix.c (scm_open_process): Remove.
>> (scm_piped_process): Add to replace open_process.
>> * module/ice-9/popen.scm (pipe->fdes): Add to convert pipe pair to fdes pair.
>> (open-process): Add open-process for backwards compatibility.
>> (pipeline): Add to implement a pipeline using piped-process.
>
> There are a couple super minor issues that I comment on below, but
> otherwise LGTM!  If Andy agrees, we can apply it once the copyright
> assignment is on file, so maybe it won’t be in 3.0.2, we’ll see!

As yet I have not received a copyright assignment form.

>
>> +@deffn (Scheme Procedure) pipeline commands
>           ^                ^
> Should be braces.
>
>> +Execute a @code{pipeline} of @var{commands} -- where each command is a
>> +list of a program and its arguments as strings -- returning an input
>
> s/--/---/ so we get an em dash and not an en dash (I’m a typography
> nitpicker :-)).
>
>> +port to the end of the pipeline, an output port to the beginning of the
>> +pipeline and a list of PIDs of the processes executing the @var{commands}.
>> +
>> +@example
>> +(let ((commands '(("git" "ls-files")
>> +                   ("tar" "-cf-" "-T-")
>> +                   ("sha1sum" "-")))
>                      ^
> There’s an extra space on these lines
>
>> +       (pipe-fail? (compose not
>> +                            zero?
>> +                            status:exit-val
>> +                            cdr
>> +                            waitpid)))
>
> I don’t think we should encourage this style, which could also look
> obscure to newcomers.  I’d just make it a regular lambda.
>

Personally I really like composing procedures like a pipeline ;-), but I
do not want to obscure things.

> That’s all for me.
>
> Thanks again, Rutger!
>
> Ludo’.

Thank you for helping me find where to dot the i's and cross the t's,
please see the updated patch.

Rutger.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: PATCH --]
[-- Type: text/x-diff, Size: 11014 bytes --]

From 9fa48fa3917eb1fab61b703de936471c3c24f4f4 Mon Sep 17 00:00:00 2001
From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
Date: Mon, 2 Mar 2020 10:38:57 +0100
Subject: [PATCH] Add pipeline procedure.

* libguile/posix.c (scm_open_process): Remove.
(scm_piped_process): Add to replace open_process.
* module/ice-9/popen.scm (pipe->fdes): Add to convert pipe pair to fdes pair.
(open-process): Add open-process for backwards compatibility.
(pipeline): Add to implement a pipeline using piped-process.
---
 doc/ref/posix.texi          | 28 ++++++++++++++++
 libguile/posix.c            | 66 ++++++++++---------------------------
 module/ice-9/popen.scm      | 46 +++++++++++++++++++++++++-
 test-suite/tests/popen.test | 37 ++++++++++++++++++++-
 4 files changed, 127 insertions(+), 50 deletions(-)

diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 2c85f803a..e5d63c7b3 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2370,6 +2370,34 @@ processes, and a system-wide limit on the number of pipes, so pipes
 should be closed explicitly when no longer needed, rather than letting
 the garbage collector pick them up at some later time.
 
+@findex pipeline
+@deffn {Scheme Procedure} pipeline commands
+Execute a @code{pipeline} of @var{commands} --- where each command is a
+list of a program and its arguments as strings --- returning an input
+port to the end of the pipeline, an output port to the beginning of the
+pipeline and a list of PIDs of the processes executing the @var{commands}.
+
+@example
+(let ((commands '(("git" "ls-files")
+                  ("tar" "-cf-" "-T-")
+                  ("sha1sum" "-")))
+      (pipe-fail? (lambda (pid)
+                    (not
+                     (zero?
+                      (status:exit-val
+                       (cdr
+                        (waitpid pid))))))))
+  (receive (from to pids) (pipeline commands)
+    (let* ((sha1 (read-delimited " " from))
+           (index (list-index pipe-fail? (reverse pids))))
+      (close to)
+      (close from)
+      (if (not index) sha1
+          (string-append "pipeline failed in command: "
+                         (string-join (list-ref commands index)))))))
+@result{} "52f99d234503fca8c84ef94b1005a3a28d8b3bc1"
+@end example
+@end deffn
 
 @node Networking
 @subsection Networking
diff --git a/libguile/posix.c b/libguile/posix.c
index 9b9b47636..b47b01701 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1372,10 +1372,9 @@ start_child (const char *exec_file, char **exec_argv,
 
 #ifdef HAVE_START_CHILD
 static SCM
-scm_open_process (SCM mode, SCM prog, SCM args)
-#define FUNC_NAME "open-process"
+scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
+#define FUNC_NAME "piped-process"
 {
-  long mode_bits;
   int reading, writing;
   int c2p[2]; /* Child to parent.  */
   int p2c[2]; /* Parent to child.  */
@@ -1383,44 +1382,27 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
-  SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
 
-  mode_bits = scm_i_mode_bits (mode);
-  reading = mode_bits & SCM_RDNG;
-  writing = mode_bits & SCM_WRTNG;
+  reading = scm_is_pair (from);
+  writing = scm_is_pair (to);
 
   if (reading)
     {
-      if (pipe (c2p))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      c2p[0] = scm_to_int (scm_car (from));
+      c2p[1] = scm_to_int (scm_cdr (from));
       out = c2p[1];
     }
-  
+
   if (writing)
     {
-      if (pipe (p2c))
-        {
-          int errno_save = errno;
-          free (exec_file);
-          if (reading)
-            {
-              close (c2p[0]);
-              close (c2p[1]);
-            }
-          errno = errno_save;
-          SCM_SYSERROR;
-        }
+      p2c[0] = scm_to_int (scm_car (to));
+      p2c[1] = scm_to_int (scm_cdr (to));
       in = p2c[0];
     }
-  
+
   {
     SCM port;
 
@@ -1453,23 +1435,12 @@ scm_open_process (SCM mode, SCM prog, SCM args)
       SCM_SYSERROR;
     }
 
-  /* There is no sense in catching errors on close().  */
   if (reading)
-    {
-      close (c2p[1]);
-      read_port = scm_i_fdes_to_port (c2p[0], scm_mode_bits ("r0"),
-                                      sym_read_pipe,
-                                      SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (c2p[1]);
   if (writing)
-    {
-      close (p2c[0]);
-      write_port = scm_i_fdes_to_port (p2c[1], scm_mode_bits ("w0"),
-                                       sym_write_pipe,
-                                       SCM_FPORT_OPTION_NOT_SEEKABLE);
-    }
+    close (p2c[0]);
 
-  return scm_values_3 (read_port, write_port, scm_from_int (pid));
+  return scm_from_int (pid);
 }
 #undef FUNC_NAME
 
@@ -1514,8 +1485,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 "Example: (system* \"echo\" \"foo\" \"bar\")")
 #define FUNC_NAME s_scm_system_star
 {
-  SCM prog, res;
-  int pid, status, wait_result;
+  SCM prog, pid;
+  int status, wait_result;
 
   if (scm_is_null (args))
     SCM_WRONG_NUM_ARGS ();
@@ -1533,9 +1504,8 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
                          SCM_UNDEFINED);
 #endif
 
-  res = scm_open_process (scm_nullstr, prog, args);
-  pid = scm_to_int (scm_c_value_ref (res, 2));
-  SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
+  pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED);
+  SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0));
   if (wait_result == -1)
     SCM_SYSERROR;
 
@@ -2382,7 +2352,7 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 static void
 scm_init_popen (void)
 {
-  scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+  scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process);
 }
 #endif /* HAVE_START_CHILD */
 
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 2afe45701..5ab93f275 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -22,9 +22,10 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
-            open-output-pipe open-input-output-pipe))
+            open-output-pipe open-input-output-pipe pipeline))
 
 (eval-when (expand load eval)
   (load-extension (string-append "libguile-" (effective-version))
@@ -84,6 +85,28 @@
 (define port/pid-table (make-weak-key-hash-table))
 (define port/pid-table-mutex (make-mutex))
 
+(define (pipe->fdes)
+  (let ((p (pipe)))
+   (cons (port->fdes (car p))
+         (port->fdes (cdr p)))))
+
+(define (open-process mode command . args)
+  "Backwards compatible implementation of the former procedure in
+libguile/posix.c (scm_open_process) replaced by
+scm_piped_process. Executes the program @var{command} with optional
+arguments @var{args} (all strings) in a subprocess.  A port to the
+process (based on pipes) is created and returned.  @var{mode} specifies
+whether an input, an output or an input-output port to the process is
+created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE}
+or @code{OPEN_BOTH}."
+  (let* ((from (and (or (string=? mode OPEN_READ)
+                        (string=? mode OPEN_BOTH)) (pipe->fdes)))
+         (to (and (or (string=? mode OPEN_WRITE)
+                      (string=? mode OPEN_BOTH)) (pipe->fdes)))
+         (pid (piped-process command args from to)))
+    (values (and from (fdes->inport (car from)))
+            (and to (fdes->outport (cdr to))) pid)))
+
 (define (open-pipe* mode command . args)
   "Executes the program @var{command} with optional arguments
 @var{args} (all strings) in a subprocess.
@@ -176,3 +199,24 @@ information on how to interpret this value."
   "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
   (open-pipe command OPEN_BOTH))
 
+(define (pipeline commands)
+  "Execute a pipeline of @var(commands) -- where each command is a list of a
+program and its arguments as strings -- returning an input port to the
+end of the pipeline, an output port to the beginning of the pipeline and
+a list of PIDs of the processes executing the @var(commands)."
+  (let* ((to (pipe->fdes))
+         (pipes (map (lambda _ (pipe->fdes)) commands))
+	 (pipeline (fold (lambda (from proc prev)
+                           (let* ((to (car prev))
+                                  (pids (cdr prev))
+                                  (pid (piped-process (car proc)
+                                                      (cdr proc)
+                                                      from
+                                                      to)))
+                             (cons from (cons pid pids))))
+                         `(,to)
+                         pipes
+                         commands))
+	 (from (car pipeline))
+	 (pids (cdr pipeline)))
+    (values (fdes->inport (car from)) (fdes->outport (cdr to)) pids)))
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 2c0877484..c780de9a7 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -17,7 +17,10 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite test-ice-9-popen)
-  #:use-module (test-suite lib))
+  #:use-module (test-suite lib)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 rdelim))
+
 
 ;; read from PORT until eof is reached, return what's read as a string
 (define (read-string-to-eof port)
@@ -211,3 +214,35 @@ exec 2>~a; read REPLY"
      (let ((st (close-pipe (open-output-pipe "exit 1"))))
        (and (status:exit-val st)
             (= 1 (status:exit-val st)))))))
+
+
+;;
+;; pipeline related tests
+;;
+
+(pass-if "open-process"
+    (receive (from to pid)
+     ((@@ (ice-9 popen) open-process) OPEN_BOTH "rev")
+   (display "dlrow olleh" to) (close to)
+   (and (equal? "hello world" (read-string from))
+        (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "piped-process"
+  (= 42 (status:exit-val
+         (cdr (waitpid ((@@ (ice-9 popen) piped-process)
+                        "./meta/guile" '("-c" "(exit 42)")))))))
+
+(pass-if "piped-process: with output"
+  (let* ((p (pipe))
+         (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar")
+                             (cons (port->fdes (car p))
+                                   (port->fdes (cdr p))))))
+
+    (and (equal? "foo bar\n" (read-string (car p)))
+         (= 0 (status:exit-val (cdr (waitpid pid)))))))
+
+(pass-if "pipeline"
+  (receive (from to pids)
+      (pipeline '(("echo" "dlrow olleh") ("rev")))
+    (and (string=? "hello world\n" (read-string from))
+         (equal? '(0 0) (map (compose status:exit-val cdr waitpid) pids)))))
-- 
2.25.1


^ permalink raw reply related	[flat|nested] 8+ messages in thread

* Re: guile pipeline do-over
  2020-04-04  8:01       ` Rutger van Beusekom
@ 2020-05-16 20:38         ` Ludovic Courtès
  0 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2020-05-16 20:38 UTC (permalink / raw)
  To: Rutger van Beusekom; +Cc: Andy Wingo, Guile Devel

Hi Rutger,

It’s been a looong process (apologies!), but I’m happy to say that this
patch is now in master!  Hopefully your future contributions will be
quicker to get in, otherwise there won’t be anyone to blame but the
maintainers.  ;-)

Rutger van Beusekom <rutger.van.beusekom@verum.com> skribis:

> From 9fa48fa3917eb1fab61b703de936471c3c24f4f4 Mon Sep 17 00:00:00 2001
> From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
> Date: Mon, 2 Mar 2020 10:38:57 +0100
> Subject: [PATCH] Add pipeline procedure.
>
> * libguile/posix.c (scm_open_process): Remove.
> (scm_piped_process): Add to replace open_process.
> * module/ice-9/popen.scm (pipe->fdes): Add to convert pipe pair to fdes pair.
> (open-process): Add open-process for backwards compatibility.
> (pipeline): Add to implement a pipeline using piped-process.

I added bits that were missing from the commit log and followed up with
cosmetic tweaks to the tests and doc.

It’s all good, thank you for sharing this!

Ludo’.



^ permalink raw reply	[flat|nested] 8+ messages in thread

end of thread, other threads:[~2020-05-16 20:38 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2020-03-06  9:52 guile pipeline do-over Rutger van Beusekom
2020-03-07 15:46 ` Ludovic Courtès
2020-03-10  7:35   ` Rutger van Beusekom
2020-03-10  8:54     ` Linus Björnstam
2020-03-10 10:37       ` Rutger van Beusekom
2020-03-26  9:09     ` Ludovic Courtès
2020-04-04  8:01       ` Rutger van Beusekom
2020-05-16 20:38         ` Ludovic Courtès

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).