mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
rewrite open-process in C, for robustness
* libguile/posix.c (scm_open_process): Rewrite in C, so as to avoid allocations and other calls that are not async-signal-safe. (scm_init_popen, scm_init_posix): Register popen extension. * module/ice-9/popen.scm: Load the popen extension, to get open-process.
This commit is contained in:
Andy Wingo
parent
7ea70f355e
commit
a2e946f1ef
2 changed files with 214 additions and 95 deletions
208
libguile/posix.c
208
libguile/posix.c
|
|
@ -1254,6 +1254,201 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
|
|||
return scm_from_int (pid);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
/* 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 SCM
|
||||
scm_open_process (SCM mode, SCM prog, SCM args)
|
||||
#define FUNC_NAME "open-process"
|
||||
{
|
||||
long mode_bits;
|
||||
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;
|
||||
int max_fd = 1024;
|
||||
|
||||
exec_file = scm_to_locale_string (prog);
|
||||
exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
|
||||
|
||||
mode_bits = scm_i_mode_bits (mode);
|
||||
reading = mode_bits & SCM_RDNG;
|
||||
writing = mode_bits & SCM_WRTNG;
|
||||
|
||||
if (reading)
|
||||
{
|
||||
if (pipe (c2p))
|
||||
{
|
||||
int errno_save = errno;
|
||||
free (exec_file);
|
||||
errno = errno_save;
|
||||
SCM_SYSERROR;
|
||||
}
|
||||
out = c2p[1];
|
||||
}
|
||||
|
||||
if (writing)
|
||||
{
|
||||
if (pipe (p2c))
|
||||
{
|
||||
int errno_save = errno;
|
||||
free (exec_file);
|
||||
if (reading)
|
||||
{
|
||||
close (c2p[0]);
|
||||
close (c2p[1]);
|
||||
}
|
||||
errno = errno_save;
|
||||
SCM_SYSERROR;
|
||||
}
|
||||
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);
|
||||
}
|
||||
|
||||
#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 == -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 (pid)
|
||||
/* Parent. */
|
||||
{
|
||||
SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port;
|
||||
|
||||
/* There is no sense in catching errors on close(). */
|
||||
if (reading)
|
||||
{
|
||||
close (c2p[1]);
|
||||
read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe);
|
||||
scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
|
||||
}
|
||||
if (writing)
|
||||
{
|
||||
close (p2c[0]);
|
||||
write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
|
||||
scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
|
||||
}
|
||||
|
||||
if (reading && writing)
|
||||
{
|
||||
static SCM make_rw_port = SCM_BOOL_F;
|
||||
|
||||
if (scm_is_false (make_rw_port))
|
||||
make_rw_port = scm_c_private_variable ("ice-9 popen",
|
||||
"make-rw-port");
|
||||
|
||||
port = scm_call_2 (scm_variable_ref (make_rw_port),
|
||||
read_port, write_port);
|
||||
}
|
||||
else if (reading)
|
||||
port = read_port;
|
||||
else if (writing)
|
||||
port = write_port;
|
||||
else
|
||||
port = scm_sys_make_void_port (mode);
|
||||
|
||||
return scm_cons (port, scm_from_int (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)
|
||||
do out = dup (out); while (errno == EINTR);
|
||||
if (err == 0)
|
||||
do err = dup (err); while (errno == EINTR);
|
||||
do dup2 (in, 0); while (errno == EINTR);
|
||||
close (in);
|
||||
}
|
||||
if (out > 1)
|
||||
{
|
||||
if (err == 1)
|
||||
do err = dup (err); while (errno == EINTR);
|
||||
do dup2 (out, 1); while (errno == EINTR);
|
||||
close (out);
|
||||
}
|
||||
if (err > 2)
|
||||
{
|
||||
do dup2 (err, 2); while (errno == EINTR);
|
||||
close (err);
|
||||
}
|
||||
|
||||
execvp (exec_file,
|
||||
#ifdef __MINGW32__
|
||||
/* extra "const" in mingw formals, provokes warning from gcc */
|
||||
(const char * const *)
|
||||
#endif
|
||||
exec_argv);
|
||||
|
||||
/* The exec failed! There is nothing sensible to do. */
|
||||
if (err > 0)
|
||||
{
|
||||
char *msg = strerror (errno);
|
||||
fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
|
||||
exec_file, msg);
|
||||
}
|
||||
|
||||
_exit (EXIT_FAILURE);
|
||||
/* Not reached. */
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
#endif /* HAVE_FORK */
|
||||
|
||||
#ifdef __MINGW32__
|
||||
|
|
@ -2083,6 +2278,14 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
|
|||
#endif /* HAVE_GETHOSTNAME */
|
||||
|
||||
|
||||
#ifdef HAVE_FORK
|
||||
static void
|
||||
scm_init_popen (void)
|
||||
{
|
||||
scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
|
||||
}
|
||||
#endif
|
||||
|
||||
void
|
||||
scm_init_posix ()
|
||||
{
|
||||
|
|
@ -2171,6 +2374,11 @@ scm_init_posix ()
|
|||
|
||||
#include "libguile/cpp-SIG.c"
|
||||
#include "libguile/posix.x"
|
||||
|
||||
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
|
||||
"scm_init_popen",
|
||||
(scm_t_extension_init_func) scm_init_popen,
|
||||
NULL);
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;; popen emulation, for non-stdio based ports.
|
||||
|
||||
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012 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
|
||||
|
|
@ -21,6 +21,10 @@
|
|||
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
|
||||
open-output-pipe open-input-output-pipe))
|
||||
|
||||
(eval-when (load eval compile)
|
||||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_popen"))
|
||||
|
||||
(define (make-rw-port read-port write-port)
|
||||
(make-soft-port
|
||||
(vector
|
||||
|
|
@ -38,100 +42,6 @@
|
|||
;; a weak hash-table to store the process ids.
|
||||
(define port/pid-table (make-weak-key-hash-table 31))
|
||||
|
||||
(define (ensure-fdes port mode)
|
||||
(or (false-if-exception (fileno port))
|
||||
(open-fdes *null-device* mode)))
|
||||
|
||||
;; run a process connected to an input, an output or an
|
||||
;; input/output port
|
||||
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
|
||||
;; returns port/pid pair.
|
||||
(define (open-process mode prog . args)
|
||||
(let* ((reading (or (equal? mode OPEN_READ)
|
||||
(equal? mode OPEN_BOTH)))
|
||||
(writing (or (equal? mode OPEN_WRITE)
|
||||
(equal? mode OPEN_BOTH)))
|
||||
(c2p (if reading (pipe) #f)) ; child to parent
|
||||
(p2c (if writing (pipe) #f))) ; parent to child
|
||||
|
||||
(if c2p (setvbuf (cdr c2p) _IONBF))
|
||||
(if p2c (setvbuf (cdr p2c) _IONBF))
|
||||
(let ((pid (primitive-fork)))
|
||||
(cond ((= pid 0)
|
||||
;; child
|
||||
(ensure-batch-mode!)
|
||||
|
||||
;; select the three file descriptors to be used as
|
||||
;; standard descriptors 0, 1, 2 for the new
|
||||
;; process. They are pipes to/from the parent or taken
|
||||
;; from the current Scheme input/output/error ports if
|
||||
;; possible.
|
||||
|
||||
(let ((input-fdes (if writing
|
||||
(fileno (car p2c))
|
||||
(ensure-fdes (current-input-port)
|
||||
O_RDONLY)))
|
||||
(output-fdes (if reading
|
||||
(fileno (cdr c2p))
|
||||
(ensure-fdes (current-output-port)
|
||||
O_WRONLY)))
|
||||
(error-fdes (ensure-fdes (current-error-port)
|
||||
O_WRONLY)))
|
||||
|
||||
;; close all file descriptors in ports inherited from
|
||||
;; the parent except for the three selected above.
|
||||
;; this is to avoid causing problems for other pipes in
|
||||
;; the parent.
|
||||
|
||||
;; use low-level system calls, not close-port or the
|
||||
;; scsh routines, to avoid side-effects such as
|
||||
;; flushing port buffers or evicting ports.
|
||||
|
||||
(port-for-each (lambda (pt-entry)
|
||||
(false-if-exception
|
||||
(let ((pt-fileno (fileno pt-entry)))
|
||||
(if (not (or (= pt-fileno input-fdes)
|
||||
(= pt-fileno output-fdes)
|
||||
(= pt-fileno error-fdes)))
|
||||
(close-fdes pt-fileno))))))
|
||||
|
||||
;; Copy the three selected descriptors to the standard
|
||||
;; descriptors 0, 1, 2, if not already there
|
||||
|
||||
(cond ((not (= input-fdes 0))
|
||||
(if (= output-fdes 0)
|
||||
(set! output-fdes (dup->fdes 0)))
|
||||
(if (= error-fdes 0)
|
||||
(set! error-fdes (dup->fdes 0)))
|
||||
(dup2 input-fdes 0)
|
||||
;; it's possible input-fdes is error-fdes
|
||||
(if (not (= input-fdes error-fdes))
|
||||
(close-fdes input-fdes))))
|
||||
|
||||
(cond ((not (= output-fdes 1))
|
||||
(if (= error-fdes 1)
|
||||
(set! error-fdes (dup->fdes 1)))
|
||||
(dup2 output-fdes 1)
|
||||
;; it's possible output-fdes is error-fdes
|
||||
(if (not (= output-fdes error-fdes))
|
||||
(close-fdes output-fdes))))
|
||||
|
||||
(cond ((not (= error-fdes 2))
|
||||
(dup2 error-fdes 2)
|
||||
(close-fdes error-fdes)))
|
||||
|
||||
(apply execlp prog prog args)))
|
||||
|
||||
(else
|
||||
;; parent
|
||||
(if c2p (close-port (cdr c2p)))
|
||||
(if p2c (close-port (car p2c)))
|
||||
(cons (cond ((not writing) (car c2p))
|
||||
((not reading) (cdr p2c))
|
||||
(else (make-rw-port (car c2p)
|
||||
(cdr p2c))))
|
||||
pid))))))
|
||||
|
||||
(define (open-pipe* mode command . args)
|
||||
"Executes the program @var{command} with optional arguments
|
||||
@var{args} (all strings) in a subprocess.
|
||||
|
|
@ -213,3 +123,4 @@ information on how to interpret this value."
|
|||
(define (open-input-output-pipe command)
|
||||
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
|
||||
(open-pipe command OPEN_BOTH))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue