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 | 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 | |
17 | ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
9a42b923 MV |
18 | ;;;; |
19 | ||
1a179b03 MD |
20 | (define-module (ice-9 popen) |
21 | :export (port/pid-table open-pipe close-pipe open-input-pipe | |
22 | open-output-pipe)) | |
51786bda JB |
23 | |
24 | ;; (define-module (guile popen) | |
25 | ;; :use-module (guile posix)) | |
26 | ||
27 | ;; a guardian to ensure the cleanup is done correctly when | |
28 | ;; an open pipe is gc'd or a close-port is used. | |
29 | (define pipe-guardian (make-guardian)) | |
30 | ||
31 | ;; a weak hash-table to store the process ids. | |
1a179b03 | 32 | (define port/pid-table (make-weak-key-hash-table 31)) |
51786bda | 33 | |
8ccc61e8 GH |
34 | (define (ensure-fdes port mode) |
35 | (or (false-if-exception (fileno port)) | |
36 | (open-fdes *null-device* mode))) | |
37 | ||
51786bda JB |
38 | ;; run a process connected to an input or output port. |
39 | ;; mode: OPEN_READ or OPEN_WRITE. | |
40 | ;; returns port/pid pair. | |
41 | (define (open-process mode prog . args) | |
42 | (let ((p (pipe)) | |
43 | (reading (string=? mode OPEN_READ))) | |
44 | (setvbuf (cdr p) _IONBF) | |
45 | (let ((pid (primitive-fork))) | |
46 | (cond ((= pid 0) | |
47 | ;; child | |
48 | (set-batch-mode?! #t) | |
8ccc61e8 GH |
49 | |
50 | ;; select the three file descriptors to be used as | |
51 | ;; standard descriptors 0, 1, 2 for the new process. one | |
52 | ;; is the pipe to the parent, the other two are taken | |
53 | ;; from the current Scheme input/output/error ports if | |
54 | ;; possible. | |
55 | ||
56 | (let ((input-fdes (if reading | |
57 | (ensure-fdes (current-input-port) | |
58 | O_RDONLY) | |
59 | (fileno (car p)))) | |
60 | (output-fdes (if reading | |
61 | (fileno (cdr p)) | |
62 | (ensure-fdes (current-output-port) | |
63 | O_WRONLY))) | |
64 | (error-fdes (ensure-fdes (current-error-port) | |
65 | O_WRONLY))) | |
66 | ||
67 | ;; close all file descriptors in ports inherited from | |
68 | ;; the parent except for the three selected above. | |
69 | ;; this is to avoid causing problems for other pipes in | |
70 | ;; the parent. | |
71 | ||
72 | ;; use low-level system calls, not close-port or the | |
73 | ;; scsh routines, to avoid side-effects such as | |
74 | ;; flushing port buffers or evicting ports. | |
75 | ||
76 | (port-for-each (lambda (pt-entry) | |
77 | (false-if-exception | |
78 | (let ((pt-fileno (fileno pt-entry))) | |
79 | (if (not (or (= pt-fileno input-fdes) | |
80 | (= pt-fileno output-fdes) | |
81 | (= pt-fileno error-fdes))) | |
82 | (close-fdes pt-fileno)))))) | |
83 | ||
84 | ;; copy the three selected descriptors to the standard | |
85 | ;; descriptors 0, 1, 2. note that it's possible that | |
86 | ;; output-fdes or input-fdes is equal to error-fdes. | |
87 | ||
88 | (cond ((not (= input-fdes 0)) | |
89 | (if (= output-fdes 0) | |
90 | (set! output-fdes (dup->fdes 0))) | |
91 | (if (= error-fdes 0) | |
92 | (set! error-fdes (dup->fdes 0))) | |
93 | (dup2 input-fdes 0))) | |
94 | ||
95 | (cond ((not (= output-fdes 1)) | |
96 | (if (= error-fdes 1) | |
97 | (set! error-fdes (dup->fdes 1))) | |
98 | (dup2 output-fdes 1))) | |
99 | ||
100 | (dup2 error-fdes 2) | |
101 | ||
102 | (apply execlp prog prog args))) | |
103 | ||
51786bda JB |
104 | (else |
105 | ;; parent | |
106 | (if reading | |
107 | (close-port (cdr p)) | |
108 | (close-port (car p))) | |
109 | (cons (if reading | |
110 | (car p) | |
111 | (cdr p)) | |
112 | pid)))))) | |
113 | ||
1a179b03 | 114 | (define (open-pipe command mode) |
ea4bcd7b GB |
115 | "Executes the shell command @var{command} (a string) in a subprocess. |
116 | A pipe to the process is created and returned. @var{modes} specifies | |
117 | whether an input or output pipe to the process is created: it should | |
118 | be the value of @code{OPEN_READ} or @code{OPEN_WRITE}." | |
51786bda JB |
119 | (let* ((port/pid (open-process mode "/bin/sh" "-c" command)) |
120 | (port (car port/pid))) | |
121 | (pipe-guardian port) | |
122 | (hashq-set! port/pid-table port (cdr port/pid)) | |
123 | port)) | |
124 | ||
125 | (define (fetch-pid port) | |
126 | (let ((pid (hashq-ref port/pid-table port))) | |
127 | (hashq-remove! port/pid-table port) | |
128 | pid)) | |
129 | ||
130 | (define (close-process port/pid) | |
131 | (close-port (car port/pid)) | |
132 | (cdr (waitpid (cdr port/pid)))) | |
133 | ||
2969637c GH |
134 | ;; for the background cleanup handler: just clean up without reporting |
135 | ;; errors. also avoids blocking the process: if the child isn't ready | |
136 | ;; to be collected, puts it back into the guardian's live list so it | |
137 | ;; can be tried again the next time the cleanup runs. | |
138 | (define (close-process-quietly port/pid) | |
139 | (catch 'system-error | |
140 | (lambda () | |
141 | (close-port (car port/pid))) | |
142 | (lambda args #f)) | |
143 | (catch 'system-error | |
144 | (lambda () | |
145 | (let ((pid/status (waitpid (cdr port/pid) WNOHANG))) | |
146 | (cond ((= (car pid/status) 0) | |
147 | ;; not ready for collection | |
148 | (pipe-guardian (car port/pid)) | |
149 | (hashq-set! port/pid-table | |
150 | (car port/pid) (cdr port/pid)))))) | |
151 | (lambda args #f))) | |
152 | ||
1a179b03 | 153 | (define (close-pipe p) |
ea4bcd7b GB |
154 | "Closes the pipe created by @code{open-pipe}, then waits for the process |
155 | to terminate and returns its status value, @xref{Processes, waitpid}, for | |
156 | information on how to interpret this value." | |
51786bda JB |
157 | (let ((pid (fetch-pid p))) |
158 | (if (not pid) | |
159 | (error "close-pipe: pipe not in table")) | |
160 | (close-process (cons p pid)))) | |
161 | ||
162 | (define reap-pipes | |
163 | (lambda () | |
164 | (let loop ((p (pipe-guardian))) | |
165 | (cond (p | |
166 | ;; maybe removed already by close-pipe. | |
167 | (let ((pid (fetch-pid p))) | |
168 | (if pid | |
2969637c | 169 | (close-process-quietly (cons p pid)))) |
51786bda JB |
170 | (loop (pipe-guardian))))))) |
171 | ||
ac373580 | 172 | (add-hook! after-gc-hook reap-pipes) |
51786bda | 173 | |
1a179b03 | 174 | (define (open-input-pipe command) |
a9c632a2 GH |
175 | "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" |
176 | (open-pipe command OPEN_READ)) | |
177 | ||
1a179b03 | 178 | (define (open-output-pipe command) |
a9c632a2 GH |
179 | "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" |
180 | (open-pipe command OPEN_WRITE)) |