bug#52835: [PATCH v7 1/2] Add spawn* and 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.
* module/ice-9/spawn.scm: New file
(spawn): New procedure.
---
 libguile/posix.c       | 82 ++++++++++++++++++++++++++++++++++++++++++
 libguile/posix.h       |  2 ++
 module/ice-9/spawn.scm | 54 ++++++++++++++++++++++++++++
 3 files changed, 138 insertions(+)
 create mode 100644 module/ice-9/spawn.scm

diff --git a/libguile/posix.c b/libguile/posix.c
index b5352c2c4..52dc11e57 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>
@@ -1426,6 +1427,87 @@ 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)
+{
+  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);
+
+  if (posix_spawnp (&pid, exec_file, &actions, attrp, exec_argv, exec_env) != 0)
+    return -1;
+
+  return pid;
+}
+
+SCM_DEFINE (scm_spawn_process, "spawn*", 6, 0, 0,
+            (SCM prog, SCM args, SCM env, SCM in, SCM out, SCM err),
+            "Spawns a new child process executing @var{prog} with arguments\n"
+            "@var{args}, with its standard input, output and error file descriptors\n"
+            "set to @var{in}, @var{out}, @var{err}, and environment to @var{env}.")
+#define FUNC_NAME s_scm_spawn_process
+{
+  int pid;
+  char *exec_file;
+  char **exec_argv;
+  char **exec_env;
+
+  exec_file = scm_to_locale_string (prog);
+  exec_argv = scm_i_allocate_string_pointers (args);
+  exec_env = scm_i_allocate_string_pointers (env);
+
+  pid = do_spawn (exec_file, exec_argv, exec_env,
+                  scm_to_int (in),
+                  scm_to_int (out),
+                  scm_to_int (err));
+
+  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)
diff --git a/libguile/posix.h b/libguile/posix.h
index 6504eaea8..35c502bc1 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -69,6 +69,8 @@ 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 args, SCM env,
+                               SCM in, SCM out, SCM err);
 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/module/ice-9/spawn.scm b/module/ice-9/spawn.scm
new file mode 100644
index 000000000..ae4f54efa
--- /dev/null
+++ b/module/ice-9/spawn.scm
@@ -0,0 +1,54 @@
+;; Spawning programs
+
+;;;; Copyright (C) 2022
+;;;;   Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 spawn)
+  #:export (spawn))
+
+(define (port-with-defaults port default-mode)
+  (if (file-port? port)
+      port
+      (open-file "/dev/null" default-mode)))
+
+(define* (spawn exec-file
+                #:optional (args (list exec-file))
+                #:key      (env (environ))
+                           (in (current-input-port))
+                           (out (current-output-port))
+                           (err (current-error-port)))
+  "Spawns a new process running the program @var{exec} with arguments
+@var{args}, in the environment specified by the list of environment
+variable strings @var{env}, and with standard input, output and error
+set to the ports specified by @var{in}, @var{out}, @var{err}.  Note that
+the last part only works with fd-backed ports."
+  (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
+                         args
+                         env
+                         (port->fdes in)
+                         (port->fdes out)
+                         (port->fdes err))))
+    (release-port-handle in)
+    (release-port-handle out)
+    (release-port-handle err)
+    result))

base-commit: 4711d45176e9b75cef43699ed514669276af62fe
-- 
2.38.1