* libguile/posix.c (renumber_file_descriptor, start_child,
scm_piped_process): Remove functions.
(scm_port_to_fd_with_default): New helper function.
(scm_system_star): Rewrite using scm_spawn_process.
(scm_init_popen): Remove the definition of piped-process.
(scm_init_posix): Now make popen available unconditionally.
* module/ice-9/popen.scm (port-with-defaults): New helper procedure.
(spawn): New procedure.
(open-process): Rewrite using spawn.
(pipeline): Rewrite using spawn*.
* test-suite/tests/popen.test ("piped-process", "piped-process:
with-output"): Removed tests.
("spawn", "spawn: with output"): Added tests.
* test-suite/tests/posix.test ("http://bugs.gnu.org/13166";, "exit code
for nonexistent file", "https://bugs.gnu.org/55596";): Remove obsolete
tests.
("exception for nonexistent file"): Add test.
---
libguile/posix.c | 218 +++---------------------------------
module/ice-9/popen.scm | 83 ++++++++++----
test-suite/tests/popen.test | 14 +--
test-suite/tests/posix.test | 36 +++---
4 files changed, 102 insertions(+), 249 deletions(-)
diff --git a/libguile/posix.c b/libguile/posix.c
index 5d287ff2a..c35346f9f 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -73,6 +73,7 @@
#include "fports.h"
#include "gettext.h"
#include "gsubr.h"
+#include "ioext.h"
#include "list.h"
#include "modules.h"
#include "numbers.h"
@@ -1280,199 +1281,6 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_FORK */
-#ifdef HAVE_FORK
-/* 'renumber_file_descriptor' is a helper function for 'start_child'
- below, and is specialized for that particular environment where it
- doesn't make sense to report errors via exceptions. It uses dup(2)
- to duplicate the file descriptor FD, closes the original FD, and
- returns the new descriptor. If dup(2) fails, print an error message
- to ERR and abort. */
-static int
-renumber_file_descriptor (int fd, int err)
-{
- int new_fd;
-
- do
- new_fd = dup (fd);
- while (new_fd == -1 && errno == EINTR);
-
- if (new_fd == -1)
- {
- /* At this point we are in the child process before exec. We
- cannot safely raise an exception in this environment. */
- const char *msg = strerror (errno);
- fprintf (fdopen (err, "a"), "start_child: dup failed: %s\n", msg);
- _exit (127); /* Use exit status 127, as with other exec errors. */
- }
-
- close (fd);
- return new_fd;
-}
-#endif /* HAVE_FORK */
-
-#ifdef HAVE_FORK
-#define HAVE_START_CHILD 1
-/* Since Guile uses threads, we have to be very careful to avoid calling
- functions that are not async-signal-safe in the child. That's why
- this function is implemented in C. */
-static pid_t
-start_child (const char *exec_file, char **exec_argv,
- int reading, int c2p[2], int writing, int p2c[2],
- int in, int out, int err)
-{
- int pid;
- 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
-
- pid = fork ();
-
- if (pid != 0)
- /* The parent, with either and error (pid == -1), or the PID of the
- child. Return directly in either case. */
- return pid;
-
- /* The child. */
- if (reading)
- close (c2p[0]);
- if (writing)
- close (p2c[1]);
-
- /* Close all file descriptors in ports inherited from the parent
- except for in, out, and err. Heavy-handed, but robust. */
- while (max_fd--)
- if (max_fd != in && max_fd != out && max_fd != err)
- close (max_fd);
-
- /* Ignore errors on these open() calls. */
- if (in == -1)
- in = open ("/dev/null", O_RDONLY);
- if (out == -1)
- out = open ("/dev/null", O_WRONLY);
- if (err == -1)
- err = open ("/dev/null", O_WRONLY);
-
- if (in > 0)
- {
- if (out == 0)
- out = renumber_file_descriptor (out, err);
- if (err == 0)
- err = renumber_file_descriptor (err, err);
- do dup2 (in, 0); while (errno == EINTR);
- close (in);
- }
- if (out > 1)
- {
- if (err == 1)
- err = renumber_file_descriptor (err, err);
- do dup2 (out, 1); while (errno == EINTR);
- if (out > 2)
- close (out);
- }
- if (err > 2)
- {
- do dup2 (err, 2); while (errno == EINTR);
- close (err);
- }
-
- execvp (exec_file, exec_argv);
-
- /* The exec failed! There is nothing sensible to do. */
- {
- const char *msg = strerror (errno);
- fprintf (fdopen (2, "a"), "In execvp of %s: %s\n",
- exec_file, msg);
- }
-
- /* Use exit status 127, like shells in this case, as per POSIX
-
<http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>.
*/
- _exit (127);
-
- /* Not reached. */
- return -1;
-}
-#endif
-
-#ifdef HAVE_START_CHILD
-static SCM
-scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
-#define FUNC_NAME "piped-process"
-{
- int reading, writing;
- int c2p[2]; /* Child to parent. */
- int p2c[2]; /* Parent to child. */
- int in = -1, out = -1, err = -1;
- int pid;
- char *exec_file;
- char **exec_argv;
-
- exec_file = scm_to_locale_string (prog);
- exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
-
- reading = scm_is_pair (from);
- writing = scm_is_pair (to);
-
- if (reading)
- {
- c2p[0] = scm_to_int (scm_car (from));
- c2p[1] = scm_to_int (scm_cdr (from));
- out = c2p[1];
- }
-
- if (writing)
- {
- p2c[0] = scm_to_int (scm_car (to));
- p2c[1] = scm_to_int (scm_cdr (to));
- in = p2c[0];
- }
-
- {
- SCM port;
-
- if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
- err = SCM_FPORT_FDES (port);
- if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
- out = SCM_FPORT_FDES (port);
- if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
- in = SCM_FPORT_FDES (port);
- }
-
- pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c,
- in, out, err);
-
- if (pid == -1)
- {
- int errno_save = errno;
- free (exec_file);
- if (reading)
- {
- close (c2p[0]);
- close (c2p[1]);
- }
- if (writing)
- {
- close (p2c[0]);
- close (p2c[1]);
- }
- errno = errno_save;
- SCM_SYSERROR;
- }
-
- if (reading)
- close (c2p[1]);
- if (writing)
- close (p2c[0]);
-
- return scm_from_int (pid);
-}
-#undef FUNC_NAME
-
static SCM
scm_spawn_process (SCM prog, SCM args, SCM scm_in, SCM scm_out, SCM scm_err)
#define FUNC_NAME "spawn*"
@@ -1563,6 +1371,15 @@ scm_dynwind_sigaction (int sig, SCM handler, SCM flags)
SCM_F_WIND_EXPLICITLY);
}
+static SCM
+scm_port_to_fd_with_default (SCM port, int mode)
+{
+ if (!SCM_FPORTP (port))
+ return scm_from_int (open_or_open64 ("/dev/null", mode));
+ return scm_fileno (port);
+
+}
+
SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
(SCM args),
"Execute the command indicated by @var{args}. The first element must\n"
@@ -1589,7 +1406,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
if (scm_is_null (args))
SCM_WRONG_NUM_ARGS ();
prog = scm_car (args);
- args = scm_cdr (args);
scm_dynwind_begin (0);
/* Make sure the child can't kill us (as per normal system call). */
@@ -1602,7 +1418,13 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
SCM_UNDEFINED);
#endif
- pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED);
+ SCM in, out, err;
+
+ in = scm_port_to_fd_with_default (scm_current_input_port (), O_RDONLY);
+ out = scm_port_to_fd_with_default (scm_current_output_port (), O_WRONLY);
+ err = scm_port_to_fd_with_default (scm_current_error_port (), O_WRONLY);
+
+ pid = scm_spawn_process (prog, args, in, out, err);
SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0));
if (wait_result == -1)
SCM_SYSERROR;
@@ -1612,7 +1434,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
return scm_from_int (status);
}
#undef FUNC_NAME
-#endif /* HAVE_START_CHILD */
#ifdef HAVE_UNAME
SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
@@ -2446,14 +2267,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
#endif /* HAVE_GETHOSTNAME */
-#ifdef HAVE_START_CHILD
static void
scm_init_popen (void)
{
- scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process);
scm_c_define_gsubr ("spawn*", 5, 0, 0, scm_spawn_process);
}
-#endif /* HAVE_START_CHILD */
void
scm_init_posix ()
@@ -2566,11 +2384,9 @@ scm_init_posix ()
#ifdef HAVE_FORK
scm_add_feature ("fork");
#endif /* HAVE_FORK */
-#ifdef HAVE_START_CHILD
scm_add_feature ("popen");
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_popen",
(scm_t_extension_init_func) scm_init_popen,
NULL);
-#endif /* HAVE_START_CHILD */
}
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index e638726a4..533282f4d 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -25,12 +25,37 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
- open-output-pipe open-input-output-pipe pipeline))
+ open-output-pipe open-input-output-pipe pipeline
+ spawn* spawn))
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_popen"))
+(define (port-with-defaults port default-mode)
+ (if (file-port? port)
+ port
+ (open-file "/dev/null" default-mode)))
+
+(define* (spawn exec-file argv #:key
+ (in (current-input-port))
+ (out (current-output-port))
+ (err (current-error-port)))
+ (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
+ argv
+ (port->fdes in)
+ (port->fdes out)
+ (port->fdes err))))
+ (release-port-handle in)
+ (release-port-handle out)
+ (release-port-handle err)
+ result))
+
(define-record-type <pipe-info>
(make-pipe-info pid)
pipe-info?
@@ -92,13 +117,13 @@
(define (open-process mode command . args)
"Backwards compatible implementation of the former procedure in
-libguile/posix.c (scm_open_process) replaced by
-scm_piped_process. Executes the program @var{command} with optional
-arguments @var{args} (all strings) in a subprocess. A port to the
-process (based on pipes) is created and returned. @var{mode} specifies
-whether an input, an output or an input-output port to the process is
-created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE}
-or @code{OPEN_BOTH}."
+libguile/posix.c (scm_open_process) replaced by scm_piped_process, now
+replaced by scm_spawn_process. Executes the program @var{command} with
+optional arguments @var{args} (all strings) in a subprocess. A port to
+the process (based on pipes) is created and returned. @var{mode}
+specifies whether an input, an output or an input-output port to the
+process is created: it should be the value of @code{OPEN_READ},
+@code{OPEN_WRITE} or @code{OPEN_BOTH}."
(define (unbuffered port)
(setvbuf port 'none)
port)
@@ -107,19 +132,25 @@ or @code{OPEN_BOTH}."
(and ports
(cons (port->fdes (car ports)) (port->fdes (cdr ports)))))
- (let* ((from (and (or (string=? mode OPEN_READ)
- (string=? mode OPEN_BOTH))
- (pipe)))
- (to (and (or (string=? mode OPEN_WRITE)
- (string=? mode OPEN_BOTH))
- (pipe)))
- (pid (piped-process command args
- (fdes-pair from)
- (fdes-pair to))))
+ (let* ((child-to-parent (and (or (string=? mode OPEN_READ)
+ (string=? mode OPEN_BOTH))
+ (pipe)))
+ (parent-to-child (and (or (string=? mode OPEN_WRITE)
+ (string=? mode OPEN_BOTH))
+ (pipe)))
+ (in (or (and=> parent-to-child car) (current-input-port)))
+ (out (or (and=> child-to-parent cdr) (current-output-port)))
+ (pid (spawn command (cons command args)
+ #:in in
+ #:out out)))
+ (when child-to-parent
+ (close (cdr child-to-parent)))
+ (when parent-to-child
+ (close (car parent-to-child)))
;; The original 'open-process' procedure would return unbuffered
;; ports; do the same here.
- (values (and from (unbuffered (car from)))
- (and to (unbuffered (cdr to)))
+ (values (and child-to-parent (unbuffered (car child-to-parent)))
+ (and parent-to-child (unbuffered (cdr parent-to-child)))
pid)))
(define (open-pipe* mode command . args)
@@ -224,10 +255,16 @@ a list of PIDs of the processes executing the
@var{commands}."
(pipeline (fold (lambda (from proc prev)
(let* ((to (car prev))
(pids (cdr prev))
- (pid (piped-process (car proc)
- (cdr proc)
- from
- to)))
+ (pid (spawn* (car proc)
+ proc
+ (car to)
+ (cdr from)
+ (port->fdes
+ (port-with-defaults
+ (current-error-port)
+ "w")))))
+ (close-fdes (car to))
+ (close-fdes (cdr from))
(cons from (cons pid pids))))
`(,to)
pipes
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 3df863375..fd810e376 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -257,18 +257,18 @@ exec 2>~a; read REPLY"
(list (read-string from)
(status:exit-val (cdr (waitpid pid))))))
-(pass-if-equal "piped-process"
+(pass-if-equal "spawn"
42
(status:exit-val
- (cdr (waitpid ((@@ (ice-9 popen) piped-process)
- "./meta/guile" '("-c" "(exit 42)"))))))
+ (cdr (waitpid (spawn
+ "./meta/guile" '("./meta/guile" "-c" "(exit 42)"))))))
-(pass-if-equal "piped-process: with output"
+(pass-if-equal "spawn: with output"
'("foo bar\n" 0)
(let* ((p (pipe))
- (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar")
- (cons (port->fdes (car p))
- (port->fdes (cdr p))))))
+ (pid (spawn "echo" '("echo" "foo" "bar")
+ #:out (cdr p))))
+ (close (cdr p))
(list (read-string (car p))
(status:exit-val (cdr (waitpid pid))))))
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 500dbb94a..157f21e24 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -236,24 +236,24 @@
(with-test-prefix "system*"
- (pass-if "http://bugs.gnu.org/13166";
- ;; With Guile up to 2.0.7 included, the child process launched by
- ;; `system*' would remain alive after an `execvp' failure.
- (let ((me (getpid)))
- (and (not (zero? (system* "something-that-does-not-exist")))
- (= me (getpid)))))
-
- (pass-if-equal "exit code for nonexistent file"
- 127 ;aka. EX_NOTFOUND
- (status:exit-val (system* "something-that-does-not-exist")))
-
- (pass-if-equal "https://bugs.gnu.org/55596";
- 127
- ;; The parameterization below used to cause 'start_child' to close
- ;; fd 2 in the child process, which in turn would cause it to
- ;; segfault, leading to a wrong exit code.
- (parameterize ((current-output-port (current-error-port)))
- (status:exit-val (system* "something-that-does-not-exist")))))
+ (pass-if-equal "exception for nonexistent file"
+ 2 ; ENOENT
+ (call-with-prompt 'escape
+ (lambda ()
+ (with-exception-handler
+ (lambda (exn)
+ (let* ((kind (exception-kind exn))
+ (errno (and (eq? kind 'system-error)
+ (car (car
+ (cdr (cdr (cdr (exception-args
+ exn)))))))))
+ (abort-to-prompt 'escape errno)))
+ (lambda ()
+ (status:exit-val (system*
+ "something-that-does-not-exist")))
+ #:unwind? #t))
+ (lambda (k arg)
+ arg))))
;;
;; crypt
--
2.37.2
