bug#52835: [PATCH v6 3/3] Move popen and posix procedures to spawn*.

[Josselin Poiret via "Bug reports for GUILE, GNU's Ubiquitous Extension Language" <bug-guile@gnu.org>]

* libguile/posix.c (scm_piped_process, scm_init_popen): Remove
functions.
(scm_port_to_fd_with_default): New helper function.
(scm_system_star): Rewrite using scm_spawn_process.
(scm_init_popen): Remove the definition of piped-process.
(scm_init_posix): Now make popen available unconditionally.

* module/ice-9/popen.scm (port-with-defaults): New helper procedure.
(spawn): New procedure.
(open-process): Rewrite using spawn.
(pipeline): Rewrite using spawn*.

* test-suite/tests/popen.test ("piped-process", "piped-process:
with-output"): Removed tests.
("spawn", "spawn: with output"): Added tests.
* test-suite/tests/posix.test ("http://bugs.gnu.org/13166", "exit code
for nonexistent file", "https://bugs.gnu.org/55596"): Remove obsolete
tests.
("exception for nonexistent file"): Add test.
---
 libguile/posix.c            | 144 ++++++++----------------------------
 module/ice-9/popen.scm      |  87 +++++++++++++++-------
 test-suite/tests/popen.test |  14 ++--
 test-suite/tests/posix.test |  36 ++++-----
 4 files changed, 118 insertions(+), 163 deletions(-)

diff --git a/libguile/posix.c b/libguile/posix.c
index f9c36d7ac..1401a9118 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -64,6 +64,7 @@
 #include "fports.h"
 #include "gettext.h"
 #include "gsubr.h"
+#include "ioext.h"
 #include "list.h"
 #include "modules.h"
 #include "numbers.h"
@@ -1388,98 +1389,6 @@ SCM_DEFINE (scm_spawn_process, "spawn*", 5, 0, 0,
 }
 #undef FUNC_NAME
 
-#ifdef HAVE_FORK
-static SCM
-scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
-#define FUNC_NAME "piped-process"
-{
-  int reading, writing;
-  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;
-  char **exec_env = environ;
-
-  exec_file = scm_to_locale_string (prog);
-  exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
-
-  reading = scm_is_pair (from);
-  writing = scm_is_pair (to);
-
-  if (reading)
-    {
-      c2p[0] = scm_to_int (scm_car (from));
-      c2p[1] = scm_to_int (scm_cdr (from));
-      out = c2p[1];
-    }
-
-  if (writing)
-    {
-      p2c[0] = scm_to_int (scm_car (to));
-      p2c[1] = scm_to_int (scm_cdr (to));
-      in = p2c[0];
-    }
-
-  {
-    SCM port;
-
-    if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
-      err = SCM_FPORT_FDES (port);
-    if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
-      out = SCM_FPORT_FDES (port);
-    if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
-      in = SCM_FPORT_FDES (port);
-  }
-
-  pid = do_spawn (exec_file, exec_argv, exec_env, in, out, err);
-  int errno_save = errno;
-
-  if (pid == -1)
-    {
-      /* TODO This is a compatibility shim until the next major release */
-      switch (errno) {
-      /* If the error seemingly comes from fork */
-      case EAGAIN:
-      case ENOMEM:
-      case ENOSYS:
-        free (exec_file);
-
-        if (reading)
-          {
-            close (c2p[0]);
-          }
-        if (writing)
-          {
-            close (p2c[1]);
-          }
-        errno = errno_save;
-        SCM_SYSERROR;
-        break;
-      /* Else create a dummy process that exits with value 127 */
-      default:
-        dprintf (err, "In execvp of %s: %s\n", exec_file,
-                 strerror (errno_save));
-        pid = fork ();
-        if (pid == -1)
-          SCM_SYSERROR;
-        if (pid == 0)
-          _exit (127);
-      }
-    }
-
-  free (exec_file);
-
-  if (reading)
-    close (c2p[1]);
-  if (writing)
-    close (p2c[0]);
-
-  return scm_from_int (pid);
-}
-#undef FUNC_NAME
-
 static void
 restore_sigaction (SCM pair)
 {
@@ -1501,6 +1410,15 @@ scm_dynwind_sigaction (int sig, SCM handler, SCM flags)
                                        SCM_F_WIND_EXPLICITLY);
 }
 
+static int
+port_to_fd_with_default (SCM port, int mode)
+{
+  if (!SCM_FPORTP (port))
+    return  open_or_open64 ("/dev/null", mode);
+  return SCM_FPORT_FDES (port);
+
+}
+
 SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
            (SCM args),
 "Execute the command indicated by @var{args}.  The first element must\n"
@@ -1521,13 +1439,14 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
 "Example: (system* \"echo\" \"foo\" \"bar\")")
 #define FUNC_NAME s_scm_system_star
 {
-  SCM prog, pid;
-  int status, wait_result;
+  int pid, status, wait_result;
+
+  int in, out, err;
+  char *exec_file;
+  char **exec_argv;
 
   if (scm_is_null (args))
     SCM_WRONG_NUM_ARGS ();
-  prog = scm_car (args);
-  args = scm_cdr (args);
 
   scm_dynwind_begin (0);
   /* Make sure the child can't kill us (as per normal system call).  */
@@ -1540,8 +1459,23 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
                          SCM_UNDEFINED);
 #endif
 
