Commit | Line | Data |
---|---|---|
51786bda JB |
1 | ;; popen emulation, for non-stdio based ports. |
2 | ||
1a179b03 | 3 | ;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. |
9a42b923 MV |
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 | |
a482f2cc MV |
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. | |
9a42b923 MV |
43 | ;;;; |
44 | ||
1a179b03 MD |
45 | (define-module (ice-9 popen) |
46 | :export (port/pid-table open-pipe close-pipe open-input-pipe | |
47 | open-output-pipe)) | |
51786bda JB |
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. | |
1a179b03 | 57 | (define port/pid-table (make-weak-key-hash-table 31)) |
51786bda | 58 | |
8ccc61e8 GH |
59 | (define (ensure-fdes port mode) |
60 | (or (false-if-exception (fileno port)) | |
61 | (open-fdes *null-device* mode))) | |
62 | ||
51786bda JB |
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) | |
8ccc61e8 GH |
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. note that it's possible that | |
111 | ;; output-fdes or input-fdes is equal to error-fdes. | |
112 | ||
113 | (cond ((not (= input-fdes 0)) | |
114 | (if (= output-fdes 0) | |
115 | (set! output-fdes (dup->fdes 0))) | |
116 | (if (= error-fdes 0) | |
117 | (set! error-fdes (dup->fdes 0))) | |
118 | (dup2 input-fdes 0))) | |
119 | ||
120 | (cond ((not (= output-fdes 1)) | |
121 | (if (= error-fdes 1) | |
122 | (set! error-fdes (dup->fdes 1))) | |
123 | (dup2 output-fdes 1))) | |
124 | ||
125 | (dup2 error-fdes 2) | |
126 | ||
127 | (apply execlp prog prog args))) | |
128 | ||
51786bda JB |
129 | (else |
130 | ;; parent | |
131 | (if reading | |
132 | (close-port (cdr p)) | |
133 | (close-port (car p))) | |
134 | (cons (if reading | |
135 | (car p) | |
136 | (cdr p)) | |
137 | pid)))))) | |
138 | ||
1a179b03 | 139 | (define (open-pipe command mode) |
ea4bcd7b GB |
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}." | |
51786bda JB |
144 | (let* ((port/pid (open-process mode "/bin/sh" "-c" command)) |
145 | (port (car port/pid))) | |
146 | (pipe-guardian port) | |
147 | (hashq-set! port/pid-table port (cdr port/pid)) | |
148 | port)) | |
149 | ||
150 | (define (fetch-pid port) | |
151 | (let ((pid (hashq-ref port/pid-table port))) | |
152 | (hashq-remove! port/pid-table port) | |
153 | pid)) | |
154 | ||
155 | (define (close-process port/pid) | |
156 | (close-port (car port/pid)) | |
157 | (cdr (waitpid (cdr port/pid)))) | |
158 | ||
2969637c GH |
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) | |
164 | (catch 'system-error | |
165 | (lambda () | |
166 | (close-port (car port/pid))) | |
167 | (lambda args #f)) | |
168 | (catch 'system-error | |
169 | (lambda () | |
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)))))) | |
176 | (lambda args #f))) | |
177 | ||
1a179b03 | 178 | (define (close-pipe p) |
ea4bcd7b GB |
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." | |
51786bda JB |
182 | (let ((pid (fetch-pid p))) |
183 | (if (not pid) | |
184 | (error "close-pipe: pipe not in table")) | |
185 | (close-process (cons p pid)))) | |
186 | ||
187 | (define reap-pipes | |
188 | (lambda () | |
189 | (let loop ((p (pipe-guardian))) | |
190 | (cond (p | |
191 | ;; maybe removed already by close-pipe. | |
192 | (let ((pid (fetch-pid p))) | |
193 | (if pid | |
2969637c | 194 | (close-process-quietly (cons p pid)))) |
51786bda JB |
195 | (loop (pipe-guardian))))))) |
196 | ||
ac373580 | 197 | (add-hook! after-gc-hook reap-pipes) |
51786bda | 198 | |
1a179b03 | 199 | (define (open-input-pipe command) |
a9c632a2 GH |
200 | "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" |
201 | (open-pipe command OPEN_READ)) | |
202 | ||
1a179b03 | 203 | (define (open-output-pipe command) |
a9c632a2 GH |
204 | "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" |
205 | (open-pipe command OPEN_WRITE)) |