Commit | Line | Data |
---|---|---|
3e690887 KR |
1 | ;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- |
2 | ;;;; | |
df3d365a | 3 | ;;;; Copyright 2003, 2006, 2010, 2011, 2013 Free Software Foundation, Inc. |
3e690887 KR |
4 | ;;;; |
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 | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
df3d365a | 9 | ;;;; |
3e690887 KR |
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. | |
df3d365a | 14 | ;;;; |
3e690887 KR |
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 |
3e690887 KR |
18 | |
19 | (define-module (test-suite test-ice-9-popen) | |
df3d365a | 20 | #:use-module (test-suite lib)) |
3e690887 KR |
21 | |
22 | ;; read from PORT until eof is reached, return what's read as a string | |
23 | (define (read-string-to-eof port) | |
24 | (do ((lst '() (cons c lst)) | |
25 | (c (read-char port) (read-char port))) | |
26 | ((eof-object? c) | |
27 | (list->string (reverse! lst))))) | |
28 | ||
29 | ;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is | |
30 | ;; generated rather than a SIGPIPE signal | |
31 | (define (with-epipe thunk) | |
32 | (dynamic-wind | |
33 | (lambda () | |
34 | (sigaction SIGPIPE SIG_IGN)) | |
35 | thunk | |
36 | restore-signals)) | |
37 | ||
df3d365a LC |
38 | (define-syntax-rule (if-supported body ...) |
39 | (if (provided? 'fork) | |
40 | (begin body ...))) | |
41 | ||
42 | (if-supported | |
43 | (use-modules (ice-9 popen)) | |
44 | ||
45 | ||
46 | ;; | |
47 | ;; open-input-pipe | |
48 | ;; | |
49 | ||
50 | (with-test-prefix "open-input-pipe" | |
51 | ||
52 | (pass-if-exception "no args" exception:wrong-num-args | |
53 | (open-input-pipe)) | |
54 | ||
55 | (pass-if "port?" | |
56 | (port? (open-input-pipe "echo hello"))) | |
57 | ||
58 | (pass-if "echo hello" | |
59 | (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello")))) | |
60 | ||
61 | ;; exercise file descriptor setups when stdin is the same as stderr | |
62 | (pass-if "stdin==stderr" | |
63 | (let ((port (open-file "/dev/null" "r+"))) | |
64 | (with-input-from-port port | |
65 | (lambda () | |
66 | (with-error-to-port port | |
67 | (lambda () | |
68 | (open-input-pipe "echo hello")))))) | |
69 | #t) | |
70 | ||
71 | ;; exercise file descriptor setups when stdout is the same as stderr | |
72 | (pass-if "stdout==stderr" | |
73 | (let ((port (open-file "/dev/null" "r+"))) | |
74 | (with-output-to-port port | |
75 | (lambda () | |
76 | (with-error-to-port port | |
77 | (lambda () | |
78 | (open-input-pipe "echo hello")))))) | |
79 | #t) | |
80 | ||
81 | (pass-if "open-input-pipe process gets (current-input-port) as stdin" | |
82 | (let* ((p2c (pipe)) | |
83 | (port (with-input-from-port (car p2c) | |
84 | (lambda () | |
85 | (open-input-pipe "read line && echo $line"))))) | |
86 | (display "hello\n" (cdr p2c)) | |
87 | (force-output (cdr p2c)) | |
88 | (let ((result (eq? (read port) 'hello))) | |
89 | (close-port (cdr p2c)) | |
90 | (close-pipe port) | |
91 | result))) | |
92 | ||
93 | ;; After the child closes stdout (which it indicates here by writing | |
94 | ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 | |
95 | ;; and earlier a duplicate of stdout existed in the child, meaning | |
96 | ;; eof was not seen. | |
97 | ;; | |
98 | ;; Note that the objective here is to test that the parent sees EOF | |
99 | ;; while the child is still alive. (It is obvious that the parent | |
100 | ;; must see EOF once the child has died.) The use of the `p2c' | |
101 | ;; pipe, and `echo closed' and `read' in the child, allows us to be | |
102 | ;; sure that we are testing what the parent sees at a point where | |
103 | ;; the child has closed stdout but is still alive. | |
104 | (pass-if "no duplicate" | |
105 | (let* ((c2p (pipe)) | |
106 | (p2c (pipe)) | |
107 | (port (with-error-to-port (cdr c2p) | |
108 | (lambda () | |
109 | (with-input-from-port (car p2c) | |
110 | (lambda () | |
111 | (open-input-pipe | |
112 | "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read REPLY"))))))) | |
113 | (close-port (cdr c2p)) ;; write side | |
114 | (let ((result (eof-object? (read-char port)))) | |
115 | (display "hello!\n" (cdr p2c)) | |
116 | (force-output (cdr p2c)) | |
117 | (close-pipe port) | |
118 | result)))) | |
119 | ||
120 | ;; | |
121 | ;; open-output-pipe | |
122 | ;; | |
123 | ||
124 | (with-test-prefix "open-output-pipe" | |
125 | ||
126 | (pass-if-exception "no args" exception:wrong-num-args | |
127 | (open-output-pipe)) | |
128 | ||
129 | (pass-if "port?" | |
130 | (port? (open-output-pipe "exit 0"))) | |
131 | ||
132 | ;; exercise file descriptor setups when stdin is the same as stderr | |
133 | (pass-if "stdin==stderr" | |
134 | (let ((port (open-file "/dev/null" "r+"))) | |
135 | (with-input-from-port port | |
136 | (lambda () | |
137 | (with-error-to-port port | |
138 | (lambda () | |
139 | (open-output-pipe "exit 0")))))) | |
140 | #t) | |
141 | ||
142 | ;; exercise file descriptor setups when stdout is the same as stderr | |
143 | (pass-if "stdout==stderr" | |
144 | (let ((port (open-file "/dev/null" "r+"))) | |
145 | (with-output-to-port port | |
146 | (lambda () | |
147 | (with-error-to-port port | |
148 | (lambda () | |
149 | (open-output-pipe "exit 0")))))) | |
150 | #t) | |
151 | ||
152 | ;; After the child closes stdin (which it indicates here by writing | |
153 | ;; "closed" to stderr), the parent should see a broken pipe. We | |
154 | ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 | |
155 | ;; and earlier a duplicate of stdin existed in the child, preventing | |
156 | ;; the broken pipe occurring. | |
157 | ;; | |
158 | ;; Note that the objective here is to test that the parent sees a | |
159 | ;; broken pipe while the child is still alive. (It is obvious that | |
160 | ;; the parent will see a broken pipe once the child has died.) The | |
161 | ;; use of the `c2p' pipe, and the repeated `echo closed' in the | |
162 | ;; child, allows us to be sure that we are testing what the parent | |
163 | ;; sees at a point where the child has closed stdin but is still | |
164 | ;; alive. | |
165 | ;; | |
166 | ;; Note that `with-epipe' must apply only to the parent and not to | |
167 | ;; the child process; we rely on the child getting SIGPIPE, to | |
168 | ;; terminate it (and avoid leaving a zombie). | |
169 | (pass-if "no duplicate" | |
170 | (let* ((c2p (pipe)) | |
171 | (port (with-error-to-port (cdr c2p) | |
172 | (lambda () | |
173 | (open-output-pipe | |
174 | (string-append "exec guile --no-auto-compile -s \"" | |
175 | (getenv "TEST_SUITE_DIR") | |
176 | "/tests/popen-child.scm\"")))))) | |
177 | (close-port (cdr c2p)) ;; write side | |
178 | (with-epipe | |
179 | (lambda () | |
180 | (let ((result | |
181 | (and (char? (read-char (car c2p))) ;; wait for child to do its thing | |
182 | (catch 'system-error | |
183 | (lambda () | |
184 | (write-char #\x port) | |
185 | (force-output port) | |
186 | #f) | |
187 | (lambda (key name fmt args errno-list) | |
188 | (= (car errno-list) EPIPE)))))) | |
189 | ;; Now close our reading end of the pipe. This should give | |
190 | ;; the child a broken pipe and so allow it to exit. | |
191 | (close-port (car c2p)) | |
192 | (close-pipe port) | |
193 | result)))))) | |
194 | ||
195 | ;; | |
196 | ;; close-pipe | |
197 | ;; | |
198 | ||
199 | (with-test-prefix "close-pipe" | |
200 | ||
201 | (pass-if-exception "no args" exception:wrong-num-args | |
202 | (close-pipe)) | |
3e690887 | 203 | |
df3d365a LC |
204 | (pass-if "exit 0" |
205 | (let ((st (close-pipe (open-output-pipe "exit 0")))) | |
206 | (and (status:exit-val st) | |
207 | (= 0 (status:exit-val st))))) | |
3e690887 | 208 | |
df3d365a LC |
209 | (pass-if "exit 1" |
210 | (let ((st (close-pipe (open-output-pipe "exit 1")))) | |
211 | (and (status:exit-val st) | |
212 | (= 1 (status:exit-val st))))))) |