home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / popen.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.4 KB  |  216 lines
  1. ;; popen emulation, for non-stdio based ports.
  2.  
  3. ;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 2.1 of the License, or (at your option) any later version.
  9. ;;;; 
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. ;;;; 
  19.  
  20. (define-module (ice-9 popen)
  21.   :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
  22.        open-output-pipe open-input-output-pipe))
  23.  
  24. (define (make-rw-port read-port write-port)
  25.   (make-soft-port
  26.    (vector
  27.     (lambda (c) (write-char c write-port))
  28.     (lambda (s) (display s write-port))
  29.     (lambda () (force-output write-port))
  30.     (lambda () (read-char read-port))
  31.     (lambda () (close-port read-port) (close-port write-port)))
  32.    "r+"))
  33.  
  34. ;; a guardian to ensure the cleanup is done correctly when
  35. ;; an open pipe is gc'd or a close-port is used.
  36. (define pipe-guardian (make-guardian))
  37.  
  38. ;; a weak hash-table to store the process ids.
  39. (define port/pid-table (make-weak-key-hash-table 31))
  40.  
  41. (define (ensure-fdes port mode)
  42.   (or (false-if-exception (fileno port))
  43.       (open-fdes *null-device* mode)))
  44.  
  45. ;; run a process connected to an input, an output or an
  46. ;; input/output port
  47. ;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
  48. ;; returns port/pid pair.
  49. (define (open-process mode prog . args)
  50.   (let* ((reading (or (equal? mode OPEN_READ)
  51.               (equal? mode OPEN_BOTH)))
  52.      (writing (or (equal? mode OPEN_WRITE)
  53.               (equal? mode OPEN_BOTH)))
  54.      (c2p (if reading (pipe) #f))  ; child to parent
  55.      (p2c (if writing (pipe) #f))) ; parent to child
  56.     
  57.     (if c2p (setvbuf (cdr c2p) _IONBF))
  58.     (if p2c (setvbuf (cdr p2c) _IONBF))
  59.     (let ((pid (primitive-fork)))
  60.       (cond ((= pid 0)
  61.          ;; child
  62.          (set-batch-mode?! #t)
  63.  
  64.          ;; select the three file descriptors to be used as
  65.          ;; standard descriptors 0, 1, 2 for the new
  66.          ;; process. They are pipes to/from the parent or taken
  67.          ;; from the current Scheme input/output/error ports if
  68.          ;; possible.
  69.  
  70.          (let ((input-fdes (if writing
  71.                    (fileno (car p2c))
  72.                    (ensure-fdes (current-input-port)
  73.                         O_RDONLY)))
  74.            (output-fdes (if reading
  75.                     (fileno (cdr c2p))
  76.                     (ensure-fdes (current-output-port)
  77.                          O_WRONLY)))
  78.            (error-fdes (ensure-fdes (current-error-port)
  79.                         O_WRONLY)))
  80.  
  81.            ;; close all file descriptors in ports inherited from
  82.            ;; the parent except for the three selected above.
  83.            ;; this is to avoid causing problems for other pipes in
  84.            ;; the parent.
  85.  
  86.            ;; use low-level system calls, not close-port or the
  87.            ;; scsh routines, to avoid side-effects such as
  88.            ;; flushing port buffers or evicting ports.
  89.  
  90.            (port-for-each (lambda (pt-entry)
  91.                 (false-if-exception
  92.                  (let ((pt-fileno (fileno pt-entry)))
  93.                    (if (not (or (= pt-fileno input-fdes)
  94.                         (= pt-fileno output-fdes)
  95.                         (= pt-fileno error-fdes)))
  96.                        (close-fdes pt-fileno))))))
  97.  
  98.            ;; Copy the three selected descriptors to the standard
  99.            ;; descriptors 0, 1, 2, if not already there
  100.  
  101.            (cond ((not (= input-fdes 0))
  102.               (if (= output-fdes 0)
  103.               (set! output-fdes (dup->fdes 0)))
  104.               (if (= error-fdes 0)
  105.               (set! error-fdes (dup->fdes 0)))
  106.               (dup2 input-fdes 0)
  107.               ;; it's possible input-fdes is error-fdes
  108.               (if (not (= input-fdes error-fdes))
  109.               (close-fdes input-fdes))))
  110.            
  111.            (cond ((not (= output-fdes 1))
  112.               (if (= error-fdes 1)
  113.               (set! error-fdes (dup->fdes 1)))
  114.               (dup2 output-fdes 1)
  115.               ;; it's possible output-fdes is error-fdes
  116.               (if (not (= output-fdes error-fdes))
  117.               (close-fdes output-fdes))))
  118.  
  119.            (cond ((not (= error-fdes 2))
  120.               (dup2 error-fdes 2)
  121.               (close-fdes error-fdes)))
  122.              
  123.            (apply execlp prog prog args)))
  124.  
  125.         (else
  126.          ;; parent
  127.          (if c2p (close-port (cdr c2p)))
  128.          (if p2c (close-port (car p2c)))
  129.          (cons (cond ((not writing) (car c2p))
  130.              ((not reading) (cdr p2c))
  131.              (else (make-rw-port (car c2p)
  132.                          (cdr p2c))))
  133.            pid))))))
  134.  
  135. (define (open-pipe* mode command . args)
  136.   "Executes the program @var{command} with optional arguments
  137. @var{args} (all strings) in a subprocess.
  138. A port to the process (based on pipes) is created and returned.
  139. @var{modes} specifies whether an input, an output or an input-output
  140. port to the process is created: it should be the value of
  141. @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
  142.   (let* ((port/pid (apply open-process mode command args))
  143.      (port (car port/pid)))
  144.     (pipe-guardian port)
  145.     (hashq-set! port/pid-table port (cdr port/pid))
  146.     port))
  147.  
  148. (define (open-pipe command mode)
  149.   "Executes the shell command @var{command} (a string) in a subprocess.
  150. A port to the process (based on pipes) is created and returned.
  151. @var{modes} specifies whether an input, an output or an input-output
  152. port to the process is created: it should be the value of
  153. @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
  154.   (open-pipe* mode "/bin/sh" "-c" command))
  155.  
  156. (define (fetch-pid port)
  157.   (let ((pid (hashq-ref port/pid-table port)))
  158.     (hashq-remove! port/pid-table port)
  159.     pid))
  160.  
  161. (define (close-process port/pid)
  162.   (close-port (car port/pid))
  163.   (cdr (waitpid (cdr port/pid))))
  164.  
  165. ;; for the background cleanup handler: just clean up without reporting
  166. ;; errors.  also avoids blocking the process: if the child isn't ready
  167. ;; to be collected, puts it back into the guardian's live list so it
  168. ;; can be tried again the next time the cleanup runs.
  169. (define (close-process-quietly port/pid)
  170.   (catch 'system-error
  171.      (lambda ()
  172.        (close-port (car port/pid)))
  173.      (lambda args #f))
  174.   (catch 'system-error
  175.      (lambda ()
  176.        (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
  177.          (cond ((= (car pid/status) 0)
  178.             ;; not ready for collection
  179.             (pipe-guardian (car port/pid))
  180.             (hashq-set! port/pid-table
  181.                 (car port/pid) (cdr port/pid))))))
  182.      (lambda args #f)))
  183.  
  184. (define (close-pipe p)
  185.   "Closes the pipe created by @code{open-pipe}, then waits for the process
  186. to terminate and returns its status value, @xref{Processes, waitpid}, for
  187. information on how to interpret this value."
  188.   (let ((pid (fetch-pid p)))
  189.     (if (not pid)
  190.         (error "close-pipe: pipe not in table"))
  191.     (close-process (cons p pid))))
  192.  
  193. (define reap-pipes
  194.   (lambda ()
  195.     (let loop ((p (pipe-guardian)))
  196.       (cond (p 
  197.          ;; maybe removed already by close-pipe.
  198.          (let ((pid (fetch-pid p)))
  199.            (if pid
  200.            (close-process-quietly (cons p pid))))
  201.          (loop (pipe-guardian)))))))
  202.  
  203. (add-hook! after-gc-hook reap-pipes)
  204.  
  205. (define (open-input-pipe command)
  206.   "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
  207.   (open-pipe command OPEN_READ))
  208.  
  209. (define (open-output-pipe command)
  210.   "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
  211.   (open-pipe command OPEN_WRITE))
  212.  
  213. (define (open-input-output-pipe command)
  214.   "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
  215.   (open-pipe command OPEN_BOTH))
  216.