From 551929e4fb77341fa5309c138b2ab92966987966 Mon Sep 17 00:00:00 2001 From: Josselin Poiret Date: Sat, 7 Jan 2023 17:07:46 +0100 Subject: Add 'spawn'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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 Signed-off-by: Ludovic Courtès --- NEWS | 15 ++++- doc/ref/posix.texi | 60 +++++++++++++++-- libguile/posix.c | 156 +++++++++++++++++++++++++++++++++++++++++++- libguile/posix.h | 3 +- test-suite/tests/posix.test | 79 +++++++++++++++++++++- 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 (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 @@ -33,6 +33,7 @@ #include #include #include +#include #ifdef HAVE_SCHED_H # include @@ -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 + ). */ + 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 ;;;; @@ -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 @@ -359,6 +360,80 @@ (parameterize ((current-output-port (current-error-port))) (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 ;; -- cgit v1.2.1