Commit | Line | Data |
---|---|---|
51786bda JB |
1 | ;; popen emulation, for non-stdio based ports. |
2 | ||
cd5fea8d | 3 | ;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. |
9a42b923 | 4 | ;;;; |
73be1d9e MV |
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. | |
9a42b923 | 9 | ;;;; |
73be1d9e | 10 | ;;;; This library is distributed in the hope that it will be useful, |
9a42b923 | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
9a42b923 | 14 | ;;;; |
73be1d9e MV |
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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
9a42b923 MV |
18 | ;;;; |
19 | ||
1a179b03 | 20 | (define-module (ice-9 popen) |
0f3eb627 MV |
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+")) | |
51786bda JB |
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. | |
1a179b03 | 39 | (define port/pid-table (make-weak-key-hash-table 31)) |
51786bda | 40 | |
8ccc61e8 GH |
41 | (define (ensure-fdes port mode) |
42 | (or (false-if-exception (fileno port)) | |
43 | (open-fdes *null-device* mode))) | |
44 | ||
0f3eb627 MV |
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 | |
51786bda JB |
48 | ;; returns port/pid pair. |
49 | (define (open-process mode prog . args) | |
0f3eb627 MV |
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)) | |
51786bda JB |
59 | (let ((pid (primitive-fork))) |
60 | (cond ((= pid 0) | |
61 | ;; child | |
62 | (set-batch-mode?! #t) | |
8ccc61e8 GH |
63 | |
64 | ;; select the three file descriptors to be used as | |
0f3eb627 MV |
65 | ;; standard descriptors 0, 1, 2 for the new |
66 | ;; process. They are pipes to/from the parent or taken | |
8ccc61e8 GH |
67 | ;; from the current Scheme input/output/error ports if |
68 | ;; possible. | |
69 | ||
0f3eb627 MV |
70 | (let ((input-fdes (if writing |
71 | (fileno (car p2c)) | |
8ccc61e8 | 72 | (ensure-fdes (current-input-port) |
0f3eb627 | 73 | O_RDONLY))) |
8ccc61e8 | 74 | (output-fdes (if reading |
0f3eb627 | 75 | (fileno (cdr c2p)) |
8ccc61e8 GH |
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 | ||
a118e0eb KR |
98 | ;; Copy the three selected descriptors to the standard |
99 | ;; descriptors 0, 1, 2, if not already there | |
8ccc61e8 GH |
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))) | |
88a63bfc | 106 | (dup2 input-fdes 0) |
a118e0eb KR |
107 | ;; it's possible input-fdes is error-fdes |
108 | (if (not (= input-fdes error-fdes)) | |
109 | (close-fdes input-fdes)))) | |
110 | ||
8ccc61e8 GH |
111 | (cond ((not (= output-fdes 1)) |
112 | (if (= error-fdes 1) | |
113 | (set! error-fdes (dup->fdes 1))) | |
88a63bfc | 114 | (dup2 output-fdes 1) |
a118e0eb KR |
115 | ;; it's possible output-fdes is error-fdes |
116 | (if (not (= output-fdes error-fdes)) | |
117 | (close-fdes output-fdes)))) | |
8ccc61e8 | 118 | |
88a63bfc KR |
119 | (cond ((not (= error-fdes 2)) |
120 | (dup2 error-fdes 2) | |
121 | (close-fdes error-fdes))) | |
8ccc61e8 GH |
122 | |
123 | (apply execlp prog prog args))) | |
124 | ||
51786bda JB |
125 | (else |
126 | ;; parent | |
0f3eb627 MV |
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)))) | |
51786bda JB |
133 | pid)))))) |
134 | ||
0f3eb627 MV |
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)) | |
51786bda JB |
143 | (port (car port/pid))) |
144 | (pipe-guardian port) | |
145 | (hashq-set! port/pid-table port (cdr port/pid)) | |
146 | port)) | |
147 | ||
0f3eb627 MV |
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 | ||
51786bda JB |
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 | ||
2969637c GH |
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 | ||
1a179b03 | 184 | (define (close-pipe p) |
ea4bcd7b GB |
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." | |
51786bda JB |
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 | |
2969637c | 200 | (close-process-quietly (cons p pid)))) |
51786bda JB |
201 | (loop (pipe-guardian))))))) |
202 | ||
ac373580 | 203 | (add-hook! after-gc-hook reap-pipes) |
51786bda | 204 | |
1a179b03 | 205 | (define (open-input-pipe command) |
a9c632a2 GH |
206 | "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" |
207 | (open-pipe command OPEN_READ)) | |
208 | ||
1a179b03 | 209 | (define (open-output-pipe command) |
a9c632a2 GH |
210 | "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" |
211 | (open-pipe command OPEN_WRITE)) | |
0f3eb627 MV |
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)) |