summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-02-23 13:56:06 +0100
committerAndy Wingo <wingo@pobox.com>2012-02-23 13:56:54 +0100
commita2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (patch)
tree0beaa5f45bae966b92de39c02e9c4486b909e9fc
parent7ea70f355e986c79f2c999753642141a0e8985f7 (diff)
downloadguile-a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61.tar.gz
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.
-rw-r--r--libguile/posix.c208
-rw-r--r--module/ice-9/popen.scm101
2 files changed, 214 insertions, 95 deletions
diff --git a/libguile/posix.c b/libguile/posix.c
index 154d26ad9..4f8b8ac7a 100644
--- a/libguile/posix.c
+++ b/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);
}
/*
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index b9debd444..7ca486805 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -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))
+