-  pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED);
-  SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0));
+  exec_file = scm_to_locale_string (scm_car (args));
+  exec_argv = scm_i_allocate_string_pointers (args);
+
+  in = port_to_fd_with_default (scm_current_input_port (), O_RDONLY);
+  out = port_to_fd_with_default (scm_current_output_port (), O_WRONLY);
+  err = port_to_fd_with_default (scm_current_error_port (), O_WRONLY);
+
+  pid = do_spawn (exec_file, exec_argv, environ, in, out, err);
+  if (pid == -1)
+    {
+      int errno_save = errno;
+      free (exec_file);
+      errno = errno_save;
+      SCM_SYSERROR;
+    }
+
+  SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
   if (wait_result == -1)
     SCM_SYSERROR;
 
@@ -1550,7 +1484,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
   return scm_from_int (status);
 }
 #undef FUNC_NAME
-#endif /* HAVE_FORK */
 
 #ifdef HAVE_UNAME
 SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
@@ -2396,14 +2329,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #endif /* HAVE_GETHOSTNAME */
 
 \f
-#ifdef HAVE_FORK
-static void
-scm_init_popen (void)
-{
-  scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process);
-}
-#endif /* HAVE_FORK */
-
 void
 scm_init_posix ()
 {
@@ -2520,10 +2445,5 @@ scm_init_posix ()
 
 #ifdef HAVE_FORK
   scm_add_feature ("fork");
-  scm_add_feature ("popen");
-  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
-                            "scm_init_popen",
-			    (scm_t_extension_init_func) scm_init_popen,
-			    NULL);
 #endif	/* HAVE_FORK */
 }
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index e638726a4..547f56d5f 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -25,11 +25,34 @@
   #: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 pipeline))
+            open-output-pipe open-input-output-pipe pipeline spawn))
 
-(eval-when (expand load eval)
-  (load-extension (string-append "libguile-" (effective-version))
-                  "scm_init_popen"))
+(define (port-with-defaults port default-mode)
+  (if (file-port? port)
+      port
+      (open-file "/dev/null" default-mode)))
+
+(define* (spawn exec-file argv #:key
+                             (in (current-input-port))
+                             (out (current-output-port))
+                             (err (current-error-port)))
+  "Spawns a new child process executing @var{prog} with arguments
+@var{args}, with its standard input, output and error file descriptors
+set to @var{in}, @var{out}, @var{err}."
+  (let* ((in (port-with-defaults in "r"))
+         (out (port-with-defaults out "w"))
+         (err (port-with-defaults err "w"))
+         ;; Increment port revealed counts while to prevent ports GC'ing and
+         ;; closing the associated fds while we spawn the process.
+         (result (spawn* exec-file
+                         argv
+                         (port->fdes in)
+                         (port->fdes out)
+                         (port->fdes err))))
+    (release-port-handle in)
+    (release-port-handle out)
+    (release-port-handle err)
+    result))
 
 (define-record-type <pipe-info>
   (make-pipe-info pid)
@@ -92,13 +115,13 @@
 
 (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}."
+libguile/posix.c (scm_open_process) replaced by scm_piped_process, now
+replaced by scm_spawn_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}."
   (define (unbuffered port)
     (setvbuf port 'none)
     port)
@@ -107,19 +130,25 @@ or @code{OPEN_BOTH}."
     (and ports
          (cons (port->fdes (car ports)) (port->fdes (cdr ports)))))
 
