unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
From: Rutger van Beusekom <rutger.van.beusekom@verum.com>
To: guile-devel@gnu.org
Subject: guile pipeline do-over
Date: Fri, 06 Mar 2020 10:52:54 +0100	[thread overview]
Message-ID: <8736al24jt.fsf@verum.com> (raw)

[-- 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


             reply	other threads:[~2020-03-06  9:52 UTC|newest]

Thread overview: 8+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-03-06  9:52 Rutger van Beusekom [this message]
2020-03-07 15:46 ` guile pipeline do-over 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

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=8736al24jt.fsf@verum.com \
    --to=rutger.van.beusekom@verum.com \
    --cc=guile-devel@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
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).