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