Commit | Line | Data |
---|---|---|
0d572e91 | 1 | ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- |
7ef450bf | 2 | ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
000ee07f | 3 | ;;;; |
96e30d2a | 4 | ;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. |
000ee07f JB |
5 | ;;;; |
6 | ;;;; This program is free software; you can redistribute it and/or modify | |
7 | ;;;; it under the terms of the GNU General Public License as published by | |
8 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
9 | ;;;; any later version. | |
10 | ;;;; | |
11 | ;;;; This program is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;;; GNU General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU General Public License | |
17 | ;;;; along with this software; see the file COPYING. If not, write to | |
18 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
19 | ;;;; Boston, MA 02111-1307 USA | |
20 | ||
f5d4dde3 | 21 | (use-modules (test-suite lib) |
22d35615 GH |
22 | (ice-9 popen) |
23 | (ice-9 rdelim)) | |
000ee07f JB |
24 | |
25 | (define (display-line . args) | |
26 | (for-each display args) | |
27 | (newline)) | |
28 | ||
29 | (define (test-file) | |
c685b42f | 30 | (data-file-name "ports-test.tmp")) |
000ee07f JB |
31 | |
32 | \f | |
33 | ;;;; Some general utilities for testing ports. | |
34 | ||
35 | ;;; Read from PORT until EOF, and return the result as a string. | |
36 | (define (read-all port) | |
37 | (let loop ((chars '())) | |
38 | (let ((char (read-char port))) | |
39 | (if (eof-object? char) | |
40 | (list->string (reverse! chars)) | |
41 | (loop (cons char chars)))))) | |
42 | ||
43 | (define (read-file filename) | |
44 | (let* ((port (open-input-file filename)) | |
45 | (string (read-all port))) | |
46 | (close-port port) | |
47 | string)) | |
48 | ||
49 | \f | |
50 | ;;;; Normal file ports. | |
51 | ||
52 | ;;; Write out an s-expression, and read it back. | |
57e7f270 DH |
53 | (let ((string '("From fairest creatures we desire increase," |
54 | "That thereby beauty's rose might never die,")) | |
55 | (filename (test-file))) | |
56 | (let ((port (open-output-file filename))) | |
57 | (write string port) | |
58 | (close-port port)) | |
59 | (let ((port (open-input-file filename))) | |
60 | (let ((in-string (read port))) | |
61 | (pass-if "file: write and read back list of strings" | |
62 | (equal? string in-string))) | |
63 | (close-port port)) | |
64 | (delete-file filename)) | |
000ee07f JB |
65 | |
66 | ;;; Write out a string, and read it back a character at a time. | |
57e7f270 DH |
67 | (let ((string "This is a test string\nwith no newline at the end") |
68 | (filename (test-file))) | |
69 | (let ((port (open-output-file filename))) | |
70 | (display string port) | |
71 | (close-port port)) | |
72 | (let ((in-string (read-file filename))) | |
73 | (pass-if "file: write and read back characters" | |
74 | (equal? string in-string))) | |
75 | (delete-file filename)) | |
000ee07f | 76 | |
7c035009 | 77 | ;;; Buffered input/output port with seeking. |
57e7f270 DH |
78 | (let* ((filename (test-file)) |
79 | (port (open-file filename "w+"))) | |
80 | (display "J'Accuse" port) | |
81 | (seek port -1 SEEK_CUR) | |
82 | (pass-if "file: r/w 1" | |
83 | (char=? (read-char port) #\e)) | |
84 | (pass-if "file: r/w 2" | |
85 | (eof-object? (read-char port))) | |
86 | (seek port -1 SEEK_CUR) | |
87 | (write-char #\x port) | |
88 | (seek port 7 SEEK_SET) | |
89 | (pass-if "file: r/w 3" | |
90 | (char=? (read-char port) #\x)) | |
91 | (seek port -2 SEEK_END) | |
92 | (pass-if "file: r/w 4" | |
93 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 94 | (close-port port) |
57e7f270 | 95 | (delete-file filename)) |
7c035009 GH |
96 | |
97 | ;;; Unbuffered input/output port with seeking. | |
57e7f270 DH |
98 | (let* ((filename (test-file)) |
99 | (port (open-file filename "w+0"))) | |
100 | (display "J'Accuse" port) | |
101 | (seek port -1 SEEK_CUR) | |
102 | (pass-if "file: ub r/w 1" | |
103 | (char=? (read-char port) #\e)) | |
104 | (pass-if "file: ub r/w 2" | |
105 | (eof-object? (read-char port))) | |
106 | (seek port -1 SEEK_CUR) | |
107 | (write-char #\x port) | |
108 | (seek port 7 SEEK_SET) | |
109 | (pass-if "file: ub r/w 3" | |
110 | (char=? (read-char port) #\x)) | |
111 | (seek port -2 SEEK_END) | |
112 | (pass-if "file: ub r/w 4" | |
113 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 114 | (close-port port) |
57e7f270 | 115 | (delete-file filename)) |
7c035009 | 116 | |
4fcd6551 | 117 | ;;; Buffered output-only and input-only ports with seeking. |
57e7f270 DH |
118 | (let* ((filename (test-file)) |
119 | (port (open-output-file filename))) | |
120 | (display "J'Accuse" port) | |
121 | (pass-if "file: out tell" | |
122 | (= (seek port 0 SEEK_CUR) 8)) | |
123 | (seek port -1 SEEK_CUR) | |
124 | (write-char #\x port) | |
125 | (close-port port) | |
126 | (let ((iport (open-input-file filename))) | |
127 | (pass-if "file: in tell 0" | |
128 | (= (seek iport 0 SEEK_CUR) 0)) | |
129 | (read-char iport) | |
130 | (pass-if "file: in tell 1" | |
131 | (= (seek iport 0 SEEK_CUR) 1)) | |
132 | (unread-char #\z iport) | |
133 | (pass-if "file: in tell 0 after unread" | |
134 | (= (seek iport 0 SEEK_CUR) 0)) | |
135 | (pass-if "file: unread char still there" | |
136 | (char=? (read-char iport) #\z)) | |
137 | (seek iport 7 SEEK_SET) | |
138 | (pass-if "file: in last char" | |
139 | (char=? (read-char iport) #\x)) | |
140 | (close-port iport)) | |
141 | (delete-file filename)) | |
4fcd6551 | 142 | |
7f214e60 | 143 | ;;; unusual characters. |
57e7f270 DH |
144 | (let* ((filename (test-file)) |
145 | (port (open-output-file filename))) | |
146 | (display (string #\nul (integer->char 255) (integer->char 128) | |
147 | #\nul) port) | |
148 | (close-port port) | |
149 | (let* ((port (open-input-file filename)) | |
150 | (line (read-line port))) | |
151 | (pass-if "file: read back NUL 1" | |
152 | (char=? (string-ref line 0) #\nul)) | |
153 | (pass-if "file: read back 255" | |
154 | (char=? (string-ref line 1) (integer->char 255))) | |
155 | (pass-if "file: read back 128" | |
156 | (char=? (string-ref line 2) (integer->char 128))) | |
157 | (pass-if "file: read back NUL 2" | |
158 | (char=? (string-ref line 3) #\nul)) | |
159 | (pass-if "file: EOF" | |
8f99e3f3 SJ |
160 | (eof-object? (read-char port))) |
161 | (close-port port)) | |
57e7f270 | 162 | (delete-file filename)) |
7f214e60 | 163 | |
0eb2e8cd | 164 | ;;; line buffering mode. |
57e7f270 DH |
165 | (let* ((filename (test-file)) |
166 | (port (open-file filename "wl")) | |
167 | (test-string "one line more or less")) | |
168 | (write-line test-string port) | |
169 | (let* ((in-port (open-input-file filename)) | |
170 | (line (read-line in-port))) | |
171 | (close-port in-port) | |
172 | (close-port port) | |
173 | (pass-if "file: line buffering" | |
174 | (string=? line test-string))) | |
175 | (delete-file filename)) | |
0eb2e8cd | 176 | |
d1b143e9 | 177 | ;;; ungetting characters and strings. |
57e7f270 DH |
178 | (with-input-from-string "walk on the moon\nmoon" |
179 | (lambda () | |
180 | (read-char) | |
181 | (unread-char #\a (current-input-port)) | |
182 | (pass-if "unread-char" | |
183 | (char=? (read-char) #\a)) | |
184 | (read-line) | |
185 | (let ((replacenoid "chicken enchilada")) | |
186 | (unread-char #\newline (current-input-port)) | |
187 | (unread-string replacenoid (current-input-port)) | |
188 | (pass-if "unread-string" | |
189 | (string=? (read-line) replacenoid))) | |
190 | (pass-if "unread residue" | |
191 | (string=? (read-line) "moon")))) | |
d1b143e9 | 192 | |
6e822cce | 193 | ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on |
8cc58ec1 GH |
194 | ;;; the reading end. try to read a byte: should get EAGAIN or |
195 | ;;; EWOULDBLOCK error. | |
57e7f270 DH |
196 | (let* ((p (pipe)) |
197 | (r (car p))) | |
198 | (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) | |
199 | (pass-if "non-blocking-I/O" | |
200 | (catch 'system-error | |
201 | (lambda () (read-char r) #f) | |
202 | (lambda (key . args) | |
203 | (and (eq? key 'system-error) | |
204 | (let ((errno (car (list-ref args 3)))) | |
205 | (or (= errno EAGAIN) | |
206 | (= errno EWOULDBLOCK)))))))) | |
22d35615 | 207 | |
000ee07f | 208 | \f |
6e822cce | 209 | ;;;; Pipe (popen) ports. |
000ee07f JB |
210 | |
211 | ;;; Run a command, and read its output. | |
57e7f270 DH |
212 | (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) |
213 | (in-string (read-all pipe))) | |
214 | (close-pipe pipe) | |
215 | (pass-if "pipe: read" | |
216 | (equal? in-string "Howdy there, partner!\n"))) | |
000ee07f JB |
217 | |
218 | ;;; Run a command, send some output to it, and see if it worked. | |
57e7f270 DH |
219 | (let* ((filename (test-file)) |
220 | (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) | |
221 | (display "Now Jimmy lives on a mushroom cloud\n" pipe) | |
222 | (display "Mommy, why does everybody have a bomb?\n" pipe) | |
223 | (close-pipe pipe) | |
224 | (let ((in-string (read-file filename))) | |
225 | (pass-if "pipe: write" | |
226 | (equal? in-string "Mommy, why does everybody have a bomb?\n"))) | |
227 | (delete-file filename)) | |
000ee07f JB |
228 | |
229 | \f | |
230 | ;;;; Void ports. These are so trivial we don't test them. | |
231 | ||
232 | \f | |
233 | ;;;; String ports. | |
234 | ||
73cb0a97 JB |
235 | (with-test-prefix "string ports" |
236 | ||
237 | ;; Write text to a string port. | |
57e7f270 DH |
238 | (let* ((string "Howdy there, partner!") |
239 | (in-string (call-with-output-string | |
240 | (lambda (port) | |
241 | (display string port) | |
242 | (newline port))))) | |
243 | (pass-if "display text" | |
244 | (equal? in-string (string-append string "\n")))) | |
000ee07f | 245 | |
73cb0a97 | 246 | ;; Write an s-expression to a string port. |
57e7f270 DH |
247 | (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) |
248 | (in-sexpr | |
249 | (call-with-input-string (call-with-output-string | |
250 | (lambda (port) | |
251 | (write sexpr port))) | |
252 | read))) | |
253 | (pass-if "write/read sexpr" | |
254 | (equal? in-sexpr sexpr))) | |
2d9e5bca GH |
255 | |
256 | ;; seeking and unreading from an input string. | |
57e7f270 DH |
257 | (let ((text "that text didn't look random to me")) |
258 | (call-with-input-string text | |
259 | (lambda (p) | |
260 | (pass-if "input tell 0" | |
261 | (= (seek p 0 SEEK_CUR) 0)) | |
262 | (read-char p) | |
263 | (pass-if "input tell 1" | |
264 | (= (seek p 0 SEEK_CUR) 1)) | |
265 | (unread-char #\x p) | |
266 | (pass-if "input tell back to 0" | |
267 | (= (seek p 0 SEEK_CUR) 0)) | |
268 | (pass-if "input ungetted char" | |
269 | (char=? (read-char p) #\x)) | |
270 | (seek p 0 SEEK_END) | |
271 | (pass-if "input seek to end" | |
272 | (= (seek p 0 SEEK_CUR) | |
273 | (string-length text))) | |
274 | (unread-char #\x p) | |
275 | (pass-if "input seek to beginning" | |
276 | (= (seek p 0 SEEK_SET) 0)) | |
277 | (pass-if "input reread first char" | |
278 | (char=? (read-char p) | |
279 | (string-ref text 0)))))) | |
280 | ||
2d9e5bca | 281 | ;; seeking an output string. |
57e7f270 DH |
282 | (let* ((text "123456789") |
283 | (len (string-length text)) | |
284 | (result (call-with-output-string | |
285 | (lambda (p) | |
286 | (pass-if "output tell 0" | |
287 | (= (seek p 0 SEEK_CUR) 0)) | |
288 | (display text p) | |
289 | (pass-if "output tell end" | |
290 | (= (seek p 0 SEEK_CUR) len)) | |
291 | (pass-if "output seek to beginning" | |
292 | (= (seek p 0 SEEK_SET) 0)) | |
293 | (write-char #\a p) | |
294 | (seek p -1 SEEK_END) | |
295 | (pass-if "output seek to last char" | |
296 | (= (seek p 0 SEEK_CUR) | |
297 | (- len 1))) | |
298 | (write-char #\b p))))) | |
299 | (string-set! text 0 #\a) | |
300 | (string-set! text (- len 1) #\b) | |
301 | (pass-if "output check" | |
302 | (string=? text result)))) | |
2d9e5bca | 303 | |
000ee07f JB |
304 | |
305 | \f | |
306 | ;;;; Soft ports. No tests implemented yet. | |
307 | ||
308 | \f | |
309 | ;;;; Generic operations across all port types. | |
310 | ||
311 | (let ((port-loop-temp (test-file))) | |
312 | ||
313 | ;; Return a list of input ports that all return the same text. | |
314 | ;; We map tests over this list. | |
315 | (define (input-port-list text) | |
316 | ||
317 | ;; Create a text file some of the ports will use. | |
318 | (let ((out-port (open-output-file port-loop-temp))) | |
319 | (display text out-port) | |
320 | (close-port out-port)) | |
321 | ||
322 | (list (open-input-file port-loop-temp) | |
323 | (open-input-pipe (string-append "cat " port-loop-temp)) | |
324 | (call-with-input-string text (lambda (x) x)) | |
325 | ;; We don't test soft ports at the moment. | |
326 | )) | |
327 | ||
328 | (define port-list-names '("file" "pipe" "string")) | |
329 | ||
330 | ;; Test the line counter. | |
73cb0a97 | 331 | (define (test-line-counter text second-line final-column) |
000ee07f JB |
332 | (with-test-prefix "line counter" |
333 | (let ((ports (input-port-list text))) | |
334 | (for-each | |
335 | (lambda (port port-name) | |
336 | (with-test-prefix port-name | |
337 | (pass-if "at beginning of input" | |
338 | (= (port-line port) 0)) | |
339 | (pass-if "read first character" | |
340 | (eqv? (read-char port) #\x)) | |
341 | (pass-if "after reading one character" | |
342 | (= (port-line port) 0)) | |
343 | (pass-if "read first newline" | |
344 | (eqv? (read-char port) #\newline)) | |
345 | (pass-if "after reading first newline char" | |
346 | (= (port-line port) 1)) | |
347 | (pass-if "second line read correctly" | |
348 | (equal? (read-line port) second-line)) | |
349 | (pass-if "read-line increments line number" | |
350 | (= (port-line port) 2)) | |
0b8faa0e JB |
351 | (pass-if "read-line returns EOF" |
352 | (let loop ((i 0)) | |
353 | (cond | |
354 | ((eof-object? (read-line port)) #t) | |
355 | ((> i 20) #f) | |
356 | (else (loop (+ i 1)))))) | |
000ee07f | 357 | (pass-if "line count is 5 at EOF" |
73cb0a97 JB |
358 | (= (port-line port) 5)) |
359 | (pass-if "column is correct at EOF" | |
360 | (= (port-column port) final-column)))) | |
000ee07f JB |
361 | ports port-list-names) |
362 | (for-each close-port ports) | |
363 | (delete-file port-loop-temp)))) | |
364 | ||
57e7f270 DH |
365 | (with-test-prefix "newline" |
366 | (test-line-counter | |
367 | (string-append "x\n" | |
368 | "He who receives an idea from me, receives instruction\n" | |
369 | "himself without lessening mine; as he who lights his\n" | |
370 | "taper at mine, receives light without darkening me.\n" | |
371 | " --- Thomas Jefferson\n") | |
372 | "He who receives an idea from me, receives instruction" | |
373 | 0)) | |
374 | ||
375 | (with-test-prefix "no newline" | |
376 | (test-line-counter | |
377 | (string-append "x\n" | |
378 | "He who receives an idea from me, receives instruction\n" | |
379 | "himself without lessening mine; as he who lights his\n" | |
380 | "taper at mine, receives light without darkening me.\n" | |
381 | " --- Thomas Jefferson\n" | |
382 | "no newline here") | |
383 | "He who receives an idea from me, receives instruction" | |
384 | 15))) | |
5bc1201f | 385 | |
9a8be5a7 MV |
386 | ;; Test port-line and port-column for output ports |
387 | ||
388 | (define (test-output-line-counter text final-column) | |
389 | (with-test-prefix "port-line and port-column for output ports" | |
390 | (let ((port (open-output-string))) | |
391 | (pass-if "at beginning of input" | |
392 | (and (= (port-line port) 0) | |
393 | (= (port-column port) 0))) | |
394 | (write-char #\x port) | |
395 | (pass-if "after writing one character" | |
396 | (and (= (port-line port) 0) | |
397 | (= (port-column port) 1))) | |
398 | (write-char #\newline port) | |
399 | (pass-if "after writing first newline char" | |
400 | (and (= (port-line port) 1) | |
401 | (= (port-column port) 0))) | |
402 | (display text port) | |
403 | (pass-if "line count is 5 at end" | |
404 | (= (port-line port) 5)) | |
405 | (pass-if "column is correct at end" | |
406 | (= (port-column port) final-column))))) | |
407 | ||
408 | (test-output-line-counter | |
409 | (string-append "He who receives an idea from me, receives instruction\n" | |
410 | "himself without lessening mine; as he who lights his\n" | |
411 | "taper at mine, receives light without darkening me.\n" | |
412 | " --- Thomas Jefferson\n" | |
413 | "no newline here") | |
414 | 15) | |
415 | ||
5bc1201f JB |
416 | ;;;; testing read-delimited and friends |
417 | ||
418 | (with-test-prefix "read-delimited!" | |
419 | (let ((c (make-string 20 #\!))) | |
420 | (call-with-input-string | |
421 | "defdef\nghighi\n" | |
422 | (lambda (port) | |
423 | ||
424 | (read-delimited! "\n" c port 'concat) | |
425 | (pass-if "read-delimited! reads a first line" | |
426 | (string=? c "defdef\n!!!!!!!!!!!!!")) | |
427 | ||
428 | (read-delimited! "\n" c port 'concat 3) | |
429 | (pass-if "read-delimited! reads a first line" | |
430 | (string=? c "defghighi\n!!!!!!!!!!")))))) | |
1b054952 JB |
431 | |
432 | \f | |
433 | ;;;; char-ready? | |
434 | ||
435 | (call-with-input-string | |
436 | "howdy" | |
437 | (lambda (port) | |
438 | (pass-if "char-ready? returns true on string port" | |
439 | (char-ready? port)))) | |
440 | ||
441 | ;;; This segfaults on some versions of Guile. We really should run | |
442 | ;;; the tests in a subprocess... | |
443 | ||
444 | (call-with-input-string | |
445 | "howdy" | |
446 | (lambda (port) | |
447 | (with-input-from-port | |
448 | port | |
449 | (lambda () | |
450 | (pass-if "char-ready? returns true on string port as default port" | |
451 | (char-ready?)))))) | |
fe5b6beb JB |
452 | |
453 | \f | |
454 | ;;;; Close current-input-port, and make sure everyone can handle it. | |
455 | ||
456 | (with-test-prefix "closing current-input-port" | |
457 | (for-each (lambda (procedure name) | |
458 | (with-input-from-port | |
459 | (call-with-input-string "foo" (lambda (p) p)) | |
460 | (lambda () | |
461 | (close-port (current-input-port)) | |
6b4113af DH |
462 | (pass-if-exception name |
463 | exception:wrong-type-arg | |
464 | (procedure))))) | |
fe5b6beb JB |
465 | (list read read-char read-line) |
466 | '("read" "read-char" "read-line"))) |