-  (let* ((from (and (or (string=? mode OPEN_READ)
-                        (string=? mode OPEN_BOTH))
-                    (pipe)))
-         (to (and (or (string=? mode OPEN_WRITE)
-                      (string=? mode OPEN_BOTH))
-                  (pipe)))
-         (pid (piped-process command args
-                             (fdes-pair from)
-                             (fdes-pair to))))
+  (let* ((child-to-parent (and (or (string=? mode OPEN_READ)
+                                   (string=? mode OPEN_BOTH))
+                               (pipe)))
+         (parent-to-child (and (or (string=? mode OPEN_WRITE)
+                                   (string=? mode OPEN_BOTH))
+                               (pipe)))
+         (in (or (and=> parent-to-child car) (current-input-port)))
+         (out (or (and=> child-to-parent cdr) (current-output-port)))
+         (pid (spawn command (cons command args)
+                     #:in in
+                     #:out out)))
+    (when child-to-parent
+      (close (cdr child-to-parent)))
+    (when parent-to-child
+      (close (car parent-to-child)))
     ;; The original 'open-process' procedure would return unbuffered
     ;; ports; do the same here.
-    (values (and from (unbuffered (car from)))
-            (and to (unbuffered (cdr to)))
+    (values (and child-to-parent (unbuffered (car child-to-parent)))
+            (and parent-to-child (unbuffered (cdr parent-to-child)))
             pid)))
 
 (define (open-pipe* mode command . args)
@@ -224,10 +253,16 @@ a list of PIDs of the processes executing the @var{commands}."
 	 (pipeline (fold (lambda (from proc prev)
                            (let* ((to (car prev))
                                   (pids (cdr prev))
-                                  (pid (piped-process (car proc)
-                                                      (cdr proc)
-                                                      from
-                                                      to)))
+                                  (pid (spawn* (car proc)
+                                               proc
+                                               (car to)
+                                               (cdr from)
+                                               (port->fdes
+                                                (port-with-defaults
+                                                 (current-error-port)
+                                                 "w")))))
+                             (close-fdes (car to))
+                             (close-fdes (cdr from))
                              (cons from (cons pid pids))))
                          `(,to)
                          pipes
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 3df863375..fd810e376 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -257,18 +257,18 @@ exec 2>~a; read REPLY"
     (list (read-string from)
           (status:exit-val (cdr (waitpid pid))))))
 
-(pass-if-equal "piped-process"
+(pass-if-equal "spawn"
     42
   (status:exit-val
-   (cdr (waitpid ((@@ (ice-9 popen) piped-process)
-                  "./meta/guile" '("-c" "(exit 42)"))))))
+   (cdr (waitpid (spawn
+                  "./meta/guile" '("./meta/guile" "-c" "(exit 42)"))))))
 
-(pass-if-equal "piped-process: with output"
+(pass-if-equal "spawn: with output"
     '("foo bar\n" 0)
   (let* ((p (pipe))
-         (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar")
-               (cons (port->fdes (car p))
-                     (port->fdes (cdr p))))))
+         (pid (spawn "echo" '("echo" "foo" "bar")
+                     #:out (cdr p))))
+    (close (cdr p))
     (list (read-string (car p))
           (status:exit-val (cdr (waitpid pid))))))
 
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index bfc6f168e..5c971f4f7 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -340,24 +340,24 @@
 
 (with-test-prefix "system*"
 
-  (pass-if "http://bugs.gnu.org/13166"
-    ;; With Guile up to 2.0.7 included, the child process launched by
-    ;; `system*' would remain alive after an `execvp' failure.
-    (let ((me (getpid)))
-      (and (not (zero? (system* "something-that-does-not-exist")))
-           (= me (getpid)))))
-
-  (pass-if-equal "exit code for nonexistent file"
-      127                                         ;aka. EX_NOTFOUND
-    (status:exit-val (system* "something-that-does-not-exist")))
-
-  (pass-if-equal "https://bugs.gnu.org/55596"
-      127
-    ;; The parameterization below used to cause 'start_child' to close
-    ;; fd 2 in the child process, which in turn would cause it to
-    ;; segfault, leading to a wrong exit code.
-    (parameterize ((current-output-port (current-error-port)))
-      (status:exit-val (system* "something-that-does-not-exist")))))
+  (pass-if-equal "exception for nonexistent file"
+      2 ; ENOENT
+      (call-with-prompt 'escape
+        (lambda ()
+          (with-exception-handler
+              (lambda (exn)
+                (let* ((kind (exception-kind exn))
+                       (errno (and (eq? kind 'system-error)
+                                   (car (car
+                                         (cdr (cdr (cdr (exception-args
+                                                        exn)))))))))
+                  (abort-to-prompt 'escape errno)))
+            (lambda ()
+              (status:exit-val (system*
+                                "something-that-does-not-exist")))
+            #:unwind? #t))
+        (lambda (k arg)
+          arg))))
 
 ;;
 ;; crypt
-- 
2.38.1