[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-59-ga2e946f

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61

The branch, stable-2.0 has been updated
       via  a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (commit)
      from  7ea70f355e986c79f2c999753642141a0e8985f7 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 libguile/posix.c       |  208 ++++++++++++++++++++++++++++++++++++++++++++++++
 module/ice-9/popen.scm |  101 ++----------------------
 2 files changed, 214 insertions(+), 95 deletions(-)

diff --git a/libguile/posix.c b/libguile/posix.c
index 154d26a..4f8b8ac 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 b9debd4..7ca4868 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))
+


hooks/post-receive
-- 
GNU Guile