diff options
author | Andy Wingo <wingo@pobox.com> | 2012-02-23 13:56:06 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-02-23 13:56:54 +0100 |
commit | a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (patch) | |
tree | 0beaa5f45bae966b92de39c02e9c4486b909e9fc | |
parent | 7ea70f355e986c79f2c999753642141a0e8985f7 (diff) | |
download | guile-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.c | 208 | ||||
-rw-r--r-- | module/ice-9/popen.scm | 101 |
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)) + |