1 ;; popen emulation, for non-stdio based ports.
3 ;;;; Copyright (C) 1998, 1999, 2000 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))
47 ;; (define-module (guile popen)
48 ;; :use-module (guile posix))
50 ;; a guardian to ensure the cleanup is done correctly when
51 ;; an open pipe is gc'd or a close-port is used.
52 (define pipe-guardian (make-guardian))
54 ;; a weak hash-table to store the process ids.
55 (define-public port/pid-table (make-weak-key-hash-table 31))
57 (define (ensure-fdes port mode)
58 (or (false-if-exception (fileno port))
59 (open-fdes *null-device* mode)))
61 ;; run a process connected to an input or output port.
62 ;; mode: OPEN_READ or OPEN_WRITE.
63 ;; returns port/pid pair.
64 (define (open-process mode prog . args)
66 (reading (string=? mode OPEN_READ)))
67 (setvbuf (cdr p) _IONBF)
68 (let ((pid (primitive-fork)))
73 ;; select the three file descriptors to be used as
74 ;; standard descriptors 0, 1, 2 for the new process. one
75 ;; is the pipe to the parent, the other two are taken
76 ;; from the current Scheme input/output/error ports if
79 (let ((input-fdes (if reading
80 (ensure-fdes (current-input-port)
83 (output-fdes (if reading
85 (ensure-fdes (current-output-port)
87 (error-fdes (ensure-fdes (current-error-port)
90 ;; close all file descriptors in ports inherited from
91 ;; the parent except for the three selected above.
92 ;; this is to avoid causing problems for other pipes in
95 ;; use low-level system calls, not close-port or the
96 ;; scsh routines, to avoid side-effects such as
97 ;; flushing port buffers or evicting ports.
99 (port-for-each (lambda (pt-entry)
101 (let ((pt-fileno (fileno pt-entry)))
102 (if (not (or (= pt-fileno input-fdes)
103 (= pt-fileno output-fdes)
104 (= pt-fileno error-fdes)))
105 (close-fdes pt-fileno))))))
107 ;; copy the three selected descriptors to the standard
108 ;; descriptors 0, 1, 2. note that it's possible that
109 ;; output-fdes or input-fdes is equal to error-fdes.
111 (cond ((not (= input-fdes 0))
112 (if (= output-fdes 0)
113 (set! output-fdes (dup->fdes 0)))
115 (set! error-fdes (dup->fdes 0)))
116 (dup2 input-fdes 0)))
118 (cond ((not (= output-fdes 1))
120 (set! error-fdes (dup->fdes 1)))
121 (dup2 output-fdes 1)))
125 (apply execlp prog prog args)))
131 (close-port (car p)))
137 (define-public (open-pipe command mode)
138 "Executes the shell command @var{command} (a string) in a subprocess.
139 A pipe to the process is created and returned. @var{modes} specifies
140 whether an input or output pipe to the process is created: it should
141 be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
142 (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
143 (port (car port/pid)))
145 (hashq-set! port/pid-table port (cdr port/pid))
148 (define (fetch-pid port)
149 (let ((pid (hashq-ref port/pid-table port)))
150 (hashq-remove! port/pid-table port)
153 (define (close-process port/pid)
154 (close-port (car port/pid))
155 (cdr (waitpid (cdr port/pid))))
157 ;; for the background cleanup handler: just clean up without reporting
158 ;; errors. also avoids blocking the process: if the child isn't ready
159 ;; to be collected, puts it back into the guardian's live list so it
160 ;; can be tried again the next time the cleanup runs.
161 (define (close-process-quietly port/pid)
164 (close-port (car port/pid)))
168 (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
169 (cond ((= (car pid/status) 0)
170 ;; not ready for collection
171 (pipe-guardian (car port/pid))
172 (hashq-set! port/pid-table
173 (car port/pid) (cdr port/pid))))))
176 (define-public (close-pipe p)
177 "Closes the pipe created by @code{open-pipe}, then waits for the process
178 to terminate and returns its status value, @xref{Processes, waitpid}, for
179 information on how to interpret this value."
180 (let ((pid (fetch-pid p)))
182 (error "close-pipe: pipe not in table"))
183 (close-process (cons p pid))))
187 (let loop ((p (pipe-guardian)))
189 ;; maybe removed already by close-pipe.
190 (let ((pid (fetch-pid p)))
192 (close-process-quietly (cons p pid))))
193 (loop (pipe-guardian)))))))
195 (add-hook! after-gc-hook reap-pipes)
197 (define-public (open-input-pipe command)
198 "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
199 (open-pipe command OPEN_READ))
201 (define-public (open-output-pipe command)
202 "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
203 (open-pipe command OPEN_WRITE))