ice-9/popen.scm

   1 ;; popen emulation, for non-stdio based ports.
   2
   3 ;;;; Copyright (C) 1998, 1999, 2000 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., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20
  21 (define-module (ice-9 popen))
  22
  23 ;;    (define-module (guile popen)
  24 ;;      :use-module (guile posix))
  25
  26 ;; a guardian to ensure the cleanup is done correctly when
  27 ;; an open pipe is gc'd or a close-port is used.
  28 (define pipe-guardian (make-guardian))
  29
  30 ;; a weak hash-table to store the process ids.
  31 (define-public port/pid-table (make-weak-key-hash-table 31))
  32
  33 (define (ensure-fdes port mode)
  34   (or (false-if-exception (fileno port))
  35       (open-fdes *null-device* mode)))
  36
  37 ;; run a process connected to an input or output port.
  38 ;; mode: OPEN_READ or OPEN_WRITE.
  39 ;; returns port/pid pair.
  40 (define (open-process mode prog . args)
  41   (let ((p (pipe))
  42         (reading (string=? mode OPEN_READ)))
  43     (setvbuf (cdr p) _IONBF)
  44     (let ((pid (primitive-fork)))
  45       (cond ((= pid 0)
  46              ;; child
  47              (set-batch-mode?! #t)
  48
  49              ;; select the three file descriptors to be used as
  50              ;; standard descriptors 0, 1, 2 for the new process.  one
  51              ;; is the pipe to the parent, the other two are taken
  52              ;; from the current Scheme input/output/error ports if
  53              ;; possible.
  54
  55              (let ((input-fdes (if reading
  56                                    (ensure-fdes (current-input-port)
  57                                                 O_RDONLY)
  58                                    (fileno (car p))))
  59                    (output-fdes (if reading
  60                                     (fileno (cdr p))
  61                                     (ensure-fdes (current-output-port)
  62                                                  O_WRONLY)))
  63                    (error-fdes (ensure-fdes (current-error-port)
  64                                             O_WRONLY)))
  65
  66                ;; close all file descriptors in ports inherited from
  67                ;; the parent except for the three selected above.
  68                ;; this is to avoid causing problems for other pipes in
  69                ;; the parent.
  70
  71                ;; use low-level system calls, not close-port or the
  72                ;; scsh routines, to avoid side-effects such as
  73                ;; flushing port buffers or evicting ports.
  74
  75                (port-for-each (lambda (pt-entry)
  76                                 (false-if-exception
  77                                  (let ((pt-fileno (fileno pt-entry)))
  78                                    (if (not (or (= pt-fileno input-fdes)
  79                                                 (= pt-fileno output-fdes)
  80                                                 (= pt-fileno error-fdes)))
  81                                        (close-fdes pt-fileno))))))
  82
  83                ;; copy the three selected descriptors to the standard
  84                ;; descriptors 0, 1, 2.  note that it's possible that
  85                ;; output-fdes or input-fdes is equal to error-fdes.
  86
  87                (cond ((not (= input-fdes 0))
  88                       (if (= output-fdes 0)
  89                           (set! output-fdes (dup->fdes 0)))
  90                       (if (= error-fdes 0)
  91                           (set! error-fdes (dup->fdes 0)))
  92                       (dup2 input-fdes 0)))
  93
  94                (cond ((not (= output-fdes 1))
  95                       (if (= error-fdes 1)
  96                           (set! error-fdes (dup->fdes 1)))
  97                       (dup2 output-fdes 1)))
  98
  99                (dup2 error-fdes 2)
 100
 101                (apply execlp prog prog args)))
 102
 103             (else
 104              ;; parent
 105              (if reading
 106                  (close-port (cdr p))
 107                  (close-port (car p)))
 108              (cons (if reading
 109                        (car p)
 110                        (cdr p))
 111                    pid))))))
 112
 113 (define-public (open-pipe command mode)
 114   "Executes the shell command @var{command} (a string) in a subprocess.
 115 A pipe to the process is created and returned.  @var{modes} specifies
 116 whether an input or output pipe to the process is created: it should
 117 be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
 118   (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
 119          (port (car port/pid)))
 120     (pipe-guardian port)
 121     (hashq-set! port/pid-table port (cdr port/pid))
 122     port))
 123
 124 (define (fetch-pid port)
 125   (let ((pid (hashq-ref port/pid-table port)))
 126     (hashq-remove! port/pid-table port)
 127     pid))
 128
 129 (define (close-process port/pid)
 130   (close-port (car port/pid))
 131   (cdr (waitpid (cdr port/pid))))
 132
 133 ;; for the background cleanup handler: just clean up without reporting
 134 ;; errors.  also avoids blocking the process: if the child isn't ready
 135 ;; to be collected, puts it back into the guardian's live list so it
 136 ;; can be tried again the next time the cleanup runs.
 137 (define (close-process-quietly port/pid)
 138   (catch 'system-error
 139          (lambda ()
 140            (close-port (car port/pid)))
 141          (lambda args #f))
 142   (catch 'system-error
 143          (lambda ()
 144            (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
 145              (cond ((= (car pid/status) 0)
 146                     ;; not ready for collection
 147                     (pipe-guardian (car port/pid))
 148                     (hashq-set! port/pid-table
 149                                 (car port/pid) (cdr port/pid))))))
 150          (lambda args #f)))
 151
 152 (define-public (close-pipe p)
 153   "Closes the pipe created by @code{open-pipe}, then waits for the process
 154 to terminate and returns its status value, @xref{Processes, waitpid}, for
 155 information on how to interpret this value."
 156   (let ((pid (fetch-pid p)))
 157     (if (not pid)
 158         (error "close-pipe: pipe not in table"))
 159     (close-process (cons p pid))))
 160
 161 (define reap-pipes
 162   (lambda ()
 163     (let loop ((p (pipe-guardian)))
 164       (cond (p
 165              ;; maybe removed already by close-pipe.
 166              (let ((pid (fetch-pid p)))
 167                (if pid
 168                    (close-process-quietly (cons p pid))))
 169              (loop (pipe-guardian)))))))
 170
 171 (add-hook! after-gc-hook reap-pipes)
 172
 173 (define-public (open-input-pipe command)
 174   "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
 175   (open-pipe command OPEN_READ))
 176
 177 (define-public (open-output-pipe command)
 178   "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
 179   (open-pipe command OPEN_WRITE))