guile18/ice-9/popen.scm

   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))