1 ;; popen emulation, for non-stdio based ports.
3 ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
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.
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.
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
20 ;;;; As a special exception, the Free Software Foundation gives permission
21 ;;;; for additional uses of the text contained in its release of GUILE.
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.
29 ;;;; This exception does not however invalidate any other reasons why
30 ;;;; the executable file might be covered by the GNU General Public License.
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.
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.
45 (define-module (ice-9 popen)
46 :export (port/pid-table open-pipe close-pipe open-input-pipe
49 ;; (define-module (guile popen)
50 ;; :use-module (guile posix))
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))
56 ;; a weak hash-table to store the process ids.
57 (define port/pid-table (make-weak-key-hash-table 31))
59 (define (ensure-fdes port mode)
60 (or (false-if-exception (fileno port))
61 (open-fdes *null-device* mode)))
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)
68 (reading (string=? mode OPEN_READ)))
69 (setvbuf (cdr p) _IONBF)
70 (let ((pid (primitive-fork)))
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
81 (let ((input-fdes (if reading
82 (ensure-fdes (current-input-port)
85 (output-fdes (if reading
87 (ensure-fdes (current-output-port)
89 (error-fdes (ensure-fdes (current-error-port)
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
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.
101 (port-for-each (lambda (pt-entry)
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))))))
109 ;; copy the three selected descriptors to the standard
110 ;; descriptors 0, 1, 2. note that it's possible that
111 ;; output-fdes or input-fdes is equal to error-fdes.
113 (cond ((not (= input-fdes 0))
114 (if (= output-fdes 0)
115 (set! output-fdes (dup->fdes 0)))
117 (set! error-fdes (dup->fdes 0)))
118 (dup2 input-fdes 0)))
120 (cond ((not (= output-fdes 1))
122 (set! error-fdes (dup->fdes 1)))
123 (dup2 output-fdes 1)))
127 (apply execlp prog prog args)))
133 (close-port (car p)))
139 (define (open-pipe command mode)
140 "Executes the shell command @var{command} (a string) in a subprocess.
141 A pipe to the process is created and returned. @var{modes} specifies
142 whether an input or output pipe to the process is created: it should
143 be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
144 (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
145 (port (car port/pid)))
147 (hashq-set! port/pid-table port (cdr port/pid))
150 (define (fetch-pid port)
151 (let ((pid (hashq-ref port/pid-table port)))
152 (hashq-remove! port/pid-table port)
155 (define (close-process port/pid)
156 (close-port (car port/pid))
157 (cdr (waitpid (cdr port/pid))))
159 ;; for the background cleanup handler: just clean up without reporting
160 ;; errors. also avoids blocking the process: if the child isn't ready
161 ;; to be collected, puts it back into the guardian's live list so it
162 ;; can be tried again the next time the cleanup runs.
163 (define (close-process-quietly port/pid)
166 (close-port (car port/pid)))
170 (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
171 (cond ((= (car pid/status) 0)
172 ;; not ready for collection
173 (pipe-guardian (car port/pid))
174 (hashq-set! port/pid-table
175 (car port/pid) (cdr port/pid))))))
178 (define (close-pipe p)
179 "Closes the pipe created by @code{open-pipe}, then waits for the process
180 to terminate and returns its status value, @xref{Processes, waitpid}, for
181 information on how to interpret this value."
182 (let ((pid (fetch-pid p)))
184 (error "close-pipe: pipe not in table"))
185 (close-process (cons p pid))))
189 (let loop ((p (pipe-guardian)))
191 ;; maybe removed already by close-pipe.
192 (let ((pid (fetch-pid p)))
194 (close-process-quietly (cons p pid))))
195 (loop (pipe-guardian)))))))
197 (add-hook! after-gc-hook reap-pipes)
199 (define (open-input-pipe command)
200 "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
201 (open-pipe command OPEN_READ))
203 (define (open-output-pipe command)
204 "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
205 (open-pipe command OPEN_WRITE))