Commit | Line | Data |
---|---|---|
7b041912 | 1 | ;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*- |
7ef450bf | 2 | ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 |
000ee07f | 3 | ;;;; |
2e59af21 LC |
4 | ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, |
5 | ;;;; 2011 Free Software Foundation, Inc. | |
6 | ;;;; | |
53befeb7 NJ |
7 | ;;;; This library is free software; you can redistribute it and/or |
8 | ;;;; modify it under the terms of the GNU Lesser General Public | |
9 | ;;;; License as published by the Free Software Foundation; either | |
10 | ;;;; version 3 of the License, or (at your option) any later version. | |
000ee07f | 11 | ;;;; |
53befeb7 | 12 | ;;;; This library is distributed in the hope that it will be useful, |
000ee07f | 13 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
53befeb7 NJ |
14 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
15 | ;;;; Lesser General Public License for more details. | |
000ee07f | 16 | ;;;; |
53befeb7 NJ |
17 | ;;;; You should have received a copy of the GNU Lesser General Public |
18 | ;;;; License along with this library; if not, write to the Free Software | |
19 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
000ee07f | 20 | |
8aa28a91 | 21 | (define-module (test-suite test-ports) |
2e59af21 LC |
22 | #:use-module (test-suite lib) |
23 | #:use-module (test-suite guile-test) | |
24 | #:use-module (ice-9 popen) | |
25 | #:use-module (ice-9 rdelim) | |
cc540d0b LC |
26 | #:use-module (rnrs bytevectors) |
27 | #:use-module ((rnrs io ports) #:select (open-bytevector-input-port))) | |
000ee07f JB |
28 | |
29 | (define (display-line . args) | |
30 | (for-each display args) | |
31 | (newline)) | |
32 | ||
33 | (define (test-file) | |
c685b42f | 34 | (data-file-name "ports-test.tmp")) |
000ee07f JB |
35 | |
36 | \f | |
37 | ;;;; Some general utilities for testing ports. | |
38 | ||
d6a6989e LC |
39 | ;; Make sure we are set up for 8-bit Latin-1 data. |
40 | (fluid-set! %default-port-encoding "ISO-8859-1") | |
41 | (for-each (lambda (p) | |
42 | (set-port-encoding! p (fluid-ref %default-port-encoding))) | |
43 | (list (current-input-port) (current-output-port) | |
44 | (current-error-port))) | |
889975e5 | 45 | |
000ee07f JB |
46 | ;;; Read from PORT until EOF, and return the result as a string. |
47 | (define (read-all port) | |
48 | (let loop ((chars '())) | |
49 | (let ((char (read-char port))) | |
50 | (if (eof-object? char) | |
51 | (list->string (reverse! chars)) | |
52 | (loop (cons char chars)))))) | |
53 | ||
54 | (define (read-file filename) | |
55 | (let* ((port (open-input-file filename)) | |
56 | (string (read-all port))) | |
57 | (close-port port) | |
58 | string)) | |
59 | ||
60 | \f | |
61 | ;;;; Normal file ports. | |
62 | ||
63 | ;;; Write out an s-expression, and read it back. | |
57e7f270 DH |
64 | (let ((string '("From fairest creatures we desire increase," |
65 | "That thereby beauty's rose might never die,")) | |
66 | (filename (test-file))) | |
67 | (let ((port (open-output-file filename))) | |
68 | (write string port) | |
69 | (close-port port)) | |
70 | (let ((port (open-input-file filename))) | |
71 | (let ((in-string (read port))) | |
72 | (pass-if "file: write and read back list of strings" | |
73 | (equal? string in-string))) | |
74 | (close-port port)) | |
75 | (delete-file filename)) | |
000ee07f JB |
76 | |
77 | ;;; Write out a string, and read it back a character at a time. | |
57e7f270 DH |
78 | (let ((string "This is a test string\nwith no newline at the end") |
79 | (filename (test-file))) | |
80 | (let ((port (open-output-file filename))) | |
81 | (display string port) | |
82 | (close-port port)) | |
83 | (let ((in-string (read-file filename))) | |
84 | (pass-if "file: write and read back characters" | |
85 | (equal? string in-string))) | |
86 | (delete-file filename)) | |
000ee07f | 87 | |
7c035009 | 88 | ;;; Buffered input/output port with seeking. |
57e7f270 DH |
89 | (let* ((filename (test-file)) |
90 | (port (open-file filename "w+"))) | |
91 | (display "J'Accuse" port) | |
92 | (seek port -1 SEEK_CUR) | |
93 | (pass-if "file: r/w 1" | |
94 | (char=? (read-char port) #\e)) | |
95 | (pass-if "file: r/w 2" | |
96 | (eof-object? (read-char port))) | |
97 | (seek port -1 SEEK_CUR) | |
98 | (write-char #\x port) | |
99 | (seek port 7 SEEK_SET) | |
100 | (pass-if "file: r/w 3" | |
101 | (char=? (read-char port) #\x)) | |
102 | (seek port -2 SEEK_END) | |
103 | (pass-if "file: r/w 4" | |
104 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 105 | (close-port port) |
57e7f270 | 106 | (delete-file filename)) |
7c035009 GH |
107 | |
108 | ;;; Unbuffered input/output port with seeking. | |
57e7f270 DH |
109 | (let* ((filename (test-file)) |
110 | (port (open-file filename "w+0"))) | |
111 | (display "J'Accuse" port) | |
112 | (seek port -1 SEEK_CUR) | |
113 | (pass-if "file: ub r/w 1" | |
114 | (char=? (read-char port) #\e)) | |
115 | (pass-if "file: ub r/w 2" | |
116 | (eof-object? (read-char port))) | |
117 | (seek port -1 SEEK_CUR) | |
118 | (write-char #\x port) | |
119 | (seek port 7 SEEK_SET) | |
120 | (pass-if "file: ub r/w 3" | |
121 | (char=? (read-char port) #\x)) | |
122 | (seek port -2 SEEK_END) | |
123 | (pass-if "file: ub r/w 4" | |
124 | (char=? (read-char port) #\s)) | |
8f99e3f3 | 125 | (close-port port) |
57e7f270 | 126 | (delete-file filename)) |
7c035009 | 127 | |
4fcd6551 | 128 | ;;; Buffered output-only and input-only ports with seeking. |
57e7f270 DH |
129 | (let* ((filename (test-file)) |
130 | (port (open-output-file filename))) | |
131 | (display "J'Accuse" port) | |
132 | (pass-if "file: out tell" | |
133 | (= (seek port 0 SEEK_CUR) 8)) | |
134 | (seek port -1 SEEK_CUR) | |
135 | (write-char #\x port) | |
136 | (close-port port) | |
137 | (let ((iport (open-input-file filename))) | |
138 | (pass-if "file: in tell 0" | |
139 | (= (seek iport 0 SEEK_CUR) 0)) | |
140 | (read-char iport) | |
141 | (pass-if "file: in tell 1" | |
142 | (= (seek iport 0 SEEK_CUR) 1)) | |
143 | (unread-char #\z iport) | |
144 | (pass-if "file: in tell 0 after unread" | |
145 | (= (seek iport 0 SEEK_CUR) 0)) | |
146 | (pass-if "file: unread char still there" | |
147 | (char=? (read-char iport) #\z)) | |
148 | (seek iport 7 SEEK_SET) | |
149 | (pass-if "file: in last char" | |
150 | (char=? (read-char iport) #\x)) | |
151 | (close-port iport)) | |
152 | (delete-file filename)) | |
4fcd6551 | 153 | |
7f214e60 | 154 | ;;; unusual characters. |
57e7f270 DH |
155 | (let* ((filename (test-file)) |
156 | (port (open-output-file filename))) | |
157 | (display (string #\nul (integer->char 255) (integer->char 128) | |
158 | #\nul) port) | |
159 | (close-port port) | |
160 | (let* ((port (open-input-file filename)) | |
161 | (line (read-line port))) | |
162 | (pass-if "file: read back NUL 1" | |
163 | (char=? (string-ref line 0) #\nul)) | |
164 | (pass-if "file: read back 255" | |
165 | (char=? (string-ref line 1) (integer->char 255))) | |
166 | (pass-if "file: read back 128" | |
167 | (char=? (string-ref line 2) (integer->char 128))) | |
168 | (pass-if "file: read back NUL 2" | |
169 | (char=? (string-ref line 3) #\nul)) | |
170 | (pass-if "file: EOF" | |
8f99e3f3 SJ |
171 | (eof-object? (read-char port))) |
172 | (close-port port)) | |
57e7f270 | 173 | (delete-file filename)) |
7f214e60 | 174 | |
0eb2e8cd | 175 | ;;; line buffering mode. |
57e7f270 DH |
176 | (let* ((filename (test-file)) |
177 | (port (open-file filename "wl")) | |
178 | (test-string "one line more or less")) | |
179 | (write-line test-string port) | |
180 | (let* ((in-port (open-input-file filename)) | |
181 | (line (read-line in-port))) | |
182 | (close-port in-port) | |
183 | (close-port port) | |
184 | (pass-if "file: line buffering" | |
185 | (string=? line test-string))) | |
186 | (delete-file filename)) | |
0eb2e8cd | 187 | |
e50d921b MG |
188 | ;;; read-line should use the port encoding (not the locale encoding). |
189 | (let ((str "ĉu bone?")) | |
211683cc MG |
190 | (with-locale "C" |
191 | (let* ((filename (test-file)) | |
192 | (port (open-file filename "wl"))) | |
193 | (set-port-encoding! port "UTF-8") | |
194 | (write-line str port) | |
195 | (let ((in-port (open-input-file filename))) | |
196 | (set-port-encoding! in-port "UTF-8") | |
197 | (let ((line (read-line in-port))) | |
198 | (close-port in-port) | |
199 | (close-port port) | |
200 | (pass-if "file: read-line honors port encoding" | |
201 | (string=? line str)))) | |
202 | (delete-file filename)))) | |
203 | ||
204 | ;;; binary mode ignores port encoding | |
205 | (pass-if "file: binary mode ignores port encoding" | |
206 | (with-fluids ((%default-port-encoding "UTF-8")) | |
207 | (let* ((filename (test-file)) | |
208 | (port (open-file filename "w")) | |
209 | (test-string "一二三") | |
210 | (binary-test-string | |
211 | (apply string | |
212 | (map integer->char | |
213 | (uniform-vector->list | |
214 | (string->utf8 test-string)))))) | |
215 | (write-line test-string port) | |
216 | (close-port port) | |
217 | (let* ((in-port (open-file filename "rb")) | |
218 | (line (read-line in-port))) | |
219 | (close-port in-port) | |
220 | (delete-file filename) | |
221 | (string=? line binary-test-string))))) | |
222 | ||
223 | ;;; binary mode ignores file coding declaration | |
224 | (pass-if "file: binary mode ignores file coding declaration" | |
225 | (with-fluids ((%default-port-encoding "UTF-8")) | |
226 | (let* ((filename (test-file)) | |
227 | (port (open-file filename "w")) | |
228 | (test-string "一二三") | |
229 | (binary-test-string | |
230 | (apply string | |
231 | (map integer->char | |
232 | (uniform-vector->list | |
233 | (string->utf8 test-string)))))) | |
234 | (write-line ";; coding: utf-8" port) | |
235 | (write-line test-string port) | |
236 | (close-port port) | |
237 | (let* ((in-port (open-file filename "rb")) | |
238 | (line1 (read-line in-port)) | |
239 | (line2 (read-line in-port))) | |
240 | (close-port in-port) | |
241 | (delete-file filename) | |
242 | (string=? line2 binary-test-string))))) | |
243 | ||
244 | ;; open-file honors file coding declarations | |
245 | (pass-if "file: open-file honors coding declarations" | |
246 | (with-fluids ((%default-port-encoding "UTF-8")) | |
247 | (let* ((filename (test-file)) | |
248 | (port (open-output-file filename)) | |
249 | (test-string "€100")) | |
250 | (set-port-encoding! port "ISO-8859-15") | |
251 | (write-line ";; coding: iso-8859-15" port) | |
252 | (write-line test-string port) | |
253 | (close-port port) | |
254 | (let* ((in-port (open-input-file filename)) | |
255 | (line1 (read-line in-port)) | |
256 | (line2 (read-line in-port))) | |
257 | (close-port in-port) | |
258 | (delete-file filename) | |
259 | (string=? line2 test-string))))) | |
e50d921b | 260 | |
d1b143e9 | 261 | ;;; ungetting characters and strings. |
57e7f270 DH |
262 | (with-input-from-string "walk on the moon\nmoon" |
263 | (lambda () | |
264 | (read-char) | |
265 | (unread-char #\a (current-input-port)) | |
266 | (pass-if "unread-char" | |
267 | (char=? (read-char) #\a)) | |
268 | (read-line) | |
269 | (let ((replacenoid "chicken enchilada")) | |
270 | (unread-char #\newline (current-input-port)) | |
271 | (unread-string replacenoid (current-input-port)) | |
272 | (pass-if "unread-string" | |
273 | (string=? (read-line) replacenoid))) | |
274 | (pass-if "unread residue" | |
275 | (string=? (read-line) "moon")))) | |
d1b143e9 | 276 | |
6e822cce | 277 | ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on |
8cc58ec1 GH |
278 | ;;; the reading end. try to read a byte: should get EAGAIN or |
279 | ;;; EWOULDBLOCK error. | |
57e7f270 DH |
280 | (let* ((p (pipe)) |
281 | (r (car p))) | |
282 | (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) | |
283 | (pass-if "non-blocking-I/O" | |
284 | (catch 'system-error | |
285 | (lambda () (read-char r) #f) | |
286 | (lambda (key . args) | |
287 | (and (eq? key 'system-error) | |
288 | (let ((errno (car (list-ref args 3)))) | |
289 | (or (= errno EAGAIN) | |
290 | (= errno EWOULDBLOCK)))))))) | |
22d35615 | 291 | |
000ee07f | 292 | \f |
6e822cce | 293 | ;;;; Pipe (popen) ports. |
000ee07f JB |
294 | |
295 | ;;; Run a command, and read its output. | |
57e7f270 DH |
296 | (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) |
297 | (in-string (read-all pipe))) | |
298 | (close-pipe pipe) | |
299 | (pass-if "pipe: read" | |
300 | (equal? in-string "Howdy there, partner!\n"))) | |
000ee07f JB |
301 | |
302 | ;;; Run a command, send some output to it, and see if it worked. | |
57e7f270 DH |
303 | (let* ((filename (test-file)) |
304 | (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) | |
305 | (display "Now Jimmy lives on a mushroom cloud\n" pipe) | |
306 | (display "Mommy, why does everybody have a bomb?\n" pipe) | |
307 | (close-pipe pipe) | |
308 | (let ((in-string (read-file filename))) | |
309 | (pass-if "pipe: write" | |
310 | (equal? in-string "Mommy, why does everybody have a bomb?\n"))) | |
311 | (delete-file filename)) | |
000ee07f JB |
312 | |
313 | \f | |
314 | ;;;; Void ports. These are so trivial we don't test them. | |
315 | ||
316 | \f | |
317 | ;;;; String ports. | |
318 | ||
73cb0a97 JB |
319 | (with-test-prefix "string ports" |
320 | ||
321 | ;; Write text to a string port. | |
57e7f270 DH |
322 | (let* ((string "Howdy there, partner!") |
323 | (in-string (call-with-output-string | |
324 | (lambda (port) | |
325 | (display string port) | |
326 | (newline port))))) | |
327 | (pass-if "display text" | |
328 | (equal? in-string (string-append string "\n")))) | |
000ee07f | 329 | |
73cb0a97 | 330 | ;; Write an s-expression to a string port. |
57e7f270 DH |
331 | (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) |
332 | (in-sexpr | |
333 | (call-with-input-string (call-with-output-string | |
334 | (lambda (port) | |
335 | (write sexpr port))) | |
336 | read))) | |
337 | (pass-if "write/read sexpr" | |
338 | (equal? in-sexpr sexpr))) | |
2d9e5bca GH |
339 | |
340 | ;; seeking and unreading from an input string. | |
57e7f270 DH |
341 | (let ((text "that text didn't look random to me")) |
342 | (call-with-input-string text | |
343 | (lambda (p) | |
344 | (pass-if "input tell 0" | |
345 | (= (seek p 0 SEEK_CUR) 0)) | |
346 | (read-char p) | |
347 | (pass-if "input tell 1" | |
348 | (= (seek p 0 SEEK_CUR) 1)) | |
349 | (unread-char #\x p) | |
350 | (pass-if "input tell back to 0" | |
351 | (= (seek p 0 SEEK_CUR) 0)) | |
352 | (pass-if "input ungetted char" | |
353 | (char=? (read-char p) #\x)) | |
354 | (seek p 0 SEEK_END) | |
355 | (pass-if "input seek to end" | |
356 | (= (seek p 0 SEEK_CUR) | |
357 | (string-length text))) | |
358 | (unread-char #\x p) | |
359 | (pass-if "input seek to beginning" | |
360 | (= (seek p 0 SEEK_SET) 0)) | |
361 | (pass-if "input reread first char" | |
362 | (char=? (read-char p) | |
363 | (string-ref text 0)))))) | |
364 | ||
2d9e5bca | 365 | ;; seeking an output string. |
e4cbd1d8 | 366 | (let* ((text (string-copy "123456789")) |
57e7f270 DH |
367 | (len (string-length text)) |
368 | (result (call-with-output-string | |
369 | (lambda (p) | |
370 | (pass-if "output tell 0" | |
371 | (= (seek p 0 SEEK_CUR) 0)) | |
372 | (display text p) | |
373 | (pass-if "output tell end" | |
374 | (= (seek p 0 SEEK_CUR) len)) | |
375 | (pass-if "output seek to beginning" | |
376 | (= (seek p 0 SEEK_SET) 0)) | |
377 | (write-char #\a p) | |
378 | (seek p -1 SEEK_END) | |
379 | (pass-if "output seek to last char" | |
380 | (= (seek p 0 SEEK_CUR) | |
381 | (- len 1))) | |
382 | (write-char #\b p))))) | |
383 | (string-set! text 0 #\a) | |
384 | (string-set! text (- len 1) #\b) | |
385 | (pass-if "output check" | |
7b041912 LC |
386 | (string=? text result))) |
387 | ||
388 | (pass-if "%default-port-encoding is honored" | |
389 | (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3"))) | |
390 | (equal? (map (lambda (e) | |
391 | (with-fluids ((%default-port-encoding e)) | |
392 | (call-with-output-string | |
393 | (lambda (p) | |
394 | (display (port-encoding p) p))))) | |
395 | encodings) | |
396 | encodings))) | |
397 | ||
398 | (pass-if "suitable encoding [latin-1]" | |
399 | (let ((str "hello, world")) | |
400 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
401 | (equal? str | |
402 | (with-output-to-string | |
403 | (lambda () | |
404 | (display str))))))) | |
405 | ||
406 | (pass-if "suitable encoding [latin-3]" | |
407 | (let ((str "ĉu bone?")) | |
408 | (with-fluids ((%default-port-encoding "ISO-8859-3")) | |
409 | (equal? str | |
410 | (with-output-to-string | |
411 | (lambda () | |
412 | (display str))))))) | |
413 | ||
ef7e4ba3 | 414 | (pass-if "wrong encoding" |
7b041912 | 415 | (let ((str "ĉu bone?")) |
ef7e4ba3 LC |
416 | (catch 'encoding-error |
417 | (lambda () | |
418 | ;; Latin-1 cannot represent ‘ĉ’. | |
419 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
420 | (with-output-to-string | |
421 | (lambda () | |
422 | (display str))))) | |
6851d3be LC |
423 | (lambda (key subr message errno port chr) |
424 | (and (eq? chr #\ĉ) | |
fd5eec2b LC |
425 | (string? (strerror errno))))))) |
426 | ||
2e59af21 LC |
427 | (pass-if "wrong encoding, substitute" |
428 | (let ((str "ĉu bone?")) | |
429 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
430 | (string=? (with-output-to-string | |
431 | (lambda () | |
432 | (set-port-conversion-strategy! (current-output-port) | |
433 | 'substitute) | |
434 | (display str))) | |
435 | "?u bone?")))) | |
436 | ||
437 | (pass-if "wrong encoding, escape" | |
438 | (let ((str "ĉu bone?")) | |
439 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
440 | (string=? (with-output-to-string | |
441 | (lambda () | |
442 | (set-port-conversion-strategy! (current-output-port) | |
443 | 'escape) | |
444 | (display str))) | |
445 | "\\u0109u bone?")))) | |
446 | ||
fd5eec2b LC |
447 | (pass-if "peek-char [latin-1]" |
448 | (let ((p (with-fluids ((%default-port-encoding #f)) | |
449 | (open-input-string "hello, world")))) | |
450 | (and (char=? (peek-char p) #\h) | |
451 | (char=? (peek-char p) #\h) | |
452 | (char=? (peek-char p) #\h) | |
453 | (= (port-line p) 0) | |
454 | (= (port-column p) 0)))) | |
455 | ||
456 | (pass-if "peek-char [utf-8]" | |
457 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) | |
458 | (open-input-string "안녕하세요")))) | |
459 | (and (char=? (peek-char p) #\안) | |
460 | (char=? (peek-char p) #\안) | |
461 | (char=? (peek-char p) #\안) | |
462 | (= (port-line p) 0) | |
cc540d0b LC |
463 | (= (port-column p) 0)))) |
464 | ||
c62da8f8 | 465 | (pass-if "read-char, wrong encoding, error" |
cc540d0b | 466 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) |
c62da8f8 LC |
467 | (open-bytevector-input-port #vu8(255 65 66 67))))) |
468 | (catch 'decoding-error | |
469 | (lambda () | |
470 | (set-port-conversion-strategy! p 'error) | |
471 | (read-char p) | |
472 | #f) | |
473 | (lambda (key subr message err port) | |
474 | (and (eq? port p) | |
475 | ||
476 | ;; PORT should point past the error. | |
477 | (equal? '(#\A #\B #\C) | |
478 | (list (read-char port) | |
479 | (read-char port) | |
480 | (read-char port))) | |
481 | ||
482 | (eof-object? (read-char port))))))) | |
483 | ||
484 | (pass-if "read-char, wrong encoding, escape" | |
485 | ;; `escape' should behave exactly like `error'. | |
cc540d0b | 486 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) |
c62da8f8 LC |
487 | (open-bytevector-input-port #vu8(255 65 66 67))))) |
488 | (catch 'decoding-error | |
489 | (lambda () | |
490 | (set-port-conversion-strategy! p 'escape) | |
491 | (read-char p) | |
492 | #f) | |
493 | (lambda (key subr message err port) | |
494 | (and (eq? port p) | |
495 | ||
496 | ;; PORT should point past the error. | |
497 | (equal? '(#\A #\B #\C) | |
498 | (list (read-char port) | |
499 | (read-char port) | |
500 | (read-char port))) | |
501 | ||
502 | (eof-object? (read-char port))))))) | |
cc540d0b LC |
503 | |
504 | (pass-if "read-char, wrong encoding, substitute" | |
505 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) | |
506 | (open-bytevector-input-port #vu8(255 206 187 206 188))))) | |
507 | (set-port-conversion-strategy! p 'substitute) | |
508 | (equal? (list (read-char p) (read-char p) (read-char p)) | |
c62da8f8 LC |
509 | '(#\? #\λ #\μ)))) |
510 | ||
511 | (pass-if "peek-char, wrong encoding, error" | |
512 | (let-syntax ((decoding-error? | |
513 | (syntax-rules () | |
514 | ((_ port exp) | |
515 | (catch 'decoding-error | |
516 | (lambda () | |
517 | (pk 'exp exp) | |
518 | #f) | |
519 | (lambda (key subr message errno p) | |
520 | (eq? p port))))))) | |
521 | (let ((p (with-fluids ((%default-port-encoding "UTF-8")) | |
522 | (open-bytevector-input-port #vu8(255 65 66 67))))) | |
523 | (set-port-conversion-strategy! p 'error) | |
524 | ||
525 | ;; `peek-char' should repeatedly raise an error. | |
526 | (and (decoding-error? p (peek-char p)) | |
527 | (decoding-error? p (peek-char p)) | |
528 | (decoding-error? p (peek-char p)) | |
529 | ||
530 | ;; Move past the error. | |
531 | (decoding-error? p (read-char p)) | |
532 | ||
533 | ;; Finish happily. | |
534 | (equal? '(#\A #\B #\C) | |
535 | (list (read-char p) | |
536 | (read-char p) | |
537 | (read-char p))) | |
538 | (eof-object? (read-char p))))))) | |
2d9e5bca | 539 | |
ee6eedcd KR |
540 | (with-test-prefix "call-with-output-string" |
541 | ||
542 | ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't | |
543 | ;; occur. | |
544 | (pass-if-exception "proc closes port" exception:wrong-type-arg | |
545 | (call-with-output-string close-port))) | |
546 | ||
000ee07f JB |
547 | |
548 | \f | |
549 | ;;;; Soft ports. No tests implemented yet. | |
550 | ||
551 | \f | |
552 | ;;;; Generic operations across all port types. | |
553 | ||
554 | (let ((port-loop-temp (test-file))) | |
555 | ||
556 | ;; Return a list of input ports that all return the same text. | |
557 | ;; We map tests over this list. | |
558 | (define (input-port-list text) | |
559 | ||
560 | ;; Create a text file some of the ports will use. | |
561 | (let ((out-port (open-output-file port-loop-temp))) | |
562 | (display text out-port) | |
563 | (close-port out-port)) | |
564 | ||
565 | (list (open-input-file port-loop-temp) | |
566 | (open-input-pipe (string-append "cat " port-loop-temp)) | |
567 | (call-with-input-string text (lambda (x) x)) | |
568 | ;; We don't test soft ports at the moment. | |
569 | )) | |
570 | ||
571 | (define port-list-names '("file" "pipe" "string")) | |
572 | ||
573 | ;; Test the line counter. | |
73cb0a97 | 574 | (define (test-line-counter text second-line final-column) |
000ee07f JB |
575 | (with-test-prefix "line counter" |
576 | (let ((ports (input-port-list text))) | |
577 | (for-each | |
578 | (lambda (port port-name) | |
579 | (with-test-prefix port-name | |
580 | (pass-if "at beginning of input" | |
581 | (= (port-line port) 0)) | |
582 | (pass-if "read first character" | |
583 | (eqv? (read-char port) #\x)) | |
584 | (pass-if "after reading one character" | |
585 | (= (port-line port) 0)) | |
586 | (pass-if "read first newline" | |
587 | (eqv? (read-char port) #\newline)) | |
588 | (pass-if "after reading first newline char" | |
589 | (= (port-line port) 1)) | |
590 | (pass-if "second line read correctly" | |
591 | (equal? (read-line port) second-line)) | |
592 | (pass-if "read-line increments line number" | |
593 | (= (port-line port) 2)) | |
0b8faa0e JB |
594 | (pass-if "read-line returns EOF" |
595 | (let loop ((i 0)) | |
596 | (cond | |
597 | ((eof-object? (read-line port)) #t) | |
598 | ((> i 20) #f) | |
599 | (else (loop (+ i 1)))))) | |
000ee07f | 600 | (pass-if "line count is 5 at EOF" |
73cb0a97 JB |
601 | (= (port-line port) 5)) |
602 | (pass-if "column is correct at EOF" | |
603 | (= (port-column port) final-column)))) | |
000ee07f JB |
604 | ports port-list-names) |
605 | (for-each close-port ports) | |
606 | (delete-file port-loop-temp)))) | |
607 | ||
57e7f270 DH |
608 | (with-test-prefix "newline" |
609 | (test-line-counter | |
610 | (string-append "x\n" | |
611 | "He who receives an idea from me, receives instruction\n" | |
612 | "himself without lessening mine; as he who lights his\n" | |
613 | "taper at mine, receives light without darkening me.\n" | |
614 | " --- Thomas Jefferson\n") | |
615 | "He who receives an idea from me, receives instruction" | |
616 | 0)) | |
617 | ||
618 | (with-test-prefix "no newline" | |
619 | (test-line-counter | |
620 | (string-append "x\n" | |
621 | "He who receives an idea from me, receives instruction\n" | |
622 | "himself without lessening mine; as he who lights his\n" | |
623 | "taper at mine, receives light without darkening me.\n" | |
624 | " --- Thomas Jefferson\n" | |
625 | "no newline here") | |
626 | "He who receives an idea from me, receives instruction" | |
627 | 15))) | |
5bc1201f | 628 | |
9a8be5a7 MV |
629 | ;; Test port-line and port-column for output ports |
630 | ||
631 | (define (test-output-line-counter text final-column) | |
632 | (with-test-prefix "port-line and port-column for output ports" | |
633 | (let ((port (open-output-string))) | |
634 | (pass-if "at beginning of input" | |
635 | (and (= (port-line port) 0) | |
636 | (= (port-column port) 0))) | |
637 | (write-char #\x port) | |
638 | (pass-if "after writing one character" | |
639 | (and (= (port-line port) 0) | |
640 | (= (port-column port) 1))) | |
641 | (write-char #\newline port) | |
642 | (pass-if "after writing first newline char" | |
643 | (and (= (port-line port) 1) | |
644 | (= (port-column port) 0))) | |
645 | (display text port) | |
646 | (pass-if "line count is 5 at end" | |
647 | (= (port-line port) 5)) | |
648 | (pass-if "column is correct at end" | |
649 | (= (port-column port) final-column))))) | |
650 | ||
651 | (test-output-line-counter | |
652 | (string-append "He who receives an idea from me, receives instruction\n" | |
653 | "himself without lessening mine; as he who lights his\n" | |
654 | "taper at mine, receives light without darkening me.\n" | |
655 | " --- Thomas Jefferson\n" | |
656 | "no newline here") | |
657 | 15) | |
658 | ||
7424deab KR |
659 | (with-test-prefix "port-column" |
660 | ||
661 | (with-test-prefix "output" | |
662 | ||
663 | (pass-if "x" | |
664 | (let ((port (open-output-string))) | |
665 | (display "x" port) | |
666 | (= 1 (port-column port)))) | |
667 | ||
668 | (pass-if "\\a" | |
669 | (let ((port (open-output-string))) | |
670 | (display "\a" port) | |
671 | (= 0 (port-column port)))) | |
672 | ||
673 | (pass-if "x\\a" | |
674 | (let ((port (open-output-string))) | |
675 | (display "x\a" port) | |
676 | (= 1 (port-column port)))) | |
677 | ||
678 | (pass-if "\\x08 backspace" | |
679 | (let ((port (open-output-string))) | |
680 | (display "\x08" port) | |
681 | (= 0 (port-column port)))) | |
682 | ||
683 | (pass-if "x\\x08 backspace" | |
684 | (let ((port (open-output-string))) | |
685 | (display "x\x08" port) | |
686 | (= 0 (port-column port)))) | |
687 | ||
688 | (pass-if "\\n" | |
689 | (let ((port (open-output-string))) | |
690 | (display "\n" port) | |
691 | (= 0 (port-column port)))) | |
692 | ||
693 | (pass-if "x\\n" | |
694 | (let ((port (open-output-string))) | |
695 | (display "x\n" port) | |
696 | (= 0 (port-column port)))) | |
697 | ||
698 | (pass-if "\\r" | |
699 | (let ((port (open-output-string))) | |
700 | (display "\r" port) | |
701 | (= 0 (port-column port)))) | |
702 | ||
703 | (pass-if "x\\r" | |
704 | (let ((port (open-output-string))) | |
705 | (display "x\r" port) | |
706 | (= 0 (port-column port)))) | |
707 | ||
708 | (pass-if "\\t" | |
709 | (let ((port (open-output-string))) | |
710 | (display "\t" port) | |
711 | (= 8 (port-column port)))) | |
712 | ||
713 | (pass-if "x\\t" | |
714 | (let ((port (open-output-string))) | |
715 | (display "x\t" port) | |
716 | (= 8 (port-column port))))) | |
717 | ||
718 | (with-test-prefix "input" | |
719 | ||
720 | (pass-if "x" | |
721 | (let ((port (open-input-string "x"))) | |
722 | (while (not (eof-object? (read-char port)))) | |
723 | (= 1 (port-column port)))) | |
724 | ||
725 | (pass-if "\\a" | |
726 | (let ((port (open-input-string "\a"))) | |
727 | (while (not (eof-object? (read-char port)))) | |
728 | (= 0 (port-column port)))) | |
729 | ||
730 | (pass-if "x\\a" | |
731 | (let ((port (open-input-string "x\a"))) | |
732 | (while (not (eof-object? (read-char port)))) | |
733 | (= 1 (port-column port)))) | |
734 | ||
735 | (pass-if "\\x08 backspace" | |
736 | (let ((port (open-input-string "\x08"))) | |
737 | (while (not (eof-object? (read-char port)))) | |
738 | (= 0 (port-column port)))) | |
739 | ||
740 | (pass-if "x\\x08 backspace" | |
741 | (let ((port (open-input-string "x\x08"))) | |
742 | (while (not (eof-object? (read-char port)))) | |
743 | (= 0 (port-column port)))) | |
744 | ||
745 | (pass-if "\\n" | |
746 | (let ((port (open-input-string "\n"))) | |
747 | (while (not (eof-object? (read-char port)))) | |
748 | (= 0 (port-column port)))) | |
749 | ||
750 | (pass-if "x\\n" | |
751 | (let ((port (open-input-string "x\n"))) | |
752 | (while (not (eof-object? (read-char port)))) | |
753 | (= 0 (port-column port)))) | |
754 | ||
755 | (pass-if "\\r" | |
756 | (let ((port (open-input-string "\r"))) | |
757 | (while (not (eof-object? (read-char port)))) | |
758 | (= 0 (port-column port)))) | |
759 | ||
760 | (pass-if "x\\r" | |
761 | (let ((port (open-input-string "x\r"))) | |
762 | (while (not (eof-object? (read-char port)))) | |
763 | (= 0 (port-column port)))) | |
764 | ||
765 | (pass-if "\\t" | |
766 | (let ((port (open-input-string "\t"))) | |
767 | (while (not (eof-object? (read-char port)))) | |
768 | (= 8 (port-column port)))) | |
769 | ||
770 | (pass-if "x\\t" | |
771 | (let ((port (open-input-string "x\t"))) | |
772 | (while (not (eof-object? (read-char port)))) | |
773 | (= 8 (port-column port)))))) | |
774 | ||
004be623 KR |
775 | (with-test-prefix "port-line" |
776 | ||
777 | ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas | |
778 | ;; scm_t_port actually holds a long; this restricted the range on 64-bit | |
779 | ;; systems | |
780 | (pass-if "set most-positive-fixnum/2" | |
781 | (let ((n (quotient most-positive-fixnum 2)) | |
782 | (port (open-output-string))) | |
783 | (set-port-line! port n) | |
784 | (eqv? n (port-line port))))) | |
785 | ||
064c27c4 LC |
786 | (with-test-prefix "port-encoding" |
787 | ||
788 | (pass-if-exception "set-port-encoding!, wrong encoding" | |
789 | exception:miscellaneous-error | |
790 | (set-port-encoding! (open-input-string "") "does-not-exist")) | |
791 | ||
792 | (pass-if-exception "%default-port-encoding, wrong encoding" | |
793 | exception:miscellaneous-error | |
794 | (read (with-fluids ((%default-port-encoding "does-not-exist")) | |
795 | (open-input-string ""))))) | |
796 | ||
256f34e7 KR |
797 | ;;; |
798 | ;;; port-for-each | |
799 | ;;; | |
800 | ||
801 | (with-test-prefix "port-for-each" | |
802 | ||
803 | ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to | |
804 | ;; its iterator func if a port was inaccessible in the last gc mark but | |
805 | ;; the lazy sweeping has not yet reached it to remove it from the port | |
806 | ;; table (scm_i_port_table). Provoking those gc conditions is a little | |
807 | ;; tricky, but the following code made it happen in 1.8.2. | |
808 | (pass-if "passing freed cell" | |
256f34e7 KR |
809 | (let ((lst '())) |
810 | ;; clear out the heap | |
811 | (gc) (gc) (gc) | |
812 | ;; allocate cells so the opened ports aren't at the start of the heap | |
813 | (make-list 1000) | |
814 | (open-input-file "/dev/null") | |
815 | (make-list 1000) | |
816 | (open-input-file "/dev/null") | |
817 | ;; this gc leaves the above ports unmarked, ie. inaccessible | |
818 | (gc) | |
819 | ;; but they're still in the port table, so this sees them | |
820 | (port-for-each (lambda (port) | |
821 | (set! lst (cons port lst)))) | |
822 | ;; this forces completion of the sweeping | |
823 | (gc) (gc) (gc) | |
824 | ;; and (if the bug is present) the cells accumulated in LST are now | |
825 | ;; freed cells, which give #f from `port?' | |
826 | (not (memq #f (map port? lst)))))) | |
827 | ||
e9966dbb HWN |
828 | (with-test-prefix |
829 | "fdes->port" | |
830 | (pass-if "fdes->ports finds port" | |
831 | (let ((port (open-file (test-file) "w"))) | |
832 | ||
833 | (not (not (memq port (fdes->ports (port->fdes port)))))))) | |
834 | ||
8ab3d8a0 KR |
835 | ;;; |
836 | ;;; seek | |
837 | ;;; | |
838 | ||
839 | (with-test-prefix "seek" | |
840 | ||
841 | (with-test-prefix "file port" | |
842 | ||
843 | (pass-if "SEEK_CUR" | |
844 | (call-with-output-file (test-file) | |
845 | (lambda (port) | |
846 | (display "abcde" port))) | |
847 | (let ((port (open-file (test-file) "r"))) | |
848 | (read-char port) | |
849 | (seek port 2 SEEK_CUR) | |
850 | (eqv? #\d (read-char port)))) | |
851 | ||
852 | (pass-if "SEEK_SET" | |
853 | (call-with-output-file (test-file) | |
854 | (lambda (port) | |
855 | (display "abcde" port))) | |
856 | (let ((port (open-file (test-file) "r"))) | |
857 | (read-char port) | |
858 | (seek port 3 SEEK_SET) | |
859 | (eqv? #\d (read-char port)))) | |
860 | ||
861 | (pass-if "SEEK_END" | |
862 | (call-with-output-file (test-file) | |
863 | (lambda (port) | |
864 | (display "abcde" port))) | |
865 | (let ((port (open-file (test-file) "r"))) | |
866 | (read-char port) | |
867 | (seek port -2 SEEK_END) | |
868 | (eqv? #\d (read-char port)))))) | |
869 | ||
6e7d5622 KR |
870 | ;;; |
871 | ;;; truncate-file | |
872 | ;;; | |
873 | ||
874 | (with-test-prefix "truncate-file" | |
875 | ||
8ab3d8a0 KR |
876 | (pass-if-exception "flonum file" exception:wrong-type-arg |
877 | (truncate-file 1.0 123)) | |
878 | ||
879 | (pass-if-exception "frac file" exception:wrong-type-arg | |
880 | (truncate-file 7/3 123)) | |
881 | ||
6e7d5622 KR |
882 | (with-test-prefix "filename" |
883 | ||
8ab3d8a0 KR |
884 | (pass-if-exception "flonum length" exception:wrong-type-arg |
885 | (call-with-output-file (test-file) | |
886 | (lambda (port) | |
887 | (display "hello" port))) | |
888 | (truncate-file (test-file) 1.0)) | |
889 | ||
6e7d5622 KR |
890 | (pass-if "shorten" |
891 | (call-with-output-file (test-file) | |
892 | (lambda (port) | |
893 | (display "hello" port))) | |
894 | (truncate-file (test-file) 1) | |
8ab3d8a0 KR |
895 | (eqv? 1 (stat:size (stat (test-file))))) |
896 | ||
897 | (pass-if-exception "shorten to current pos" exception:miscellaneous-error | |
898 | (call-with-output-file (test-file) | |
899 | (lambda (port) | |
900 | (display "hello" port))) | |
901 | (truncate-file (test-file)))) | |
6e7d5622 KR |
902 | |
903 | (with-test-prefix "file descriptor" | |
904 | ||
905 | (pass-if "shorten" | |
906 | (call-with-output-file (test-file) | |
907 | (lambda (port) | |
908 | (display "hello" port))) | |
909 | (let ((fd (open-fdes (test-file) O_RDWR))) | |
910 | (truncate-file fd 1) | |
911 | (close-fdes fd)) | |
8ab3d8a0 KR |
912 | (eqv? 1 (stat:size (stat (test-file))))) |
913 | ||
914 | (pass-if "shorten to current pos" | |
915 | (call-with-output-file (test-file) | |
916 | (lambda (port) | |
917 | (display "hello" port))) | |
918 | (let ((fd (open-fdes (test-file) O_RDWR))) | |
919 | (seek fd 1 SEEK_SET) | |
920 | (truncate-file fd) | |
921 | (close-fdes fd)) | |
6e7d5622 KR |
922 | (eqv? 1 (stat:size (stat (test-file)))))) |
923 | ||
924 | (with-test-prefix "file port" | |
925 | ||
926 | (pass-if "shorten" | |
927 | (call-with-output-file (test-file) | |
928 | (lambda (port) | |
929 | (display "hello" port))) | |
930 | (let ((port (open-file (test-file) "r+"))) | |
931 | (truncate-file port 1)) | |
8ab3d8a0 KR |
932 | (eqv? 1 (stat:size (stat (test-file))))) |
933 | ||
934 | (pass-if "shorten to current pos" | |
935 | (call-with-output-file (test-file) | |
936 | (lambda (port) | |
937 | (display "hello" port))) | |
938 | (let ((port (open-file (test-file) "r+"))) | |
939 | (read-char port) | |
940 | (truncate-file port)) | |
6e7d5622 KR |
941 | (eqv? 1 (stat:size (stat (test-file))))))) |
942 | ||
7424deab | 943 | |
5bc1201f JB |
944 | ;;;; testing read-delimited and friends |
945 | ||
946 | (with-test-prefix "read-delimited!" | |
947 | (let ((c (make-string 20 #\!))) | |
948 | (call-with-input-string | |
949 | "defdef\nghighi\n" | |
950 | (lambda (port) | |
951 | ||
952 | (read-delimited! "\n" c port 'concat) | |
953 | (pass-if "read-delimited! reads a first line" | |
954 | (string=? c "defdef\n!!!!!!!!!!!!!")) | |
955 | ||
956 | (read-delimited! "\n" c port 'concat 3) | |
957 | (pass-if "read-delimited! reads a first line" | |
958 | (string=? c "defghighi\n!!!!!!!!!!")))))) | |
1b054952 JB |
959 | |
960 | \f | |
961 | ;;;; char-ready? | |
962 | ||
963 | (call-with-input-string | |
964 | "howdy" | |
965 | (lambda (port) | |
966 | (pass-if "char-ready? returns true on string port" | |
967 | (char-ready? port)))) | |
968 | ||
969 | ;;; This segfaults on some versions of Guile. We really should run | |
970 | ;;; the tests in a subprocess... | |
971 | ||
972 | (call-with-input-string | |
973 | "howdy" | |
974 | (lambda (port) | |
975 | (with-input-from-port | |
976 | port | |
977 | (lambda () | |
978 | (pass-if "char-ready? returns true on string port as default port" | |
979 | (char-ready?)))))) | |
fe5b6beb JB |
980 | |
981 | \f | |
982 | ;;;; Close current-input-port, and make sure everyone can handle it. | |
983 | ||
984 | (with-test-prefix "closing current-input-port" | |
985 | (for-each (lambda (procedure name) | |
986 | (with-input-from-port | |
987 | (call-with-input-string "foo" (lambda (p) p)) | |
988 | (lambda () | |
989 | (close-port (current-input-port)) | |
6b4113af DH |
990 | (pass-if-exception name |
991 | exception:wrong-type-arg | |
992 | (procedure))))) | |
fe5b6beb JB |
993 | (list read read-char read-line) |
994 | '("read" "read-char" "read-line"))) | |
c56c0f79 MV |
995 | |
996 | (delete-file (test-file)) |