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

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).