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 | 4 | ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, |
37b14530 | 5 | ;;;; 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
2e59af21 | 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 | 26 | #:use-module (rnrs bytevectors) |
7f6c3f8f MW |
27 | #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port |
28 | open-bytevector-output-port | |
29 | put-bytevector | |
30 | get-bytevector-n | |
31 | get-bytevector-all | |
32 | unget-bytevector))) | |
000ee07f JB |
33 | |
34 | (define (display-line . args) | |
35 | (for-each display args) | |
36 | (newline)) | |
37 | ||
38 | (define (test-file) | |
c685b42f | 39 | (data-file-name "ports-test.tmp")) |
000ee07f JB |
40 | |
41 | \f | |
42 | ;;;; Some general utilities for testing ports. | |
43 | ||
d6a6989e LC |
44 | ;; Make sure we are set up for 8-bit Latin-1 data. |
45 | (fluid-set! %default-port-encoding "ISO-8859-1") | |
46 | (for-each (lambda (p) | |
47 | (set-port-encoding! p (fluid-ref %default-port-encoding))) | |
48 | (list (current-input-port) (current-output-port) | |
49 | (current-error-port))) | |
889975e5 | 50 | |
000ee07f JB |
51 | ;;; Read from PORT until EOF, and return the result as a string. |
52 | (define (read-all port) | |
53 | (let loop ((chars '())) | |
54 | (let ((char (read-char port))) | |
55 | (if (eof-object? char) | |
8c6b62e7 EZ |
56 | (list->string (reverse! chars)) |
57 | (loop (cons char chars)))))) | |
000ee07f JB |
58 | |
59 | (define (read-file filename) | |
60 | (let* ((port (open-input-file filename)) | |
8c6b62e7 | 61 | (string (read-all port))) |
000ee07f JB |
62 | (close-port port) |
63 | string)) | |
64 | ||
65 | \f | |
b22e94db LC |
66 | |
67 | (with-test-prefix "%default-port-conversion-strategy" | |
68 | ||
69 | (pass-if "initial value" | |
70 | (eq? 'substitute (fluid-ref %default-port-conversion-strategy))) | |
71 | ||
72 | (pass-if "file port" | |
73 | (let ((strategies '(error substitute escape))) | |
74 | (equal? (map (lambda (s) | |
75 | (with-fluids ((%default-port-conversion-strategy s)) | |
76 | (call-with-output-file "/dev/null" | |
77 | (lambda (p) | |
78 | (port-conversion-strategy p))))) | |
79 | strategies) | |
80 | strategies))) | |
81 | ||
82 | (pass-if "(set-port-conversion-strategy! #f sym)" | |
83 | (begin | |
84 | (set-port-conversion-strategy! #f 'error) | |
85 | (and (eq? (fluid-ref %default-port-conversion-strategy) 'error) | |
86 | (begin | |
87 | (set-port-conversion-strategy! #f 'substitute) | |
88 | (eq? (fluid-ref %default-port-conversion-strategy) | |
89 | 'substitute))))) | |
90 | ||
91 | ) | |
92 | ||
93 | \f | |
000ee07f JB |
94 | ;;;; Normal file ports. |
95 | ||
96 | ;;; Write out an s-expression, and read it back. | |
57e7f270 | 97 | (let ((string '("From fairest creatures we desire increase," |
8c6b62e7 | 98 | "That thereby beauty's rose might never die,")) |
57e7f270 DH |
99 | (filename (test-file))) |
100 | (let ((port (open-output-file filename))) | |
101 | (write string port) | |
102 | (close-port port)) | |
103 | (let ((port (open-input-file filename))) | |
104 | (let ((in-string (read port))) | |
105 | (pass-if "file: write and read back list of strings" | |
8c6b62e7 | 106 | (equal? string in-string))) |
57e7f270 DH |
107 | (close-port port)) |
108 | (delete-file filename)) | |
c53b5d89 | 109 | |
000ee07f | 110 | ;;; Write out a string, and read it back a character at a time. |
57e7f270 DH |
111 | (let ((string "This is a test string\nwith no newline at the end") |
112 | (filename (test-file))) | |
113 | (let ((port (open-output-file filename))) | |
114 | (display string port) | |
115 | (close-port port)) | |
116 | (let ((in-string (read-file filename))) | |
117 | (pass-if "file: write and read back characters" | |
8c6b62e7 | 118 | (equal? string in-string))) |
57e7f270 | 119 | (delete-file filename)) |
000ee07f | 120 | |
7c035009 | 121 | ;;; Buffered input/output port with seeking. |
57e7f270 DH |
122 | (let* ((filename (test-file)) |
123 | (port (open-file filename "w+"))) | |
124 | (display "J'Accuse" port) | |
125 | (seek port -1 SEEK_CUR) | |
126 | (pass-if "file: r/w 1" | |
8c6b62e7 | 127 | (char=? (read-char port) #\e)) |
57e7f270 | 128 | (pass-if "file: r/w 2" |
8c6b62e7 | 129 | (eof-object? (read-char port))) |
57e7f270 DH |
130 | (seek port -1 SEEK_CUR) |
131 | (write-char #\x port) | |
132 | (seek port 7 SEEK_SET) | |
133 | (pass-if "file: r/w 3" | |
8c6b62e7 | 134 | (char=? (read-char port) #\x)) |
57e7f270 DH |
135 | (seek port -2 SEEK_END) |
136 | (pass-if "file: r/w 4" | |
8c6b62e7 | 137 | (char=? (read-char port) #\s)) |
8f99e3f3 | 138 | (close-port port) |
57e7f270 | 139 | (delete-file filename)) |
7c035009 GH |
140 | |
141 | ;;; Unbuffered input/output port with seeking. | |
57e7f270 DH |
142 | (let* ((filename (test-file)) |
143 | (port (open-file filename "w+0"))) | |
144 | (display "J'Accuse" port) | |
145 | (seek port -1 SEEK_CUR) | |
146 | (pass-if "file: ub r/w 1" | |
8c6b62e7 | 147 | (char=? (read-char port) #\e)) |
57e7f270 | 148 | (pass-if "file: ub r/w 2" |
8c6b62e7 | 149 | (eof-object? (read-char port))) |
57e7f270 DH |
150 | (seek port -1 SEEK_CUR) |
151 | (write-char #\x port) | |
152 | (seek port 7 SEEK_SET) | |
153 | (pass-if "file: ub r/w 3" | |
8c6b62e7 | 154 | (char=? (read-char port) #\x)) |
57e7f270 DH |
155 | (seek port -2 SEEK_END) |
156 | (pass-if "file: ub r/w 4" | |
8c6b62e7 | 157 | (char=? (read-char port) #\s)) |
8f99e3f3 | 158 | (close-port port) |
57e7f270 | 159 | (delete-file filename)) |
7c035009 | 160 | |
4fcd6551 | 161 | ;;; Buffered output-only and input-only ports with seeking. |
57e7f270 DH |
162 | (let* ((filename (test-file)) |
163 | (port (open-output-file filename))) | |
164 | (display "J'Accuse" port) | |
165 | (pass-if "file: out tell" | |
8c6b62e7 | 166 | (= (seek port 0 SEEK_CUR) 8)) |
57e7f270 DH |
167 | (seek port -1 SEEK_CUR) |
168 | (write-char #\x port) | |
169 | (close-port port) | |
170 | (let ((iport (open-input-file filename))) | |
171 | (pass-if "file: in tell 0" | |
8c6b62e7 | 172 | (= (seek iport 0 SEEK_CUR) 0)) |
57e7f270 DH |
173 | (read-char iport) |
174 | (pass-if "file: in tell 1" | |
8c6b62e7 | 175 | (= (seek iport 0 SEEK_CUR) 1)) |
57e7f270 DH |
176 | (unread-char #\z iport) |
177 | (pass-if "file: in tell 0 after unread" | |
8c6b62e7 | 178 | (= (seek iport 0 SEEK_CUR) 0)) |
57e7f270 | 179 | (pass-if "file: unread char still there" |
8c6b62e7 | 180 | (char=? (read-char iport) #\z)) |
57e7f270 DH |
181 | (seek iport 7 SEEK_SET) |
182 | (pass-if "file: in last char" | |
8c6b62e7 | 183 | (char=? (read-char iport) #\x)) |
57e7f270 DH |
184 | (close-port iport)) |
185 | (delete-file filename)) | |
4fcd6551 | 186 | |
7f214e60 | 187 | ;;; unusual characters. |
57e7f270 DH |
188 | (let* ((filename (test-file)) |
189 | (port (open-output-file filename))) | |
190 | (display (string #\nul (integer->char 255) (integer->char 128) | |
8c6b62e7 | 191 | #\nul) port) |
57e7f270 DH |
192 | (close-port port) |
193 | (let* ((port (open-input-file filename)) | |
8c6b62e7 | 194 | (line (read-line port))) |
57e7f270 | 195 | (pass-if "file: read back NUL 1" |
8c6b62e7 | 196 | (char=? (string-ref line 0) #\nul)) |
57e7f270 | 197 | (pass-if "file: read back 255" |
8c6b62e7 | 198 | (char=? (string-ref line 1) (integer->char 255))) |
57e7f270 | 199 | (pass-if "file: read back 128" |
8c6b62e7 | 200 | (char=? (string-ref line 2) (integer->char 128))) |
57e7f270 | 201 | (pass-if "file: read back NUL 2" |
8c6b62e7 | 202 | (char=? (string-ref line 3) #\nul)) |
57e7f270 | 203 | (pass-if "file: EOF" |
8c6b62e7 | 204 | (eof-object? (read-char port))) |
8f99e3f3 | 205 | (close-port port)) |
57e7f270 | 206 | (delete-file filename)) |
7f214e60 | 207 | |
0eb2e8cd | 208 | ;;; line buffering mode. |
57e7f270 DH |
209 | (let* ((filename (test-file)) |
210 | (port (open-file filename "wl")) | |
211 | (test-string "one line more or less")) | |
212 | (write-line test-string port) | |
213 | (let* ((in-port (open-input-file filename)) | |
8c6b62e7 | 214 | (line (read-line in-port))) |
57e7f270 DH |
215 | (close-port in-port) |
216 | (close-port port) | |
217 | (pass-if "file: line buffering" | |
8c6b62e7 | 218 | (string=? line test-string))) |
57e7f270 | 219 | (delete-file filename)) |
0eb2e8cd | 220 | |
e50d921b MG |
221 | ;;; read-line should use the port encoding (not the locale encoding). |
222 | (let ((str "ĉu bone?")) | |
211683cc MG |
223 | (with-locale "C" |
224 | (let* ((filename (test-file)) | |
225 | (port (open-file filename "wl"))) | |
226 | (set-port-encoding! port "UTF-8") | |
227 | (write-line str port) | |
228 | (let ((in-port (open-input-file filename))) | |
229 | (set-port-encoding! in-port "UTF-8") | |
230 | (let ((line (read-line in-port))) | |
231 | (close-port in-port) | |
232 | (close-port port) | |
233 | (pass-if "file: read-line honors port encoding" | |
234 | (string=? line str)))) | |
235 | (delete-file filename)))) | |
236 | ||
237 | ;;; binary mode ignores port encoding | |
238 | (pass-if "file: binary mode ignores port encoding" | |
239 | (with-fluids ((%default-port-encoding "UTF-8")) | |
240 | (let* ((filename (test-file)) | |
241 | (port (open-file filename "w")) | |
242 | (test-string "一二三") | |
243 | (binary-test-string | |
244 | (apply string | |
245 | (map integer->char | |
fb7dd001 | 246 | (array->list |
211683cc MG |
247 | (string->utf8 test-string)))))) |
248 | (write-line test-string port) | |
249 | (close-port port) | |
250 | (let* ((in-port (open-file filename "rb")) | |
251 | (line (read-line in-port))) | |
252 | (close-port in-port) | |
253 | (delete-file filename) | |
254 | (string=? line binary-test-string))))) | |
255 | ||
256 | ;;; binary mode ignores file coding declaration | |
257 | (pass-if "file: binary mode ignores file coding declaration" | |
258 | (with-fluids ((%default-port-encoding "UTF-8")) | |
259 | (let* ((filename (test-file)) | |
260 | (port (open-file filename "w")) | |
261 | (test-string "一二三") | |
262 | (binary-test-string | |
263 | (apply string | |
264 | (map integer->char | |
fb7dd001 | 265 | (array->list |
211683cc MG |
266 | (string->utf8 test-string)))))) |
267 | (write-line ";; coding: utf-8" port) | |
268 | (write-line test-string port) | |
269 | (close-port port) | |
270 | (let* ((in-port (open-file filename "rb")) | |
271 | (line1 (read-line in-port)) | |
272 | (line2 (read-line in-port))) | |
273 | (close-port in-port) | |
274 | (delete-file filename) | |
275 | (string=? line2 binary-test-string))))) | |
276 | ||
3ace9a8e MW |
277 | ;; open-file ignores file coding declaration by default |
278 | (pass-if "file: open-file ignores coding declaration by default" | |
211683cc MG |
279 | (with-fluids ((%default-port-encoding "UTF-8")) |
280 | (let* ((filename (test-file)) | |
281 | (port (open-output-file filename)) | |
282 | (test-string "€100")) | |
211683cc MG |
283 | (write-line ";; coding: iso-8859-15" port) |
284 | (write-line test-string port) | |
285 | (close-port port) | |
286 | (let* ((in-port (open-input-file filename)) | |
287 | (line1 (read-line in-port)) | |
288 | (line2 (read-line in-port))) | |
289 | (close-port in-port) | |
290 | (delete-file filename) | |
291 | (string=? line2 test-string))))) | |
e50d921b | 292 | |
3ace9a8e MW |
293 | ;; open-input-file with guess-encoding honors coding declaration |
294 | (pass-if "file: open-input-file with guess-encoding honors coding declaration" | |
295 | (with-fluids ((%default-port-encoding "UTF-8")) | |
296 | (let* ((filename (test-file)) | |
297 | (port (open-output-file filename)) | |
298 | (test-string "€100")) | |
299 | (set-port-encoding! port "iso-8859-15") | |
300 | (write-line ";; coding: iso-8859-15" port) | |
301 | (write-line test-string port) | |
302 | (close-port port) | |
303 | (let* ((in-port (open-input-file filename | |
304 | #:guess-encoding #t)) | |
305 | (line1 (read-line in-port)) | |
306 | (line2 (read-line in-port))) | |
307 | (close-port in-port) | |
308 | (delete-file filename) | |
309 | (string=? line2 test-string))))) | |
310 | ||
37b14530 LC |
311 | (pass-if-exception "invalid wide mode string" |
312 | exception:out-of-range | |
313 | (open-file "/dev/null" "λ")) | |
314 | ||
315 | (pass-if "valid wide mode string" | |
316 | ;; Pass 'open-file' a valid mode string, but as a wide string. | |
317 | (let ((mode "λ")) | |
318 | (string-set! mode 0 #\r) | |
319 | (let ((port (open-file "/dev/null" mode))) | |
320 | (and (input-port? port) | |
321 | (begin | |
322 | (close-port port) | |
323 | #t))))) | |
324 | ||
3ace9a8e MW |
325 | (with-test-prefix "keyword arguments for file openers" |
326 | (with-fluids ((%default-port-encoding "UTF-8")) | |
327 | (let ((filename (test-file))) | |
328 | ||
329 | (with-test-prefix "write #:encoding" | |
330 | ||
331 | (pass-if-equal "open-file" | |
332 | #vu8(116 0 101 0 115 0 116 0) | |
333 | (let ((port (open-file filename "w" | |
334 | #:encoding "UTF-16LE"))) | |
335 | (display "test" port) | |
336 | (close-port port)) | |
337 | (let* ((port (open-file filename "rb")) | |
338 | (bv (get-bytevector-all port))) | |
339 | (close-port port) | |
340 | bv)) | |
341 | ||
342 | (pass-if-equal "open-output-file" | |
343 | #vu8(116 0 101 0 115 0 116 0) | |
344 | (let ((port (open-output-file filename | |
345 | #:encoding "UTF-16LE"))) | |
346 | (display "test" port) | |
347 | (close-port port)) | |
348 | (let* ((port (open-file filename "rb")) | |
349 | (bv (get-bytevector-all port))) | |
350 | (close-port port) | |
351 | bv)) | |
352 | ||
353 | (pass-if-equal "call-with-output-file" | |
354 | #vu8(116 0 101 0 115 0 116 0) | |
355 | (call-with-output-file filename | |
356 | (lambda (port) | |
357 | (display "test" port)) | |
358 | #:encoding "UTF-16LE") | |
359 | (let* ((port (open-file filename "rb")) | |
360 | (bv (get-bytevector-all port))) | |
361 | (close-port port) | |
362 | bv)) | |
363 | ||
364 | (pass-if-equal "with-output-to-file" | |
365 | #vu8(116 0 101 0 115 0 116 0) | |
366 | (with-output-to-file filename | |
367 | (lambda () | |
368 | (display "test")) | |
369 | #:encoding "UTF-16LE") | |
370 | (let* ((port (open-file filename "rb")) | |
371 | (bv (get-bytevector-all port))) | |
372 | (close-port port) | |
373 | bv)) | |
374 | ||
375 | (pass-if-equal "with-error-to-file" | |
376 | #vu8(116 0 101 0 115 0 116 0) | |
377 | (with-error-to-file | |
378 | filename | |
379 | (lambda () | |
380 | (display "test" (current-error-port))) | |
381 | #:encoding "UTF-16LE") | |
382 | (let* ((port (open-file filename "rb")) | |
383 | (bv (get-bytevector-all port))) | |
384 | (close-port port) | |
385 | bv))) | |
386 | ||
387 | (with-test-prefix "write #:binary" | |
388 | ||
389 | (pass-if-equal "open-output-file" | |
390 | "ISO-8859-1" | |
391 | (let* ((port (open-output-file filename #:binary #t)) | |
392 | (enc (port-encoding port))) | |
393 | (close-port port) | |
394 | enc)) | |
395 | ||
396 | (pass-if-equal "call-with-output-file" | |
397 | "ISO-8859-1" | |
398 | (call-with-output-file filename port-encoding #:binary #t)) | |
399 | ||
400 | (pass-if-equal "with-output-to-file" | |
401 | "ISO-8859-1" | |
402 | (with-output-to-file filename | |
403 | (lambda () (port-encoding (current-output-port))) | |
404 | #:binary #t)) | |
405 | ||
406 | (pass-if-equal "with-error-to-file" | |
407 | "ISO-8859-1" | |
408 | (with-error-to-file | |
409 | filename | |
410 | (lambda () (port-encoding (current-error-port))) | |
411 | #:binary #t))) | |
412 | ||
413 | (with-test-prefix "read #:encoding" | |
414 | ||
415 | (pass-if-equal "open-file read #:encoding" | |
416 | "test" | |
417 | (call-with-output-file filename | |
418 | (lambda (port) | |
419 | (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) | |
420 | (let* ((port (open-file filename "r" #:encoding "UTF-16LE")) | |
421 | (str (read-string port))) | |
422 | (close-port port) | |
423 | str)) | |
424 | ||
425 | (pass-if-equal "open-input-file #:encoding" | |
426 | "test" | |
427 | (call-with-output-file filename | |
428 | (lambda (port) | |
429 | (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) | |
430 | (let* ((port (open-input-file filename #:encoding "UTF-16LE")) | |
431 | (str (read-string port))) | |
432 | (close-port port) | |
433 | str)) | |
434 | ||
435 | (pass-if-equal "call-with-input-file #:encoding" | |
436 | "test" | |
437 | (call-with-output-file filename | |
438 | (lambda (port) | |
439 | (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) | |
440 | (call-with-input-file filename | |
441 | read-string | |
442 | #:encoding "UTF-16LE")) | |
443 | ||
444 | (pass-if-equal "with-input-from-file #:encoding" | |
445 | "test" | |
446 | (call-with-output-file filename | |
447 | (lambda (port) | |
448 | (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) | |
449 | (with-input-from-file filename | |
450 | read-string | |
451 | #:encoding "UTF-16LE"))) | |
452 | ||
453 | (with-test-prefix "read #:binary" | |
454 | ||
455 | (pass-if-equal "open-input-file" | |
456 | "ISO-8859-1" | |
457 | (let* ((port (open-input-file filename #:binary #t)) | |
458 | (enc (port-encoding port))) | |
459 | (close-port port) | |
460 | enc)) | |
461 | ||
462 | (pass-if-equal "call-with-input-file" | |
463 | "ISO-8859-1" | |
464 | (call-with-input-file filename port-encoding #:binary #t)) | |
465 | ||
466 | (pass-if-equal "with-input-from-file" | |
467 | "ISO-8859-1" | |
468 | (with-input-from-file filename | |
469 | (lambda () (port-encoding (current-input-port))) | |
470 | #:binary #t))) | |
471 | ||
472 | (with-test-prefix "#:guess-encoding with coding declaration" | |
473 | ||
474 | (pass-if-equal "open-file" | |
475 | "€100" | |
476 | (with-output-to-file filename | |
477 | (lambda () | |
478 | (write-line "test") | |
479 | (write-line "; coding: ISO-8859-15") | |
480 | (write-line "€100")) | |
481 | #:encoding "ISO-8859-15") | |
482 | (let* ((port (open-file filename "r" | |
483 | #:guess-encoding #t | |
484 | #:encoding "UTF-16LE")) | |
485 | (str (begin (read-line port) | |
486 | (read-line port) | |
487 | (read-line port)))) | |
488 | (close-port port) | |
489 | str)) | |
490 | ||
491 | (pass-if-equal "open-input-file" | |
492 | "€100" | |
493 | (with-output-to-file filename | |
494 | (lambda () | |
495 | (write-line "test") | |
496 | (write-line "; coding: ISO-8859-15") | |
497 | (write-line "€100")) | |
498 | #:encoding "ISO-8859-15") | |
499 | (let* ((port (open-input-file filename | |
500 | #:guess-encoding #t | |
501 | #:encoding "UTF-16LE")) | |
502 | (str (begin (read-line port) | |
503 | (read-line port) | |
504 | (read-line port)))) | |
505 | (close-port port) | |
506 | str)) | |
507 | ||
508 | (pass-if-equal "call-with-input-file" | |
509 | "€100" | |
510 | (with-output-to-file filename | |
511 | (lambda () | |
512 | (write-line "test") | |
513 | (write-line "; coding: ISO-8859-15") | |
514 | (write-line "€100")) | |
515 | #:encoding "ISO-8859-15") | |
516 | (call-with-input-file filename | |
517 | (lambda (port) | |
518 | (read-line port) | |
519 | (read-line port) | |
520 | (read-line port)) | |
521 | #:guess-encoding #t | |
522 | #:encoding "UTF-16LE")) | |
523 | ||
524 | (pass-if-equal "with-input-from-file" | |
525 | "€100" | |
526 | (with-output-to-file filename | |
527 | (lambda () | |
528 | (write-line "test") | |
529 | (write-line "; coding: ISO-8859-15") | |
530 | (write-line "€100")) | |
531 | #:encoding "ISO-8859-15") | |
532 | (with-input-from-file filename | |
533 | (lambda () | |
534 | (read-line) | |
535 | (read-line) | |
536 | (read-line)) | |
537 | #:guess-encoding #t | |
538 | #:encoding "UTF-16LE"))) | |
539 | ||
540 | (with-test-prefix "#:guess-encoding without coding declaration" | |
541 | ||
542 | (pass-if-equal "open-file" | |
543 | "€100" | |
544 | (with-output-to-file filename | |
545 | (lambda () (write-line "€100")) | |
546 | #:encoding "ISO-8859-15") | |
547 | (let* ((port (open-file filename "r" | |
548 | #:guess-encoding #t | |
549 | #:encoding "ISO-8859-15")) | |
550 | (str (read-line port))) | |
551 | (close-port port) | |
552 | str)) | |
553 | ||
554 | (pass-if-equal "open-input-file" | |
555 | "€100" | |
556 | (with-output-to-file filename | |
557 | (lambda () (write-line "€100")) | |
558 | #:encoding "ISO-8859-15") | |
559 | (let* ((port (open-input-file filename | |
560 | #:guess-encoding #t | |
561 | #:encoding "ISO-8859-15")) | |
562 | (str (read-line port))) | |
563 | (close-port port) | |
564 | str)) | |
565 | ||
566 | (pass-if-equal "call-with-input-file" | |
567 | "€100" | |
568 | (with-output-to-file filename | |
569 | (lambda () (write-line "€100")) | |
570 | #:encoding "ISO-8859-15") | |
571 | (call-with-input-file filename | |
572 | read-line | |
573 | #:guess-encoding #t | |
574 | #:encoding "ISO-8859-15")) | |
575 | ||
576 | (pass-if-equal "with-input-from-file" | |
577 | "€100" | |
578 | (with-output-to-file filename | |
579 | (lambda () (write-line "€100")) | |
580 | #:encoding "ISO-8859-15") | |
581 | (with-input-from-file filename | |
582 | read-line | |
583 | #:guess-encoding #t | |
584 | #:encoding "ISO-8859-15"))) | |
585 | ||
586 | (delete-file filename)))) | |
587 | ||
d1b143e9 | 588 | ;;; ungetting characters and strings. |
57e7f270 | 589 | (with-input-from-string "walk on the moon\nmoon" |
8c6b62e7 EZ |
590 | (lambda () |
591 | (read-char) | |
592 | (unread-char #\a (current-input-port)) | |
593 | (pass-if "unread-char" | |
594 | (char=? (read-char) #\a)) | |
595 | (read-line) | |
596 | (let ((replacenoid "chicken enchilada")) | |
597 | (unread-char #\newline (current-input-port)) | |
598 | (unread-string replacenoid (current-input-port)) | |
599 | (pass-if "unread-string" | |
600 | (string=? (read-line) replacenoid))) | |
601 | (pass-if "unread residue" | |
602 | (string=? (read-line) "moon")))) | |
d1b143e9 | 603 | |
6e822cce | 604 | ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on |
8cc58ec1 GH |
605 | ;;; the reading end. try to read a byte: should get EAGAIN or |
606 | ;;; EWOULDBLOCK error. | |
57e7f270 DH |
607 | (let* ((p (pipe)) |
608 | (r (car p))) | |
609 | (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) | |
610 | (pass-if "non-blocking-I/O" | |
8c6b62e7 EZ |
611 | (catch 'system-error |
612 | (lambda () (read-char r) #f) | |
613 | (lambda (key . args) | |
614 | (and (eq? key 'system-error) | |
615 | (let ((errno (car (list-ref args 3)))) | |
616 | (or (= errno EAGAIN) | |
617 | (= errno EWOULDBLOCK)))))))) | |
22d35615 | 618 | |
000ee07f | 619 | \f |
6e822cce | 620 | ;;;; Pipe (popen) ports. |
000ee07f JB |
621 | |
622 | ;;; Run a command, and read its output. | |
57e7f270 DH |
623 | (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) |
624 | (in-string (read-all pipe))) | |
625 | (close-pipe pipe) | |
626 | (pass-if "pipe: read" | |
8c6b62e7 | 627 | (equal? in-string "Howdy there, partner!\n"))) |
000ee07f JB |
628 | |
629 | ;;; Run a command, send some output to it, and see if it worked. | |
57e7f270 DH |
630 | (let* ((filename (test-file)) |
631 | (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) | |
632 | (display "Now Jimmy lives on a mushroom cloud\n" pipe) | |
633 | (display "Mommy, why does everybody have a bomb?\n" pipe) | |
634 | (close-pipe pipe) | |
635 | (let ((in-string (read-file filename))) | |
636 | (pass-if "pipe: write" | |
8c6b62e7 | 637 | (equal? in-string "Mommy, why does everybody have a bomb?\n"))) |
57e7f270 | 638 | (delete-file filename)) |
000ee07f | 639 | |
c497bfb1 LC |
640 | (pass-if-equal "pipe, fdopen, and _IOLBF" |
641 | "foo\nbar\n" | |
642 | (let ((in+out (pipe)) | |
643 | (pid (primitive-fork))) | |
644 | (if (zero? pid) | |
645 | (dynamic-wind | |
646 | (const #t) | |
647 | (lambda () | |
648 | (close-port (car in+out)) | |
649 | (let ((port (cdr in+out))) | |
650 | (setvbuf port _IOLBF ) | |
651 | ;; Strings containing '\n' or should be flushed; others | |
652 | ;; should be kept in PORT's buffer. | |
653 | (display "foo\n" port) | |
654 | (display "bar\n" port) | |
655 | (display "this will be kept in PORT's buffer" port))) | |
656 | (lambda () | |
657 | (primitive-_exit 0))) | |
658 | (begin | |
659 | (close-port (cdr in+out)) | |
660 | (let ((str (read-all (car in+out)))) | |
661 | (waitpid pid) | |
662 | str))))) | |
663 | ||
000ee07f JB |
664 | \f |
665 | ;;;; Void ports. These are so trivial we don't test them. | |
666 | ||
667 | \f | |
668 | ;;;; String ports. | |
669 | ||
73cb0a97 JB |
670 | (with-test-prefix "string ports" |
671 | ||
672 | ;; Write text to a string port. | |
57e7f270 | 673 | (let* ((string "Howdy there, partner!") |
8c6b62e7 EZ |
674 | (in-string (call-with-output-string |
675 | (lambda (port) | |
676 | (display string port) | |
677 | (newline port))))) | |
57e7f270 | 678 | (pass-if "display text" |
8c6b62e7 | 679 | (equal? in-string (string-append string "\n")))) |
c53b5d89 | 680 | |
73cb0a97 | 681 | ;; Write an s-expression to a string port. |
57e7f270 | 682 | (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) |
c53b5d89 | 683 | (in-sexpr |
8c6b62e7 EZ |
684 | (call-with-input-string (call-with-output-string |
685 | (lambda (port) | |
686 | (write sexpr port))) | |
687 | read))) | |
57e7f270 | 688 | (pass-if "write/read sexpr" |
8c6b62e7 | 689 | (equal? in-sexpr sexpr))) |
2d9e5bca GH |
690 | |
691 | ;; seeking and unreading from an input string. | |
57e7f270 DH |
692 | (let ((text "that text didn't look random to me")) |
693 | (call-with-input-string text | |
8c6b62e7 EZ |
694 | (lambda (p) |
695 | (pass-if "input tell 0" | |
696 | (= (seek p 0 SEEK_CUR) 0)) | |
697 | (read-char p) | |
698 | (pass-if "input tell 1" | |
699 | (= (seek p 0 SEEK_CUR) 1)) | |
700 | (unread-char #\x p) | |
701 | (pass-if "input tell back to 0" | |
702 | (= (seek p 0 SEEK_CUR) 0)) | |
703 | (pass-if "input ungetted char" | |
704 | (char=? (read-char p) #\x)) | |
705 | (seek p 0 SEEK_END) | |
706 | (pass-if "input seek to end" | |
707 | (= (seek p 0 SEEK_CUR) | |
708 | (string-length text))) | |
709 | (unread-char #\x p) | |
710 | (pass-if "input seek to beginning" | |
711 | (= (seek p 0 SEEK_SET) 0)) | |
712 | (pass-if "input reread first char" | |
713 | (char=? (read-char p) | |
714 | (string-ref text 0)))))) | |
57e7f270 | 715 | |
2d9e5bca | 716 | ;; seeking an output string. |
e4cbd1d8 | 717 | (let* ((text (string-copy "123456789")) |
8c6b62e7 EZ |
718 | (len (string-length text)) |
719 | (result (call-with-output-string | |
720 | (lambda (p) | |
721 | (pass-if "output tell 0" | |
722 | (= (seek p 0 SEEK_CUR) 0)) | |
723 | (display text p) | |
724 | (pass-if "output tell end" | |
725 | (= (seek p 0 SEEK_CUR) len)) | |
726 | (pass-if "output seek to beginning" | |
727 | (= (seek p 0 SEEK_SET) 0)) | |
728 | (write-char #\a p) | |
729 | (seek p -1 SEEK_END) | |
730 | (pass-if "output seek to last char" | |
731 | (= (seek p 0 SEEK_CUR) | |
732 | (- len 1))) | |
733 | (write-char #\b p))))) | |
57e7f270 DH |
734 | (string-set! text 0 #\a) |
735 | (string-set! text (- len 1) #\b) | |
736 | (pass-if "output check" | |
8c6b62e7 | 737 | (string=? text result))) |
7b041912 | 738 | |
6dce942c MW |
739 | (pass-if "%default-port-encoding is ignored" |
740 | (let ((str "ĉu bone?")) | |
741 | ;; Latin-1 cannot represent ‘ĉ’. | |
742 | (with-fluids ((%default-port-encoding "ISO-8859-1")) | |
743 | (string=? (call-with-output-string | |
744 | (lambda (p) | |
745 | (set-port-conversion-strategy! p 'substitute) | |
746 | (display str p))) | |
747 | "ĉu bone?")))) | |
7b041912 | 748 | |
9f6e3f5a LC |
749 | (pass-if "%default-port-conversion-strategy is honored" |
750 | (let ((strategies '(error substitute escape))) | |
751 | (equal? (map (lambda (s) | |
752 | (with-fluids ((%default-port-conversion-strategy s)) | |
753 | (call-with-output-string | |
754 | (lambda (p) | |
755 | (and (eq? s (port-conversion-strategy p)) | |
756 | (begin | |
757 | (set-port-conversion-strategy! p s) | |
758 | (display (port-conversion-strategy p) | |
759 | p))))))) | |
760 | strategies) | |
761 | (map symbol->string strategies)))) | |
762 | ||
7b041912 | 763 | (pass-if "suitable encoding [latin-1]" |
6dce942c MW |
764 | (let ((str "hello, world") |
765 | (encoding "ISO-8859-1")) | |
766 | (equal? str | |
767 | (call-with-output-string | |
768 | (lambda (p) | |
769 | (set-port-encoding! p encoding) | |
770 | (display str p)))))) | |
7b041912 LC |
771 | |
772 | (pass-if "suitable encoding [latin-3]" | |
6dce942c MW |
773 | (let ((str "ĉu bone?") |
774 | (encoding "ISO-8859-3")) | |
775 | (equal? str | |
776 | (call-with-output-string | |
777 | (lambda (p) | |
778 | (set-port-encoding! p encoding) | |
779 | (display str p)))))) | |
7b041912 | 780 | |
9f6e3f5a | 781 | (pass-if "wrong encoding, error" |
7b041912 | 782 | (let ((str "ĉu bone?")) |
ef7e4ba3 LC |
783 | (catch 'encoding-error |
784 | (lambda () | |
6dce942c MW |
785 | (with-fluids ((%default-port-conversion-strategy 'error)) |
786 | (call-with-output-string | |
787 | (lambda (p) | |
788 | ;; Latin-1 cannot represent ‘ĉ’. | |
789 | (set-port-encoding! p "ISO-8859-1") | |
790 | (display str p)))) | |
791 | #f) ; so the test really fails here | |
6851d3be | 792 | (lambda (key subr message errno port chr) |
764246cf | 793 | (and (eqv? chr #\ĉ) |
fd5eec2b LC |
794 | (string? (strerror errno))))))) |
795 | ||
2e59af21 LC |
796 | (pass-if "wrong encoding, substitute" |
797 | (let ((str "ĉu bone?")) | |
6dce942c MW |
798 | (string=? (call-with-output-string |
799 | (lambda (p) | |
800 | (set-port-encoding! p "ISO-8859-1") | |
801 | (set-port-conversion-strategy! p 'substitute) | |
802 | (display str p))) | |
803 | "?u bone?"))) | |
2e59af21 LC |
804 | |
805 | (pass-if "wrong encoding, escape" | |
806 | (let ((str "ĉu bone?")) | |
6dce942c MW |
807 | (string=? (call-with-output-string |
808 | (lambda (p) | |
809 | (set-port-encoding! p "ISO-8859-1") | |
810 | (set-port-conversion-strategy! p 'escape) | |
811 | (display str p))) | |
812 | "\\u0109u bone?"))) | |
813 | ||
814 | (pass-if "peek-char" | |
815 | (let ((p (open-input-string "안녕하세요"))) | |
d84783a8 LC |
816 | (and (char=? (peek-char p) #\안) |
817 | (char=? (peek-char p) #\안) | |
818 | (char=? (peek-char p) #\안) | |
819 | (= (port-line p) 0) | |
820 | (= (port-column p) 0)))) | |
821 | ||
9a201881 LC |
822 | ;; Mini DSL to test decoding error handling. |
823 | (letrec-syntax ((decoding-error? | |
824 | (syntax-rules () | |
825 | ((_ port exp) | |
826 | (catch 'decoding-error | |
827 | (lambda () | |
828 | (pk 'exp exp) | |
829 | #f) | |
830 | (lambda (key subr message errno p) | |
831 | (and (eq? p port) | |
832 | (not (= 0 errno)))))))) | |
833 | (make-check | |
834 | (syntax-rules (-> error eof) | |
835 | ((_ port (proc -> error)) | |
3009b93e LC |
836 | (if (eq? 'substitute |
837 | (port-conversion-strategy port)) | |
764246cf | 838 | (eqv? (proc port) #\?) |
3009b93e | 839 | (decoding-error? port (proc port)))) |
9a201881 LC |
840 | ((_ port (proc -> eof)) |
841 | (eof-object? (proc port))) | |
842 | ((_ port (proc -> char)) | |
764246cf | 843 | (eqv? (proc port) char)))) |
9a201881 LC |
844 | (make-checks |
845 | (syntax-rules () | |
846 | ((_ port check ...) | |
847 | (and (make-check port check) ...)))) | |
e6e286bb LC |
848 | (make-peek+read-checks |
849 | (syntax-rules () | |
850 | ((_ port (result ...) e1 expected ...) | |
851 | (make-peek+read-checks port | |
852 | (result ... | |
853 | (peek-char -> e1) | |
854 | (read-char -> e1)) | |
855 | expected ...)) | |
856 | ((_ port (result ...)) | |
857 | (make-checks port result ...)) | |
858 | ((_ port #f e1 expected ...) | |
859 | (make-peek+read-checks port | |
860 | ((peek-char -> e1) | |
861 | (read-char -> e1)) | |
862 | expected ...)))) | |
3009b93e LC |
863 | |
864 | (test-decoding-error* | |
e6e286bb LC |
865 | (syntax-rules () |
866 | ((_ sequence encoding strategy (expected ...)) | |
867 | (begin | |
868 | (pass-if (format #f "test-decoding-error: ~s ~s ~s" | |
869 | 'sequence encoding strategy) | |
870 | (let ((p (open-bytevector-input-port | |
871 | (u8-list->bytevector 'sequence)))) | |
872 | (set-port-encoding! p encoding) | |
873 | (set-port-conversion-strategy! p strategy) | |
874 | (make-checks p | |
875 | (read-char -> expected) ...))) | |
876 | ||
877 | ;; Generate the same test, but with one | |
878 | ;; `peek-char' call before each `read-char'. | |
879 | ;; Both should yield the same result. | |
880 | (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char" | |
881 | 'sequence encoding strategy) | |
882 | (let ((p (open-bytevector-input-port | |
883 | (u8-list->bytevector 'sequence)))) | |
884 | (set-port-encoding! p encoding) | |
885 | (set-port-conversion-strategy! p strategy) | |
3009b93e LC |
886 | (make-peek+read-checks p #f expected |
887 | ...))))))) | |
888 | (test-decoding-error | |
889 | (syntax-rules () | |
890 | ((_ sequence encoding (expected ...)) | |
891 | (begin | |
892 | (test-decoding-error* sequence encoding 'error | |
893 | (expected ...)) | |
9a201881 | 894 | |
3009b93e LC |
895 | ;; `escape' should behave exactly like `error'. |
896 | (test-decoding-error* sequence encoding 'escape | |
897 | (expected ...)) | |
9a201881 | 898 | |
3009b93e LC |
899 | (test-decoding-error* sequence encoding 'substitute |
900 | (expected ...))))))) | |
901 | ||
902 | (test-decoding-error (255 65 66 67) "UTF-8" | |
e6e286bb | 903 | (error #\A #\B #\C eof)) |
9a201881 | 904 | |
3009b93e LC |
905 | (test-decoding-error (255 206 187 206 188) "UTF-8" |
906 | (error #\λ #\μ eof)) | |
9a201881 | 907 | |
3009b93e | 908 | (test-decoding-error (206 187 206) "UTF-8" |
a42d7971 | 909 | ;; Unterminated sequence. |
e6e286bb | 910 | (#\λ error eof)) |
a42d7971 | 911 | |
4cadf64f LC |
912 | ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7 |
913 | ;; of the "Conformance" chapter of Unicode 6.0.0.) | |
914 | ||
3009b93e | 915 | (test-decoding-error (#xc0 #x80 #x41) "UTF-8" |
e6e286bb LC |
916 | (error ;; C0: should be in the C2..DF range |
917 | error ;; 80: invalid | |
918 | #\A | |
919 | eof)) | |
920 | ||
3009b93e | 921 | (test-decoding-error (#xc2 #x41 #x42) "UTF-8" |
7be1705d LC |
922 | ;; Section 3.9 of Unicode 6.0.0 reads: |
923 | ;; "If the converter encounters an ill-formed UTF-8 code unit | |
924 | ;; sequence which starts with a valid first byte, but which does | |
925 | ;; not continue with valid successor bytes (see Table 3-7), it | |
926 | ;; must not consume the successor bytes". | |
927 | ;; Glibc/libiconv do not conform to it and instead swallow the | |
928 | ;; #x41. This example appears literally in Section 3.9. | |
929 | (error ;; 41: invalid successor | |
930 | #\A ;; 41: valid starting byte | |
e6e286bb LC |
931 | #\B |
932 | eof)) | |
4cadf64f | 933 | |
7be1705d LC |
934 | (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8" |
935 | ;; According to Unicode 6.0.0, Section 3.9, "the only formal | |
936 | ;; requirement mandated by Unicode conformance for a converter is | |
937 | ;; that the <41> be processed and correctly interpreted as | |
938 | ;; <U+0041>". | |
e6e286bb | 939 | (error ;; 2nd byte should be in the A0..BF range |
7be1705d LC |
940 | error ;; 80: not a valid starting byte |
941 | error ;; 80: not a valid starting byte | |
942 | #\A | |
e6e286bb LC |
943 | eof)) |
944 | ||
3009b93e | 945 | (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8" |
e6e286bb | 946 | (error ;; 3rd byte should be in the 80..BF range |
7be1705d | 947 | #\A |
e6e286bb LC |
948 | #\B |
949 | eof)) | |
4cadf64f | 950 | |
3009b93e | 951 | (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" |
e6e286bb | 952 | (error ;; 2nd byte should be in the 90..BF range |
7be1705d LC |
953 | error ;; 88: not a valid starting byte |
954 | error ;; 88: not a valid starting byte | |
955 | error ;; 88: not a valid starting byte | |
e6e286bb | 956 | eof)))) |
2d9e5bca | 957 | |
ee6eedcd KR |
958 | (with-test-prefix "call-with-output-string" |
959 | ||
960 | ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't | |
961 | ;; occur. | |
962 | (pass-if-exception "proc closes port" exception:wrong-type-arg | |
963 | (call-with-output-string close-port))) | |
964 | ||
000ee07f JB |
965 | |
966 | \f | |
967 | ;;;; Soft ports. No tests implemented yet. | |
968 | ||
969 | \f | |
970 | ;;;; Generic operations across all port types. | |
971 | ||
972 | (let ((port-loop-temp (test-file))) | |
973 | ||
974 | ;; Return a list of input ports that all return the same text. | |
975 | ;; We map tests over this list. | |
976 | (define (input-port-list text) | |
c53b5d89 | 977 | |
000ee07f JB |
978 | ;; Create a text file some of the ports will use. |
979 | (let ((out-port (open-output-file port-loop-temp))) | |
980 | (display text out-port) | |
981 | (close-port out-port)) | |
982 | ||
983 | (list (open-input-file port-loop-temp) | |
8c6b62e7 EZ |
984 | (open-input-pipe (string-append "cat " port-loop-temp)) |
985 | (call-with-input-string text (lambda (x) x)) | |
986 | ;; We don't test soft ports at the moment. | |
987 | )) | |
000ee07f JB |
988 | |
989 | (define port-list-names '("file" "pipe" "string")) | |
990 | ||
991 | ;; Test the line counter. | |
73cb0a97 | 992 | (define (test-line-counter text second-line final-column) |
000ee07f JB |
993 | (with-test-prefix "line counter" |
994 | (let ((ports (input-port-list text))) | |
8c6b62e7 EZ |
995 | (for-each |
996 | (lambda (port port-name) | |
997 | (with-test-prefix port-name | |
998 | (pass-if "at beginning of input" | |
999 | (= (port-line port) 0)) | |
1000 | (pass-if "read first character" | |
1001 | (eqv? (read-char port) #\x)) | |
1002 | (pass-if "after reading one character" | |
1003 | (= (port-line port) 0)) | |
1004 | (pass-if "read first newline" | |
1005 | (eqv? (read-char port) #\newline)) | |
1006 | (pass-if "after reading first newline char" | |
1007 | (= (port-line port) 1)) | |
1008 | (pass-if "second line read correctly" | |
1009 | (equal? (read-line port) second-line)) | |
1010 | (pass-if "read-line increments line number" | |
1011 | (= (port-line port) 2)) | |
1012 | (pass-if "read-line returns EOF" | |
1013 | (let loop ((i 0)) | |
1014 | (cond | |
1015 | ((eof-object? (read-line port)) #t) | |
1016 | ((> i 20) #f) | |
1017 | (else (loop (+ i 1)))))) | |
1018 | (pass-if "line count is 5 at EOF" | |
1019 | (= (port-line port) 5)) | |
1020 | (pass-if "column is correct at EOF" | |
1021 | (= (port-column port) final-column)))) | |
1022 | ports port-list-names) | |
1023 | (for-each close-port ports) | |
1024 | (delete-file port-loop-temp)))) | |
000ee07f | 1025 | |
57e7f270 DH |
1026 | (with-test-prefix "newline" |
1027 | (test-line-counter | |
1028 | (string-append "x\n" | |
8c6b62e7 EZ |
1029 | "He who receives an idea from me, receives instruction\n" |
1030 | "himself without lessening mine; as he who lights his\n" | |
1031 | "taper at mine, receives light without darkening me.\n" | |
1032 | " --- Thomas Jefferson\n") | |
57e7f270 DH |
1033 | "He who receives an idea from me, receives instruction" |
1034 | 0)) | |
1035 | ||
1036 | (with-test-prefix "no newline" | |
1037 | (test-line-counter | |
1038 | (string-append "x\n" | |
8c6b62e7 EZ |
1039 | "He who receives an idea from me, receives instruction\n" |
1040 | "himself without lessening mine; as he who lights his\n" | |
1041 | "taper at mine, receives light without darkening me.\n" | |
1042 | " --- Thomas Jefferson\n" | |
1043 | "no newline here") | |
57e7f270 DH |
1044 | "He who receives an idea from me, receives instruction" |
1045 | 15))) | |
5bc1201f | 1046 | |
9a8be5a7 MV |
1047 | ;; Test port-line and port-column for output ports |
1048 | ||
1049 | (define (test-output-line-counter text final-column) | |
1050 | (with-test-prefix "port-line and port-column for output ports" | |
1051 | (let ((port (open-output-string))) | |
1052 | (pass-if "at beginning of input" | |
8c6b62e7 EZ |
1053 | (and (= (port-line port) 0) |
1054 | (= (port-column port) 0))) | |
9a8be5a7 MV |
1055 | (write-char #\x port) |
1056 | (pass-if "after writing one character" | |
8c6b62e7 EZ |
1057 | (and (= (port-line port) 0) |
1058 | (= (port-column port) 1))) | |
9a8be5a7 MV |
1059 | (write-char #\newline port) |
1060 | (pass-if "after writing first newline char" | |
8c6b62e7 EZ |
1061 | (and (= (port-line port) 1) |
1062 | (= (port-column port) 0))) | |
9a8be5a7 MV |
1063 | (display text port) |
1064 | (pass-if "line count is 5 at end" | |
8c6b62e7 | 1065 | (= (port-line port) 5)) |
9a8be5a7 | 1066 | (pass-if "column is correct at end" |
8c6b62e7 | 1067 | (= (port-column port) final-column))))) |
9a8be5a7 MV |
1068 | |
1069 | (test-output-line-counter | |
1070 | (string-append "He who receives an idea from me, receives instruction\n" | |
8c6b62e7 EZ |
1071 | "himself without lessening mine; as he who lights his\n" |
1072 | "taper at mine, receives light without darkening me.\n" | |
1073 | " --- Thomas Jefferson\n" | |
1074 | "no newline here") | |
9a8be5a7 MV |
1075 | 15) |
1076 | ||
7424deab KR |
1077 | (with-test-prefix "port-column" |
1078 | ||
1079 | (with-test-prefix "output" | |
1080 | ||
1081 | (pass-if "x" | |
1082 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1083 | (display "x" port) |
1084 | (= 1 (port-column port)))) | |
7424deab KR |
1085 | |
1086 | (pass-if "\\a" | |
1087 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1088 | (display "\a" port) |
1089 | (= 0 (port-column port)))) | |
7424deab KR |
1090 | |
1091 | (pass-if "x\\a" | |
1092 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1093 | (display "x\a" port) |
1094 | (= 1 (port-column port)))) | |
7424deab KR |
1095 | |
1096 | (pass-if "\\x08 backspace" | |
1097 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1098 | (display "\x08" port) |
1099 | (= 0 (port-column port)))) | |
7424deab KR |
1100 | |
1101 | (pass-if "x\\x08 backspace" | |
1102 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1103 | (display "x\x08" port) |
1104 | (= 0 (port-column port)))) | |
7424deab KR |
1105 | |
1106 | (pass-if "\\n" | |
1107 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1108 | (display "\n" port) |
1109 | (= 0 (port-column port)))) | |
7424deab KR |
1110 | |
1111 | (pass-if "x\\n" | |
1112 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1113 | (display "x\n" port) |
1114 | (= 0 (port-column port)))) | |
7424deab KR |
1115 | |
1116 | (pass-if "\\r" | |
1117 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1118 | (display "\r" port) |
1119 | (= 0 (port-column port)))) | |
7424deab KR |
1120 | |
1121 | (pass-if "x\\r" | |
1122 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1123 | (display "x\r" port) |
1124 | (= 0 (port-column port)))) | |
7424deab KR |
1125 | |
1126 | (pass-if "\\t" | |
1127 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1128 | (display "\t" port) |
1129 | (= 8 (port-column port)))) | |
7424deab KR |
1130 | |
1131 | (pass-if "x\\t" | |
1132 | (let ((port (open-output-string))) | |
8c6b62e7 EZ |
1133 | (display "x\t" port) |
1134 | (= 8 (port-column port))))) | |
7424deab KR |
1135 | |
1136 | (with-test-prefix "input" | |
1137 | ||
1138 | (pass-if "x" | |
1139 | (let ((port (open-input-string "x"))) | |
8c6b62e7 EZ |
1140 | (while (not (eof-object? (read-char port)))) |
1141 | (= 1 (port-column port)))) | |
7424deab KR |
1142 | |
1143 | (pass-if "\\a" | |
1144 | (let ((port (open-input-string "\a"))) | |
8c6b62e7 EZ |
1145 | (while (not (eof-object? (read-char port)))) |
1146 | (= 0 (port-column port)))) | |
7424deab KR |
1147 | |
1148 | (pass-if "x\\a" | |
1149 | (let ((port (open-input-string "x\a"))) | |
8c6b62e7 EZ |
1150 | (while (not (eof-object? (read-char port)))) |
1151 | (= 1 (port-column port)))) | |
7424deab KR |
1152 | |
1153 | (pass-if "\\x08 backspace" | |
1154 | (let ((port (open-input-string "\x08"))) | |
8c6b62e7 EZ |
1155 | (while (not (eof-object? (read-char port)))) |
1156 | (= 0 (port-column port)))) | |
7424deab KR |
1157 | |
1158 | (pass-if "x\\x08 backspace" | |
1159 | (let ((port (open-input-string "x\x08"))) | |
8c6b62e7 EZ |
1160 | (while (not (eof-object? (read-char port)))) |
1161 | (= 0 (port-column port)))) | |
7424deab KR |
1162 | |
1163 | (pass-if "\\n" | |
1164 | (let ((port (open-input-string "\n"))) | |
8c6b62e7 EZ |
1165 | (while (not (eof-object? (read-char port)))) |
1166 | (= 0 (port-column port)))) | |
7424deab KR |
1167 | |
1168 | (pass-if "x\\n" | |
1169 | (let ((port (open-input-string "x\n"))) | |
8c6b62e7 EZ |
1170 | (while (not (eof-object? (read-char port)))) |
1171 | (= 0 (port-column port)))) | |
7424deab KR |
1172 | |
1173 | (pass-if "\\r" | |
1174 | (let ((port (open-input-string "\r"))) | |
8c6b62e7 EZ |
1175 | (while (not (eof-object? (read-char port)))) |
1176 | (= 0 (port-column port)))) | |
7424deab KR |
1177 | |
1178 | (pass-if "x\\r" | |
1179 | (let ((port (open-input-string "x\r"))) | |
8c6b62e7 EZ |
1180 | (while (not (eof-object? (read-char port)))) |
1181 | (= 0 (port-column port)))) | |
7424deab KR |
1182 | |
1183 | (pass-if "\\t" | |
1184 | (let ((port (open-input-string "\t"))) | |
8c6b62e7 EZ |
1185 | (while (not (eof-object? (read-char port)))) |
1186 | (= 8 (port-column port)))) | |
7424deab KR |
1187 | |
1188 | (pass-if "x\\t" | |
1189 | (let ((port (open-input-string "x\t"))) | |
8c6b62e7 EZ |
1190 | (while (not (eof-object? (read-char port)))) |
1191 | (= 8 (port-column port)))))) | |
7424deab | 1192 | |
004be623 KR |
1193 | (with-test-prefix "port-line" |
1194 | ||
1195 | ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas | |
1196 | ;; scm_t_port actually holds a long; this restricted the range on 64-bit | |
1197 | ;; systems | |
1198 | (pass-if "set most-positive-fixnum/2" | |
1199 | (let ((n (quotient most-positive-fixnum 2)) | |
8c6b62e7 | 1200 | (port (open-output-string))) |
004be623 KR |
1201 | (set-port-line! port n) |
1202 | (eqv? n (port-line port))))) | |
1203 | ||
064c27c4 LC |
1204 | (with-test-prefix "port-encoding" |
1205 | ||
1206 | (pass-if-exception "set-port-encoding!, wrong encoding" | |
1207 | exception:miscellaneous-error | |
cdd3d6c9 MW |
1208 | (let ((p (open-input-string ""))) |
1209 | (set-port-encoding! p "does-not-exist") | |
1210 | (read p))) | |
064c27c4 | 1211 | |
6dce942c MW |
1212 | (let ((filename (test-file))) |
1213 | (with-output-to-file filename (lambda () (write 'test))) | |
1214 | ||
1215 | (pass-if-exception "%default-port-encoding, wrong encoding" | |
1216 | exception:miscellaneous-error | |
1217 | (read (with-fluids ((%default-port-encoding "does-not-exist")) | |
1218 | (open-input-file filename)))) | |
1219 | ||
1220 | (delete-file filename))) | |
064c27c4 | 1221 | |
256f34e7 KR |
1222 | ;;; |
1223 | ;;; port-for-each | |
1224 | ;;; | |
1225 | ||
1226 | (with-test-prefix "port-for-each" | |
1227 | ||
1228 | ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to | |
1229 | ;; its iterator func if a port was inaccessible in the last gc mark but | |
1230 | ;; the lazy sweeping has not yet reached it to remove it from the port | |
1231 | ;; table (scm_i_port_table). Provoking those gc conditions is a little | |
1232 | ;; tricky, but the following code made it happen in 1.8.2. | |
1233 | (pass-if "passing freed cell" | |
256f34e7 KR |
1234 | (let ((lst '())) |
1235 | ;; clear out the heap | |
1236 | (gc) (gc) (gc) | |
1237 | ;; allocate cells so the opened ports aren't at the start of the heap | |
1238 | (make-list 1000) | |
1239 | (open-input-file "/dev/null") | |
1240 | (make-list 1000) | |
1241 | (open-input-file "/dev/null") | |
1242 | ;; this gc leaves the above ports unmarked, ie. inaccessible | |
1243 | (gc) | |
1244 | ;; but they're still in the port table, so this sees them | |
1245 | (port-for-each (lambda (port) | |
8c6b62e7 | 1246 | (set! lst (cons port lst)))) |
256f34e7 KR |
1247 | ;; this forces completion of the sweeping |
1248 | (gc) (gc) (gc) | |
1249 | ;; and (if the bug is present) the cells accumulated in LST are now | |
1250 | ;; freed cells, which give #f from `port?' | |
1251 | (not (memq #f (map port? lst)))))) | |
1252 | ||
e9966dbb HWN |
1253 | (with-test-prefix |
1254 | "fdes->port" | |
1255 | (pass-if "fdes->ports finds port" | |
8c6b62e7 EZ |
1256 | (let* ((port (open-file (test-file) "w")) |
1257 | (res (not (not (memq port (fdes->ports (port->fdes port))))))) | |
1258 | (close-port port) | |
1259 | res))) | |
e9966dbb | 1260 | |
8ab3d8a0 KR |
1261 | ;;; |
1262 | ;;; seek | |
1263 | ;;; | |
1264 | ||
1265 | (with-test-prefix "seek" | |
1266 | ||
1267 | (with-test-prefix "file port" | |
1268 | ||
1269 | (pass-if "SEEK_CUR" | |
1270 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1271 | (lambda (port) |
1272 | (display "abcde" port))) | |
8ab3d8a0 | 1273 | (let ((port (open-file (test-file) "r"))) |
8c6b62e7 EZ |
1274 | (read-char port) |
1275 | (seek port 2 SEEK_CUR) | |
1276 | (let ((res (eqv? #\d (read-char port)))) | |
1277 | (close-port port) | |
1278 | res))) | |
8ab3d8a0 KR |
1279 | |
1280 | (pass-if "SEEK_SET" | |
1281 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1282 | (lambda (port) |
1283 | (display "abcde" port))) | |
8ab3d8a0 | 1284 | (let ((port (open-file (test-file) "r"))) |
8c6b62e7 EZ |
1285 | (read-char port) |
1286 | (seek port 3 SEEK_SET) | |
1287 | (let ((res (eqv? #\d (read-char port)))) | |
1288 | (close-port port) | |
1289 | res))) | |
8ab3d8a0 KR |
1290 | |
1291 | (pass-if "SEEK_END" | |
1292 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1293 | (lambda (port) |
1294 | (display "abcde" port))) | |
8ab3d8a0 | 1295 | (let ((port (open-file (test-file) "r"))) |
8c6b62e7 EZ |
1296 | (read-char port) |
1297 | (seek port -2 SEEK_END) | |
1298 | (let ((res (eqv? #\d (read-char port)))) | |
1299 | (close-port port) | |
1300 | res))))) | |
8ab3d8a0 | 1301 | |
6e7d5622 KR |
1302 | ;;; |
1303 | ;;; truncate-file | |
1304 | ;;; | |
1305 | ||
1306 | (with-test-prefix "truncate-file" | |
1307 | ||
8ab3d8a0 KR |
1308 | (pass-if-exception "flonum file" exception:wrong-type-arg |
1309 | (truncate-file 1.0 123)) | |
1310 | ||
1311 | (pass-if-exception "frac file" exception:wrong-type-arg | |
1312 | (truncate-file 7/3 123)) | |
1313 | ||
6e7d5622 KR |
1314 | (with-test-prefix "filename" |
1315 | ||
8ab3d8a0 KR |
1316 | (pass-if-exception "flonum length" exception:wrong-type-arg |
1317 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1318 | (lambda (port) |
1319 | (display "hello" port))) | |
8ab3d8a0 KR |
1320 | (truncate-file (test-file) 1.0)) |
1321 | ||
6e7d5622 KR |
1322 | (pass-if "shorten" |
1323 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1324 | (lambda (port) |
1325 | (display "hello" port))) | |
6e7d5622 | 1326 | (truncate-file (test-file) 1) |
8ab3d8a0 KR |
1327 | (eqv? 1 (stat:size (stat (test-file))))) |
1328 | ||
1329 | (pass-if-exception "shorten to current pos" exception:miscellaneous-error | |
1330 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1331 | (lambda (port) |
1332 | (display "hello" port))) | |
8ab3d8a0 | 1333 | (truncate-file (test-file)))) |
6e7d5622 KR |
1334 | |
1335 | (with-test-prefix "file descriptor" | |
1336 | ||
1337 | (pass-if "shorten" | |
1338 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1339 | (lambda (port) |
1340 | (display "hello" port))) | |
6e7d5622 | 1341 | (let ((fd (open-fdes (test-file) O_RDWR))) |
8c6b62e7 EZ |
1342 | (truncate-file fd 1) |
1343 | (close-fdes fd)) | |
8ab3d8a0 KR |
1344 | (eqv? 1 (stat:size (stat (test-file))))) |
1345 | ||
1346 | (pass-if "shorten to current pos" | |
1347 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1348 | (lambda (port) |
1349 | (display "hello" port))) | |
8ab3d8a0 | 1350 | (let ((fd (open-fdes (test-file) O_RDWR))) |
8c6b62e7 EZ |
1351 | (seek fd 1 SEEK_SET) |
1352 | (truncate-file fd) | |
1353 | (close-fdes fd)) | |
6e7d5622 KR |
1354 | (eqv? 1 (stat:size (stat (test-file)))))) |
1355 | ||
1356 | (with-test-prefix "file port" | |
1357 | ||
1358 | (pass-if "shorten" | |
1359 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1360 | (lambda (port) |
1361 | (display "hello" port))) | |
6e7d5622 | 1362 | (let ((port (open-file (test-file) "r+"))) |
8c6b62e7 EZ |
1363 | (truncate-file port 1) |
1364 | (close-port port)) | |
8ab3d8a0 KR |
1365 | (eqv? 1 (stat:size (stat (test-file))))) |
1366 | ||
1367 | (pass-if "shorten to current pos" | |
1368 | (call-with-output-file (test-file) | |
8c6b62e7 EZ |
1369 | (lambda (port) |
1370 | (display "hello" port))) | |
8ab3d8a0 | 1371 | (let ((port (open-file (test-file) "r+"))) |
8c6b62e7 EZ |
1372 | (read-char port) |
1373 | (truncate-file port) | |
1374 | (close-port port)) | |
6e7d5622 KR |
1375 | (eqv? 1 (stat:size (stat (test-file))))))) |
1376 | ||
7424deab | 1377 | |
5bc1201f JB |
1378 | ;;;; testing read-delimited and friends |
1379 | ||
1380 | (with-test-prefix "read-delimited!" | |
1381 | (let ((c (make-string 20 #\!))) | |
c53b5d89 | 1382 | (call-with-input-string |
5bc1201f JB |
1383 | "defdef\nghighi\n" |
1384 | (lambda (port) | |
c53b5d89 | 1385 | |
5bc1201f JB |
1386 | (read-delimited! "\n" c port 'concat) |
1387 | (pass-if "read-delimited! reads a first line" | |
8c6b62e7 | 1388 | (string=? c "defdef\n!!!!!!!!!!!!!")) |
5bc1201f JB |
1389 | |
1390 | (read-delimited! "\n" c port 'concat 3) | |
1391 | (pass-if "read-delimited! reads a first line" | |
8c6b62e7 | 1392 | (string=? c "defghighi\n!!!!!!!!!!")))))) |
1b054952 JB |
1393 | |
1394 | \f | |
1395 | ;;;; char-ready? | |
1396 | ||
1397 | (call-with-input-string | |
1398 | "howdy" | |
1399 | (lambda (port) | |
1400 | (pass-if "char-ready? returns true on string port" | |
8c6b62e7 | 1401 | (char-ready? port)))) |
1b054952 JB |
1402 | |
1403 | ;;; This segfaults on some versions of Guile. We really should run | |
1404 | ;;; the tests in a subprocess... | |
1405 | ||
1406 | (call-with-input-string | |
1407 | "howdy" | |
1408 | (lambda (port) | |
1409 | (with-input-from-port | |
1410 | port | |
1411 | (lambda () | |
1412 | (pass-if "char-ready? returns true on string port as default port" | |
8c6b62e7 | 1413 | (char-ready?)))))) |
fe5b6beb JB |
1414 | |
1415 | \f | |
45c0878b MW |
1416 | ;;;; pending-eof behavior |
1417 | ||
1418 | (with-test-prefix "pending EOF behavior" | |
1419 | ;; Make a test port that will produce the given sequence. Each | |
1420 | ;; element of 'lst' may be either a character or #f (which means EOF). | |
1421 | (define (test-soft-port . lst) | |
1422 | (make-soft-port | |
1423 | (vector (lambda (c) #f) ; write char | |
1424 | (lambda (s) #f) ; write string | |
1425 | (lambda () #f) ; flush | |
1426 | (lambda () ; read char | |
1427 | (let ((c (car lst))) | |
1428 | (set! lst (cdr lst)) | |
1429 | c)) | |
1430 | (lambda () #f)) ; close | |
1431 | "rw")) | |
1432 | ||
1433 | (define (call-with-port p proc) | |
1434 | (dynamic-wind | |
1435 | (lambda () #f) | |
1436 | (lambda () (proc p)) | |
1437 | (lambda () (close-port p)))) | |
1438 | ||
1439 | (define (call-with-test-file str proc) | |
1440 | (let ((filename (test-file))) | |
1441 | (dynamic-wind | |
1442 | (lambda () (call-with-output-file filename | |
1443 | (lambda (p) (display str p)))) | |
1444 | (lambda () (call-with-input-file filename proc)) | |
1445 | (lambda () (delete-file (test-file)))))) | |
1446 | ||
1447 | (pass-if "peek-char does not swallow EOF (soft port)" | |
1448 | (call-with-port (test-soft-port #\a #f #\b) | |
1449 | (lambda (p) | |
1450 | (and (char=? #\a (peek-char p)) | |
1451 | (char=? #\a (read-char p)) | |
1452 | (eof-object? (peek-char p)) | |
1453 | (eof-object? (read-char p)) | |
1454 | (char=? #\b (peek-char p)) | |
1455 | (char=? #\b (read-char p)))))) | |
1456 | ||
1457 | (pass-if "unread clears pending EOF (soft port)" | |
1458 | (call-with-port (test-soft-port #\a #f #\b) | |
1459 | (lambda (p) | |
1460 | (and (char=? #\a (read-char p)) | |
1461 | (eof-object? (peek-char p)) | |
1462 | (begin (unread-char #\u p) | |
1463 | (char=? #\u (read-char p))))))) | |
1464 | ||
1465 | (pass-if "unread clears pending EOF (string port)" | |
1466 | (call-with-input-string "a" | |
1467 | (lambda (p) | |
1468 | (and (char=? #\a (read-char p)) | |
1469 | (eof-object? (peek-char p)) | |
1470 | (begin (unread-char #\u p) | |
1471 | (char=? #\u (read-char p))))))) | |
1472 | ||
1473 | (pass-if "unread clears pending EOF (file port)" | |
1474 | (call-with-test-file | |
1475 | "a" | |
1476 | (lambda (p) | |
1477 | (and (char=? #\a (read-char p)) | |
1478 | (eof-object? (peek-char p)) | |
1479 | (begin (unread-char #\u p) | |
1480 | (char=? #\u (read-char p))))))) | |
1481 | ||
1482 | (pass-if "seek clears pending EOF (string port)" | |
1483 | (call-with-input-string "a" | |
1484 | (lambda (p) | |
1485 | (and (char=? #\a (read-char p)) | |
1486 | (eof-object? (peek-char p)) | |
1487 | (begin (seek p 0 SEEK_SET) | |
1488 | (char=? #\a (read-char p))))))) | |
1489 | ||
1490 | (pass-if "seek clears pending EOF (file port)" | |
1491 | (call-with-test-file | |
1492 | "a" | |
1493 | (lambda (p) | |
1494 | (and (char=? #\a (read-char p)) | |
1495 | (eof-object? (peek-char p)) | |
1496 | (begin (seek p 0 SEEK_SET) | |
1497 | (char=? #\a (read-char p)))))))) | |
1498 | ||
1499 | \f | |
fe5b6beb JB |
1500 | ;;;; Close current-input-port, and make sure everyone can handle it. |
1501 | ||
1502 | (with-test-prefix "closing current-input-port" | |
1503 | (for-each (lambda (procedure name) | |
8c6b62e7 EZ |
1504 | (with-input-from-port |
1505 | (call-with-input-string "foo" (lambda (p) p)) | |
1506 | (lambda () | |
1507 | (close-port (current-input-port)) | |
1508 | (pass-if-exception name | |
1509 | exception:wrong-type-arg | |
1510 | (procedure))))) | |
1511 | (list read read-char read-line) | |
1512 | '("read" "read-char" "read-line"))) | |
c56c0f79 | 1513 | |
e8b21eec LC |
1514 | \f |
1515 | ||
1516 | (with-test-prefix "setvbuf" | |
1517 | ||
122f24cc LC |
1518 | (pass-if-exception "closed port" |
1519 | exception:wrong-type-arg | |
1520 | (let ((port (open-input-file "/dev/null"))) | |
1521 | (close-port port) | |
1522 | (setvbuf port _IOFBF))) | |
1523 | ||
1524 | (pass-if-exception "string port" | |
1525 | exception:wrong-type-arg | |
1526 | (let ((port (open-input-string "Hey!"))) | |
1527 | (close-port port) | |
1528 | (setvbuf port _IOFBF))) | |
1529 | ||
e8b21eec LC |
1530 | (pass-if "line/column number preserved" |
1531 | ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's | |
1532 | ;; line and/or column number. | |
1533 | (call-with-output-file (test-file) | |
1534 | (lambda (p) | |
1535 | (display "This is GNU Guile.\nWelcome." p))) | |
1536 | (call-with-input-file (test-file) | |
1537 | (lambda (p) | |
764246cf | 1538 | (and (eqv? #\T (read-char p)) |
e8b21eec LC |
1539 | (let ((line (port-line p)) |
1540 | (col (port-column p))) | |
1541 | (and (= line 0) (= col 1) | |
1542 | (begin | |
1543 | (setvbuf p _IOFBF 777) | |
1544 | (let ((line* (port-line p)) | |
1545 | (col* (port-column p))) | |
1546 | (and (= line line*) | |
1547 | (= col col*))))))))))) | |
1548 | ||
2ae7b7b6 LC |
1549 | \f |
1550 | ||
7f6c3f8f MW |
1551 | (pass-if-equal "unget-bytevector" |
1552 | #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203 | |
1553 | 1 2 3 4 251 253 254 255) | |
1554 | (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255)))) | |
1555 | (unget-bytevector port #vu8(200 201 202 203)) | |
1556 | (unget-bytevector port #vu8(20 21 22 23 24)) | |
1557 | (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4) | |
1558 | (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2) | |
1559 | (unget-bytevector port #vu8(10 11)) | |
1560 | (get-bytevector-all port))) | |
1561 | ||
1562 | \f | |
1563 | ||
cdd3d6c9 MW |
1564 | (with-test-prefix "unicode byte-order marks (BOMs)" |
1565 | ||
1566 | (define (bv-read-test* encoding bv proc) | |
1567 | (let ((port (open-bytevector-input-port bv))) | |
1568 | (set-port-encoding! port encoding) | |
1569 | (proc port))) | |
1570 | ||
1571 | (define (bv-read-test encoding bv) | |
1572 | (bv-read-test* encoding bv read-string)) | |
1573 | ||
1574 | (define (bv-write-test* encoding proc) | |
1575 | (call-with-values | |
1576 | (lambda () (open-bytevector-output-port)) | |
1577 | (lambda (port get-bytevector) | |
1578 | (set-port-encoding! port encoding) | |
1579 | (proc port) | |
1580 | (get-bytevector)))) | |
1581 | ||
1582 | (define (bv-write-test encoding str) | |
1583 | (bv-write-test* encoding | |
1584 | (lambda (p) | |
1585 | (display str p)))) | |
1586 | ||
1587 | (pass-if-equal "BOM not discarded from Latin-1 stream" | |
1588 | "\xEF\xBB\xBF\x61" | |
1589 | (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61))) | |
1590 | ||
1591 | (pass-if-equal "BOM not discarded from Latin-2 stream" | |
1592 | "\u010F\u0165\u017C\x61" | |
1593 | (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61))) | |
1594 | ||
1595 | (pass-if-equal "BOM not discarded from UTF-16BE stream" | |
1596 | "\uFEFF\x61" | |
1597 | (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61))) | |
1598 | ||
1599 | (pass-if-equal "BOM not discarded from UTF-16LE stream" | |
1600 | "\uFEFF\x61" | |
1601 | (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00))) | |
1602 | ||
1603 | (pass-if-equal "BOM not discarded from UTF-32BE stream" | |
1604 | "\uFEFF\x61" | |
1605 | (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF | |
1606 | #x00 #x00 #x00 #x61))) | |
1607 | ||
1608 | (pass-if-equal "BOM not discarded from UTF-32LE stream" | |
1609 | "\uFEFF\x61" | |
1610 | (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00 | |
1611 | #x61 #x00 #x00 #x00))) | |
1612 | ||
1613 | (pass-if-equal "BOM not written to UTF-8 stream" | |
1614 | #vu8(#x61) | |
1615 | (bv-write-test "UTF-8" "a")) | |
1616 | ||
1617 | (pass-if-equal "BOM not written to UTF-16BE stream" | |
1618 | #vu8(#x00 #x61) | |
1619 | (bv-write-test "UTF-16BE" "a")) | |
1620 | ||
1621 | (pass-if-equal "BOM not written to UTF-16LE stream" | |
1622 | #vu8(#x61 #x00) | |
1623 | (bv-write-test "UTF-16LE" "a")) | |
1624 | ||
1625 | (pass-if-equal "BOM not written to UTF-32BE stream" | |
1626 | #vu8(#x00 #x00 #x00 #x61) | |
1627 | (bv-write-test "UTF-32BE" "a")) | |
1628 | ||
1629 | (pass-if-equal "BOM not written to UTF-32LE stream" | |
1630 | #vu8(#x61 #x00 #x00 #x00) | |
1631 | (bv-write-test "UTF-32LE" "a")) | |
1632 | ||
1633 | (pass-if "Don't read from the port unless user asks to" | |
1634 | (let* ((p (make-soft-port | |
1635 | (vector | |
1636 | (lambda (c) #f) ; write char | |
1637 | (lambda (s) #f) ; write string | |
1638 | (lambda () #f) ; flush | |
1639 | (lambda () (throw 'fail)) ; read char | |
1640 | (lambda () #f)) | |
1641 | "rw"))) | |
1642 | (set-port-encoding! p "UTF-16") | |
1643 | (display "abc" p) | |
1644 | (set-port-encoding! p "UTF-32") | |
1645 | (display "def" p) | |
1646 | #t)) | |
1647 | ||
1648 | ;; TODO: test that input and output streams are independent when | |
1649 | ;; appropriate, and linked when appropriate. | |
1650 | ||
1651 | (pass-if-equal "BOM discarded from start of UTF-8 stream" | |
1652 | "a" | |
1653 | (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61))) | |
1654 | ||
1655 | (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0" | |
1656 | '(#\a "a") | |
1657 | (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61) | |
1658 | (lambda (p) | |
1659 | (let ((c (read-char p))) | |
1660 | (seek p 0 SEEK_SET) | |
1661 | (let ((s (read-string p))) | |
1662 | (list c s)))))) | |
1663 | ||
1664 | (pass-if-equal "Only one BOM discarded from start of UTF-8 stream" | |
1665 | "\uFEFFa" | |
1666 | (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61))) | |
1667 | ||
1668 | (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0" | |
1669 | "\uFEFFb" | |
1670 | (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62) | |
1671 | (lambda (p) | |
1672 | (seek p 1 SEEK_SET) | |
1673 | (read-string p)))) | |
1674 | ||
1675 | (pass-if-equal "BOM not discarded unless at start of UTF-8 stream" | |
1676 | "a\uFEFFb" | |
1677 | (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62))) | |
1678 | ||
1679 | (pass-if-equal "BOM (BE) written to start of UTF-16 stream" | |
1680 | #vu8(#xFE #xFF #x00 #x61 #x00 #x62) | |
1681 | (bv-write-test "UTF-16" "ab")) | |
1682 | ||
1683 | (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!" | |
1684 | #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64) | |
1685 | (bv-write-test* "UTF-16" | |
1686 | (lambda (p) | |
1687 | (display "ab" p) | |
1688 | (set-port-encoding! p "UTF-16") | |
1689 | (display "cd" p)))) | |
1690 | ||
1691 | (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)" | |
1692 | "a" | |
1693 | (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61))) | |
1694 | ||
1695 | (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0" | |
1696 | '(#\a "a") | |
1697 | (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61) | |
1698 | (lambda (p) | |
1699 | (let ((c (read-char p))) | |
1700 | (seek p 0 SEEK_SET) | |
1701 | (let ((s (read-string p))) | |
1702 | (list c s)))))) | |
1703 | ||
1704 | (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)" | |
1705 | "\uFEFFa" | |
1706 | (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61))) | |
1707 | ||
1708 | (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0" | |
1709 | "\uFEFFa" | |
1710 | (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61) | |
1711 | (lambda (p) | |
1712 | (seek p 2 SEEK_SET) | |
1713 | (read-string p)))) | |
1714 | ||
1715 | (pass-if-equal "BOM not discarded unless at start of UTF-16 stream" | |
1716 | "a\uFEFFb" | |
3f315b64 | 1717 | (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62))) |
cdd3d6c9 MW |
1718 | |
1719 | (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)" | |
1720 | "a" | |
1721 | (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00))) | |
1722 | ||
1723 | (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0" | |
1724 | '(#\a "a") | |
1725 | (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00) | |
1726 | (lambda (p) | |
1727 | (let ((c (read-char p))) | |
1728 | (seek p 0 SEEK_SET) | |
1729 | (let ((s (read-string p))) | |
1730 | (list c s)))))) | |
1731 | ||
1732 | (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)" | |
1733 | "\uFEFFa" | |
1734 | (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00))) | |
1735 | ||
1736 | (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)" | |
1737 | "a" | |
1738 | (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF | |
1739 | #x00 #x00 #x00 #x61))) | |
1740 | ||
1741 | (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0" | |
1742 | '(#\a "a") | |
1743 | (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF | |
1744 | #x00 #x00 #x00 #x61) | |
1745 | (lambda (p) | |
1746 | (let ((c (read-char p))) | |
1747 | (seek p 0 SEEK_SET) | |
1748 | (let ((s (read-string p))) | |
1749 | (list c s)))))) | |
1750 | ||
1751 | (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)" | |
1752 | "\uFEFFa" | |
1753 | (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF | |
1754 | #x00 #x00 #xFE #xFF | |
1755 | #x00 #x00 #x00 #x61))) | |
1756 | ||
1757 | (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0" | |
1758 | "\uFEFFa" | |
1759 | (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF | |
1760 | #x00 #x00 #xFE #xFF | |
1761 | #x00 #x00 #x00 #x61) | |
1762 | (lambda (p) | |
1763 | (seek p 4 SEEK_SET) | |
1764 | (read-string p)))) | |
1765 | ||
1766 | (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!" | |
1767 | "ab" | |
1768 | (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62) | |
1769 | (lambda (p) | |
1770 | (let ((a (read-char p))) | |
1771 | (set-port-encoding! p "UTF-16") | |
1772 | (string a (read-char p)))))) | |
1773 | ||
1774 | (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!" | |
1775 | "ab" | |
1776 | (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00) | |
1777 | (lambda (p) | |
1778 | (let ((a (read-char p))) | |
1779 | (set-port-encoding! p "UTF-16") | |
1780 | (string a (read-char p)))))) | |
1781 | ||
1782 | (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!" | |
1783 | "ab" | |
1784 | (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 | |
1785 | #x00 #x00 #xFE #xFF | |
1786 | #x00 #x00 #x00 #x62) | |
1787 | (lambda (p) | |
1788 | (let ((a (read-char p))) | |
1789 | (set-port-encoding! p "UTF-32") | |
1790 | (string a (read-char p)))))) | |
1791 | ||
1792 | (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!" | |
1793 | "ab" | |
1794 | (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 | |
1795 | #xFF #xFE #x00 #x00 | |
1796 | #x62 #x00 #x00 #x00) | |
1797 | (lambda (p) | |
1798 | (let ((a (read-char p))) | |
1799 | (set-port-encoding! p "UTF-32") | |
1800 | (string a (read-char p)))))) | |
1801 | ||
1802 | (pass-if-equal "BOM not discarded unless at start of UTF-32 stream" | |
1803 | "a\uFEFFb" | |
3f315b64 | 1804 | (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61 |
f6f4feb0 MW |
1805 | #x00 #x00 #xFE #xFF |
1806 | #x00 #x00 #x00 #x62))) | |
cdd3d6c9 MW |
1807 | |
1808 | (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)" | |
1809 | "a" | |
1810 | (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 | |
1811 | #x61 #x00 #x00 #x00))) | |
1812 | ||
1813 | (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0" | |
1814 | '(#\a "a") | |
1815 | (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00 | |
1816 | #x61 #x00 #x00 #x00) | |
1817 | (lambda (p) | |
1818 | (let ((c (read-char p))) | |
1819 | (seek p 0 SEEK_SET) | |
1820 | (let ((s (read-string p))) | |
1821 | (list c s)))))) | |
1822 | ||
1823 | (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)" | |
1824 | "\uFEFFa" | |
1825 | (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 | |
1826 | #xFF #xFE #x00 #x00 | |
1827 | #x61 #x00 #x00 #x00)))) | |
1828 | ||
1829 | \f | |
1830 | ||
2ae7b7b6 LC |
1831 | (define-syntax-rule (with-load-path path body ...) |
1832 | (let ((new path) | |
1833 | (old %load-path)) | |
1834 | (dynamic-wind | |
1835 | (lambda () | |
1836 | (set! %load-path new)) | |
1837 | (lambda () | |
1838 | body ...) | |
1839 | (lambda () | |
1840 | (set! %load-path old))))) | |
1841 | ||
1842 | (with-test-prefix "%file-port-name-canonicalization" | |
1843 | ||
2a7d614c | 1844 | (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null" |
2ae7b7b6 LC |
1845 | ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead |
1846 | ;; of "/dev/null". See | |
1847 | ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html> | |
1848 | ;; for a discussion. | |
2a7d614c LC |
1849 | (with-load-path (cons "" (delete "/" %load-path)) |
1850 | (with-fluids ((%file-port-name-canonicalization 'relative)) | |
1851 | (port-filename (open-input-file "/dev/null"))))) | |
1852 | ||
1853 | (pass-if-equal "relative canonicalization with /" "dev/null" | |
1854 | (with-load-path (cons "/" %load-path) | |
1855 | (with-fluids ((%file-port-name-canonicalization 'relative)) | |
1856 | (port-filename (open-input-file "/dev/null"))))) | |
1857 | ||
1858 | (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm" | |
1859 | ;; If an entry in %LOAD-PATH is not canonical, then | |
1860 | ;; `scm_i_relativize_path' is unable to do its job. | |
1861 | (if (equal? (map canonicalize-path %load-path) %load-path) | |
1862 | (with-fluids ((%file-port-name-canonicalization 'relative)) | |
1863 | (port-filename | |
1864 | (open-input-file (%search-load-path "ice-9/q.scm")))) | |
1865 | (throw 'unresolved))) | |
1866 | ||
1867 | (pass-if-equal "absolute canonicalization from ice-9" | |
1868 | (canonicalize-path | |
1869 | (string-append (assoc-ref %guile-build-info 'top_srcdir) | |
1870 | "/module/ice-9/q.scm")) | |
1871 | (with-fluids ((%file-port-name-canonicalization 'absolute)) | |
1872 | (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))) | |
2ae7b7b6 | 1873 | |
9235f805 EZ |
1874 | (with-test-prefix "file name separators" |
1875 | ||
1876 | (pass-if "no backslash separators in Windows file names" | |
1877 | ;; In Guile 2.0.11 and earlier, %load-path on Windows could | |
1878 | ;; include file names with backslashes, and `getcwd' on Windows | |
1879 | ;; would always return a directory name with backslashes. | |
1880 | (or (not (file-name-separator? #\\)) | |
1881 | (with-load-path (cons (getcwd) %load-path) | |
1882 | (not (string-index (%search-load-path (basename (test-file))) | |
1883 | #\\)))))) | |
1884 | ||
c56c0f79 | 1885 | (delete-file (test-file)) |
9a201881 LC |
1886 | |
1887 | ;;; Local Variables: | |
1888 | ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3) | |
2ae7b7b6 | 1889 | ;;; eval: (put 'with-load-path 'scheme-indent-function 1) |
9a201881 | 1890 | ;;; End: |