bug#52835: [PATCH v8 1/2] Add spawn.

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

* libguile/posix.c: Include spawn.h from Gnulib.
(do_spawn, scm_spawn_process): New functions.
---
 doc/ref/posix.texi |  34 ++++++++--
 libguile/posix.c   | 162 ++++++++++++++++++++++++++++++++++++++++++++-
 libguile/posix.h   |   1 +
 3 files changed, 192 insertions(+), 5 deletions(-)

diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index bde0f150c..36e1f5040 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2045,15 +2045,41 @@ 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 only looking to fork+exec with some pipes set up, using pipes
+or the more primitive @code{spawn} will be more robust (e.g. in the
+presence of threads), and is more portable.  @xref{Pipes} for more.
+@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 program [#:args=(list program)] @
+       [#:env=(environ)] [#:in=(fileno (current-input-port))] @
+       [#:out=(fileno (current-output-port))] @
+       [#:err=(fileno (current-error-port))] @
+       [#:use-path?=#t]
+
+Spawns a new child process executing @var{program} with argument list
+@var{args} (which must include the name of the executable as a first
+element), with its environment variables set to @var{env} and standard
+input/output/error file descriptors to @var{in}, @var{out}, @var{err},
+after closing all other file descriptors.  When @var{use-path?} is
+false, @var{program} should be a path to an executable file, but when
+@var{use-path?} is true, the environment variable @code{PATH} is
+searched to find the corresponding executable.
+
+Failure to exec in the child may be caught early and reported as an
+exception, or the child may also exit with return code 127, depending on
+how spawn is implemented for the specific system.  You therefore must be
+able to handle both cases.
+
+The return value is the pid of the spawned child process.
+
+This procedure is portable and should be thread-safe.
+@end deffn
+
 @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..f79875075 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -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,158 @@ 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 k_args, k_env, k_in, k_out, k_err, k_use_path;
+
+SCM_DEFINE (scm_spawn_process, "spawn", 1, 0, 1,
+            (SCM program, SCM keyword_args),
+            "Spawns a new child process executing @var{program} with no arguments.\n\n"
+            "If the boolean keyword argument @code{#:use-path?} is provided, it\n"
+            "selects whether the @code{PATH} environment variable should be\n"
+            "inspected to find @var{program}.  It is true by default.\n\n"
+            "If the keyword arguments @code{#:args}, @code{#:env}, are provided,\n"
+            "they respectively modify the arguments or the environment of the\n"
+            "spawning program.\n\n"
+            "If the keyword arguments @code{#:in}, @code{#:out} or @code{#:err}\n"
+            "are provided, they respectively modify the default input, output\n"
+            "and error file descriptor of the spawning program to these values.")
+#define FUNC_NAME s_scm_spawn_process
+{
+  SCM args, env, in_scm, out_scm, err_scm, use_path;
+  args = SCM_UNDEFINED;
+  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,
+                                k_args, &args,
+                                k_env, &env,
+                                k_in, &in_scm,
+                                k_out, &out_scm,
+                                k_err, &err_scm,
+                                k_use_path, &use_path,
+                                SCM_UNDEFINED);
+
+  int pid = -1;
+  char *exec_file;
+  char **exec_argv;
+  char **exec_env;
+  int in, out, err;
+
+  exec_file = scm_to_locale_string (program);
+
+  if (SCM_UNBNDP (args))
+    {
+      /* We use scm_gc_malloc here because that's the same as what
+         scm_i_allocate_string_pointers would do. */
+      exec_argv = scm_gc_malloc (2 * sizeof (char *),
+                                 "string pointers");
+      exec_argv[0] = exec_file;
+      exec_argv[1] = NULL;
+    }
+  else
+    {
+      exec_argv = scm_i_allocate_string_pointers (args);
+      if (exec_argv[0] == NULL)
+        {
+          free (exec_file);
+          scm_misc_error (FUNC_NAME, "Argument list must not be empty.",
+                          SCM_EOL);
+        }
+    }
+
+  if (SCM_UNBNDP (env))
+    exec_env = environ;
+  else
+    exec_env = scm_i_allocate_string_pointers (env);
+
+  if (SCM_UNBNDP (in_scm))
+    in = SCM_FPORT_FDES (scm_current_input_port ());
+  else
+    in = scm_to_int (in_scm);
+
+  if (SCM_UNBNDP (out_scm))
+    out = SCM_FPORT_FDES (scm_current_output_port ());
+  else
+    out = scm_to_int (out_scm);
+
+  if (SCM_UNBNDP (err_scm))
+    err = SCM_FPORT_FDES (scm_current_error_port ());
+  else
+    err = scm_to_int (err_scm);
+
+  pid = do_spawn (exec_file, exec_argv, exec_env,
+                  in, out, err, scm_to_bool (use_path));
+
+  free (exec_file);
+
+  if (pid == -1)
+    SCM_SYSERROR;
+
+  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 +2701,11 @@ scm_init_posix ()
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif /* HAVE_START_CHILD */
+#endif /* HAVE_FORK */
+  k_args     = scm_from_utf8_keyword ("args");
+  k_env      = scm_from_utf8_keyword ("env");
+  k_in       = scm_from_utf8_keyword ("in");
+  k_out      = scm_from_utf8_keyword ("out");
+  k_err      = scm_from_utf8_keyword ("err");
+  k_use_path = scm_from_utf8_keyword ("use-path?");
 }
diff --git a/libguile/posix.h b/libguile/posix.h
index 6504eaea8..5eeafd4cb 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -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_API SCM scm_spawn_process (SCM prog, 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);

base-commit: 4711d45176e9b75cef43699ed514669276af62fe
-- 
2.38.1