mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add 'spawn'.

Browse source 
* 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>
This commit is contained in:
Josselin Poiret 2023-01-07 17:07:46 +01:00 • committed by Ludovic Courtès
parent edfca3b7e5
commit 551929e4fb
5 changed files with 303 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

15
NEWS
View file

@ -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

60
doc/ref/posix.texi
View file

@ -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

156
libguile/posix.c
View file

@ -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 */
}

3
libguile/posix.h
View file

@ -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);

79
test-suite/tests/posix.test
View file

@ -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
@ -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
;;