Add 'spawn'.

* libguile/posix.c: Include spawn.h from Gnulib.
(do_spawn, scm_spawn_process): New functions.
(kw_environment, hw_input, kw_output, kw_error, kw_search_path): New
variables.
* doc/ref/posix.texi (Processes): Document it.
* test-suite/tests/posix.test ("spawn"): New test prefix.
* NEWS: Update.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

5 files changed, 303 insertions, 10 deletions

diff --git a/NEWS b/NEWS
index 07011c3c6..b3d31cf89 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,5 @@
 Guile NEWS --- history of user-visible changes.
-Copyright (C) 1996-2022 Free Software Foundation, Inc.
+Copyright (C) 1996-2023 Free Software Foundation, Inc.
 See the end for copying conditions.
 
 Please send Guile bug reports to bug-guile@gnu.org.
@@ -11,6 +11,19 @@ Changes in 3.0.9 (since 3.0.8)
 
 * New interfaces and functionality
 
+** New `spawn' procedure to spawn child processes
+
+The new `spawn' procedure creates a child processes executing the given
+program.  It lets you control the environment variables of that process
+and redirect its standard input, standard output, and standard error
+streams.
+
+Being implemented in terms of `posix_spawn', it is more portable, more
+robust, and more efficient than the combination of `primitive-fork' and
+`execl'.  See "Processes" in the manual for details, and see the 2019
+paper entitled "A fork() in the road" (Andrew Baumann et al.) for
+background information.
+
 ** `open-file' now supports an "e" flag for O_CLOEXEC
 
 Until now, the high-level `open-file' facility did not provide a way to
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index bde0f150c..5653d3758 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2045,15 +2045,67 @@ safe to call after a multithreaded fork, which is a very limited set.
 Guile issues a warning if it detects a fork from a multi-threaded
 program.
 
-If you are going to @code{exec} soon after forking, the procedures in
-@code{(ice-9 popen)} may be useful to you, as they fork and exec within
-an async-signal-safe function carefully written to ensure robust program
-behavior, even in the presence of threads.  @xref{Pipes}, for more.
+@quotation Note
+If you are looking to spawn a process with some pipes set up, using the
+@code{spawn} procedure described below will be more robust (in
+particular in multi-threaded contexts), more portable, and usually more
+efficient than the combination of @code{primitive-fork} and
+@code{execl}.
+
+@c Recommended reading: ``A fork() in the road'', HotOS 2019,
+@c <https://dx.doi.org/10.1145/3317550.3321435> (paywalled :-/).
+@end quotation
 
 This procedure has been renamed from @code{fork} to avoid a naming conflict
 with the scsh fork.
 @end deffn
 
+@deffn {Scheme Procedure} spawn @var{program} @var{arguments} @
+       [#:environment=(environ)] @
+       [#:input=(current-input-port)] @
+       [#:output=(current-output-port)] @
+       [#:error=(current-error-port)] @
+       [#:search-path?=#t]
+Spawn a new child process executing @var{program} with the
+given @var{arguments}, a list of one or more strings (by
+convention, the first argument is typically @var{program}),
+and return its PID.  Raise a @code{system-error} exception if
+@var{program} could not be found or could not be executed.
+
+If the keyword argument @code{#:search-path?} is true, it
+selects whether the @env{PATH} environment variable should be
+inspected to find @var{program}.  It is true by default.
+
+The @code{#:environment} keyword parameter specifies the
+list of environment variables of the child process.  It
+defaults to @code{(environ)}.
+
+The keyword arguments @code{#:input}, @code{#:output}, and
+@code{#:error} specify the port or file descriptor for the
+child process to use as standard input, standard output, and
+standard error.  No other file descriptors are inherited
+from the parent process.
+@end deffn
+
+The example below shows how to spawn the @command{uname} program with
+the @option{-o} option (@pxref{uname invocation,,, coreutils, GNU
+Coreutils}), redirect its standard output to a pipe, and read from it:
+
+@lisp
+(use-modules (rnrs io ports))
+
+(let* ((input+output (pipe))
+       (pid (spawn "uname" '("uname" "-o")
+                    #:output (cdr input+output))))
+  (close-port (cdr input+output))
+  (format #t "read ~s~%" (get-string-all (car input+output)))
+  (close-port (car input+output))
+  (waitpid pid))
+
+@print{} read "GNU/Linux\n"
+@result{} (1234 . 0)
+@end lisp
+
 @deffn {Scheme Procedure} nice incr
 @deffnx {C Function} scm_nice (incr)
 @cindex process priority
diff --git a/libguile/posix.c b/libguile/posix.c
index b5352c2c4..0e6a38f33 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2014, 2016-2019, 2021-2022
+/* Copyright 1995-2014, 2016-2019, 2021-2023
      Free Software Foundation, Inc.
    Copyright 2021 Maxime Devos <maximedevos@telenet.be>
 
@@ -33,6 +33,7 @@
 #include <sys/types.h>
 #include <uniconv.h>
 #include <unistd.h>
+#include <spawn.h>
 
 #ifdef HAVE_SCHED_H
 # include <sched.h>
@@ -63,6 +64,7 @@
 #include "fports.h"
 #include "gettext.h"
 #include "gsubr.h"
+#include "keywords.h"
 #include "list.h"
 #include "modules.h"
 #include "numbers.h"
@@ -1426,6 +1428,156 @@ start_child (const char *exec_file, char **exec_argv,
 }
 #endif
 
+static pid_t
+do_spawn (char *exec_file, char **exec_argv, char **exec_env,
+          int in, int out, int err, int spawnp)
+{
+  pid_t pid = -1;
+
+  posix_spawn_file_actions_t actions;
+  posix_spawnattr_t *attrp = NULL;
+
+  int max_fd = 1024;
+
+#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE)
+  {
+    struct rlimit lim = { 0, 0 };
+    if (getrlimit (RLIMIT_NOFILE, &lim) == 0)
+      max_fd = lim.rlim_cur;
+  }
+#endif
+
+  posix_spawn_file_actions_init (&actions);
+
+  int free_fd_slots = 0;
+  int fd_slot[3];
+
+  for (int fdnum = 3;free_fd_slots < 3 && fdnum < max_fd;fdnum++)
+    {
+      if (fdnum != in && fdnum != out && fdnum != err)
+        {
+          fd_slot[free_fd_slots] = fdnum;
+          free_fd_slots++;
+        }
+    }
+
+  /* Move the fds out of the way, so that duplicate fds or fds equal
+     to 0, 1, 2 don't trample each other */
+
+  posix_spawn_file_actions_adddup2 (&actions, in, fd_slot[0]);
+  posix_spawn_file_actions_adddup2 (&actions, out, fd_slot[1]);
+  posix_spawn_file_actions_adddup2 (&actions, err, fd_slot[2]);
+  posix_spawn_file_actions_adddup2 (&actions, fd_slot[0], 0);
+  posix_spawn_file_actions_adddup2 (&actions, fd_slot[1], 1);
+  posix_spawn_file_actions_adddup2 (&actions, fd_slot[2], 2);
+
+  while (--max_fd > 2)
+    posix_spawn_file_actions_addclose (&actions, max_fd);
+
+  int res = -1;
+  if (spawnp)
+    res = posix_spawnp (&pid, exec_file, &actions, attrp,
+                        exec_argv, exec_env);
+  else
+    res = posix_spawn (&pid, exec_file, &actions, attrp,
+                       exec_argv, exec_env);
+  if (res != 0)
+    return -1;
+
+  return pid;
+}
+
+SCM_KEYWORD (kw_environment, "environment");
+SCM_KEYWORD (kw_input, "input");
+SCM_KEYWORD (kw_output, "output");
+SCM_KEYWORD (kw_error, "error");
+SCM_KEYWORD (kw_search_path, "search-path?");
+
+SCM_DEFINE (scm_spawn_process, "spawn", 2, 0, 1,
+            (SCM program, SCM arguments, SCM keyword_args),
+            "Spawn a new child process executing @var{program} with the\n"
+            "given @var{arguments}, a list of one or more strings (by\n"
+            "convention, the first argument is typically @var{program}),\n"
+            "and return its PID.  Raise a @code{system-error} exception if\n"
+            "@var{program} could not be found or could not be executed.\n\n"
+            "If the keyword argument @code{#:search-path?} is true, it\n"
+            "selects whether the @env{PATH} environment variable should be\n"
+            "inspected to find @var{program}.  It is true by default.\n\n"
+            "The @code{#:environment} keyword parameter specifies the\n"
+            "list of environment variables of the child process.  It\n"
+            "defaults to @code{(environ)}.\n\n"
+            "The keyword arguments @code{#:input}, @code{#:output}, and\n"
+            "@code{#:error} specify the port or file descriptor for the\n"
+            "child process to use as standard input, standard output, and\n"
+            "standard error.  No other file descriptors are inherited\n"
+            "from the parent process.\n")
+#define FUNC_NAME s_scm_spawn_process
+{
+  SCM env, in_scm, out_scm, err_scm, use_path;
+  int pid = -1;
+  char *exec_file, **exec_argv, **exec_env;
+  int in, out, err;
+
+  /* In theory 'exec' accepts zero arguments, but programs are typically
+     not prepared for that and POSIX says: "The value in argv[0] should
+     point to a filename string that is associated with the process
+     image being started" (see
+     <https://pubs.opengroup.org/onlinepubs/9699919799/functions/posix_spawn.html>). */
+  SCM_VALIDATE_NONEMPTYLIST (1, arguments);
+
+  env = SCM_UNDEFINED;
+  in_scm = SCM_UNDEFINED;
+  out_scm = SCM_UNDEFINED;
+  err_scm = SCM_UNDEFINED;
+  use_path = SCM_BOOL_T;
+
+  scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
+                                kw_environment, &env,
+                                kw_input, &in_scm,
+                                kw_output, &out_scm,
+                                kw_error, &err_scm,
+                                kw_search_path, &use_path,
+                                SCM_UNDEFINED);
+
+  scm_dynwind_begin (0);
+
+  exec_file = scm_to_locale_string (program);
+  scm_dynwind_free (exec_file);
+
+  exec_argv = scm_i_allocate_string_pointers (arguments);
+
+  if (SCM_UNBNDP (env))
+    exec_env = environ;
+  else
+    exec_env = scm_i_allocate_string_pointers (env);
+
+  if (SCM_UNBNDP (in_scm))
+    in_scm = scm_current_input_port ();
+  if (SCM_UNBNDP (out_scm))
+    out_scm = scm_current_output_port ();
+  if (SCM_UNBNDP (err_scm))
+    err_scm = scm_current_error_port ();
+
+#define FDES_FROM_PORT_OR_INTEGER(obj)                                  \
+  (scm_is_integer (obj) ? scm_to_int (obj) : SCM_FPORT_FDES (obj))
+
+  in  = FDES_FROM_PORT_OR_INTEGER (in_scm);
+  out = FDES_FROM_PORT_OR_INTEGER (out_scm);
+  err = FDES_FROM_PORT_OR_INTEGER (err_scm);
+
+#undef FDES_FROM_PORT_OR_INTEGER
+
+  pid = do_spawn (exec_file, exec_argv, exec_env,
+                  in, out, err, scm_to_bool (use_path));
+  if (pid == -1)
+    SCM_SYSERROR;
+
+  scm_dynwind_end ();
+
+  return scm_from_int (pid);
+}
+#undef FUNC_NAME
+
 #ifdef HAVE_START_CHILD
 static SCM
 scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
@@ -2547,5 +2699,5 @@ scm_init_posix ()
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif /* HAVE_START_CHILD */
+#endif /* HAVE_FORK */
 }
diff --git a/libguile/posix.h b/libguile/posix.h
index 6504eaea8..a4b0297b3 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -1,7 +1,7 @@
 #ifndef SCM_POSIX_H
 #define SCM_POSIX_H
 
-/* Copyright 1995-1998,2000-2001,2003,2006,2008-2011,2018,2021,2022
+/* Copyright 1995-1998, 2000-2001, 2003, 2006, 2008-2011, 2018, 2021-2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -69,6 +69,7 @@ SCM_API SCM scm_tmpnam (void);
 SCM_API SCM scm_tmpfile (void);
 SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes);
 SCM_API SCM scm_close_pipe (SCM port);
+SCM_INTERNAL SCM scm_spawn_process (SCM prog, SCM arguments, SCM keyword_args);
 SCM_API SCM scm_system_star (SCM cmds);
 SCM_API SCM scm_utime (SCM object, SCM actime, SCM modtime,
                        SCM actimens, SCM modtimens, SCM flags);
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index bfc6f168e..ad13a0a07 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -1,6 +1,6 @@
 ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
 ;;;;
-;;;; Copyright 2003-2004, 2006-2007, 2010, 2012, 2015, 2017-2019, 2021-2022
+;;;; Copyright 2003-2004, 2006-2007, 2010, 2012, 2015, 2017-2019, 2021-2023
 ;;;;   Free Software Foundation, Inc.
 ;;;; Copyright 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;;
@@ -19,7 +19,8 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite test-posix)
-  :use-module (test-suite lib))
+  #:use-module (test-suite lib)
+  #:use-module ((rnrs io ports) #:select (get-string-all)))
 
 
 ;; FIXME: The following exec tests are disabled since on an i386 debian with
@@ -360,6 +361,80 @@
       (status:exit-val (system* "something-that-does-not-exist")))))
 
 ;;
+;; spawn
+;;
+
+(with-test-prefix "spawn"
+
+  (pass-if-equal "basic"
+      0
+    (cdr (waitpid (spawn "true" '("true")))))
+
+  (pass-if-equal "uname with stdout redirect"
+      (list 0                                     ;exit value
+            (string-append (utsname:sysname (uname)) " "
+                           (utsname:machine (uname)) "\n"))
+    (let* ((input+output (pipe))
+           (pid (spawn "uname" '("uname" "-s" "-m")
+                       #:output (cdr input+output))))
+      (close-port (cdr input+output))
+      (let ((str (get-string-all (car input+output))))
+        (close-port (car input+output))
+        (list (cdr (waitpid pid)) str))))
+
+  (pass-if-equal "wc with stdin and stdout redirects"
+      "2\n"
+    (let* ((a+b (pipe))
+           (c+d (pipe))
+           (pid (spawn "wc" '("wc" "-w")
+                       #:input (car a+b)
+                       #:output (cdr c+d))))
+      (close-port (car a+b))
+      (close-port (cdr c+d))
+
+      (display "Hello world.\n" (cdr a+b))
+      (close-port (cdr a+b))
+
+      (let ((str (get-string-all (car c+d))))
+        (close-port (car c+d))
+        (waitpid pid)
+        str)))
+
+  (pass-if-equal "env with #:environment and #:output"
+      "GNU=guile\n"
+    (let* ((input+output (pipe))
+           (pid (spawn "env" '("env")
+                       #:environment '("GNU=guile")
+                       #:output (cdr input+output))))
+      (close-port (cdr input+output))
+      (let ((str (get-string-all (car input+output))))
+        (close-port (car input+output))
+        (waitpid pid)
+        str)))
+
+  (pass-if-equal "ls /proc/self/fd"
+      "0\n1\n2\n3\n"                     ;fourth FD is for /proc/self/fd
+    (if (file-exists? "/proc/self/fd")   ;Linux
+        (let* ((input+output (pipe))
+               (pid (spawn "ls" '("ls" "/proc/self/fd")
+                           #:output (cdr input+output))))
+          (close-port (cdr input+output))
+          (let ((str (get-string-all (car input+output))))
+            (close-port (car input+output))
+            (waitpid pid)
+            str))
+        (throw 'unresolved)))
+
+  (pass-if-equal "file not found"
+      ENOENT
+    (catch 'system-error
+      (lambda ()
+        (spawn "this-does-not-exist" '("nope")
+               #:search-path? #f))
+      (lambda args
+        (system-error-errno args)))))
+
+;;
 ;; crypt
 ;;