1
;; popen emulation, for non-stdio based ports.
3
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
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.
10
;;;; This library 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 GNU
13
;;;; Lesser General Public License for more details.
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20
(define-module (ice-9 popen)
21
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
22
open-output-pipe open-input-output-pipe))
24
(define (make-rw-port read-port write-port)
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)))
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))
38
;; a weak hash-table to store the process ids.
39
(define port/pid-table (make-weak-key-hash-table 31))
41
(define (ensure-fdes port mode)
42
(or (false-if-exception (fileno port))
43
(open-fdes *null-device* mode)))
45
;; run a process connected to an input, an output or an
47
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
48
;; returns port/pid pair.
49
(define (open-process mode prog . args)
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
57
(if c2p (setvbuf (cdr c2p) _IONBF))
58
(if p2c (setvbuf (cdr p2c) _IONBF))
59
(let ((pid (primitive-fork)))
64
;; select the three file descriptors to be used as
65
;; standard descriptors 0, 1, 2 for the new
66
;; process. They are pipes to/from the parent or taken
67
;; from the current Scheme input/output/error ports if
70
(let ((input-fdes (if writing
72
(ensure-fdes (current-input-port)
74
(output-fdes (if reading
76
(ensure-fdes (current-output-port)
78
(error-fdes (ensure-fdes (current-error-port)
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
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.
90
(port-for-each (lambda (pt-entry)
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))))))
98
;; Copy the three selected descriptors to the standard
99
;; descriptors 0, 1, 2, if not already there
101
(cond ((not (= input-fdes 0))
102
(if (= output-fdes 0)
103
(set! output-fdes (dup->fdes 0)))
105
(set! error-fdes (dup->fdes 0)))
107
;; it's possible input-fdes is error-fdes
108
(if (not (= input-fdes error-fdes))
109
(close-fdes input-fdes))))
111
(cond ((not (= output-fdes 1))
113
(set! error-fdes (dup->fdes 1)))
115
;; it's possible output-fdes is error-fdes
116
(if (not (= output-fdes error-fdes))
117
(close-fdes output-fdes))))
119
(cond ((not (= error-fdes 2))
121
(close-fdes error-fdes)))
123
(apply execlp prog prog args)))
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)
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))
143
(port (car port/pid)))
145
(hashq-set! port/pid-table port (cdr port/pid))
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))
156
(define (fetch-pid port)
157
(let ((pid (hashq-ref port/pid-table port)))
158
(hashq-remove! port/pid-table port)
161
(define (close-process port/pid)
162
(close-port (car port/pid))
163
(cdr (waitpid (cdr port/pid))))
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)
172
(close-port (car port/pid)))
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))))))
184
(define (close-pipe p)
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."
188
(let ((pid (fetch-pid p)))
190
(error "close-pipe: pipe not in table"))
191
(close-process (cons p pid))))
195
(let loop ((p (pipe-guardian)))
197
;; maybe removed already by close-pipe.
198
(let ((pid (fetch-pid p)))
200
(close-process-quietly (cons p pid))))
201
(loop (pipe-guardian)))))))
203
(add-hook! after-gc-hook reap-pipes)
205
(define (open-input-pipe command)
206
"Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
207
(open-pipe command OPEN_READ))
209
(define (open-output-pipe command)
210
"Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
211
(open-pipe command OPEN_WRITE))
213
(define (open-input-output-pipe command)
214
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
215
(open-pipe command OPEN_BOTH))
added
removed
ice-9/popen.scm
