1 ;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
2 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
4 ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
5 ;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
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.
12 ;;;; This library is distributed in the hope that it will be useful,
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;;; Lesser General Public License for more details.
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
21 (define-module (test-suite test-ports)
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)
26 #:use-module (rnrs bytevectors)
27 #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
28 open-bytevector-output-port
34 (define (display-line . args)
35 (for-each display args)
39 (data-file-name "ports-test.tmp"))
42 ;;;; Some general utilities for testing ports.
44 ;; Make sure we are set up for 8-bit Latin-1 data.
45 (fluid-set! %default-port-encoding "ISO-8859-1")
47 (set-port-encoding! p (fluid-ref %default-port-encoding)))
48 (list (current-input-port) (current-output-port)
49 (current-error-port)))
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)
56 (list->string (reverse! chars))
57 (loop (cons char chars))))))
59 (define (read-file filename)
60 (let* ((port (open-input-file filename))
61 (string (read-all port)))
67 (with-test-prefix "%default-port-conversion-strategy"
69 (pass-if "initial value"
70 (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
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"
78 (port-conversion-strategy p)))))
82 (pass-if "(set-port-conversion-strategy! #f sym)"
84 (set-port-conversion-strategy! #f 'error)
85 (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
87 (set-port-conversion-strategy! #f 'substitute)
88 (eq? (fluid-ref %default-port-conversion-strategy)
94 ;;;; Normal file ports.
96 ;;; Write out an s-expression, and read it back.
97 (let ((string '("From fairest creatures we desire increase,"
98 "That thereby beauty's rose might never die,"))
99 (filename (test-file)))
100 (let ((port (open-output-file filename)))
103 (let ((port (open-input-file filename)))
104 (let ((in-string (read port)))
105 (pass-if "file: write and read back list of strings"
106 (equal? string in-string)))
108 (delete-file filename))
110 ;;; Write out a string, and read it back a character at a time.
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)
116 (let ((in-string (read-file filename)))
117 (pass-if "file: write and read back characters"
118 (equal? string in-string)))
119 (delete-file filename))
121 ;;; Buffered input/output port with seeking.
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"
127 (char=? (read-char port) #\e))
128 (pass-if "file: r/w 2"
129 (eof-object? (read-char port)))
130 (seek port -1 SEEK_CUR)
131 (write-char #\x port)
132 (seek port 7 SEEK_SET)
133 (pass-if "file: r/w 3"
134 (char=? (read-char port) #\x))
135 (seek port -2 SEEK_END)
136 (pass-if "file: r/w 4"
137 (char=? (read-char port) #\s))
139 (delete-file filename))
141 ;;; Unbuffered input/output port with seeking.
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"
147 (char=? (read-char port) #\e))
148 (pass-if "file: ub r/w 2"
149 (eof-object? (read-char port)))
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"
154 (char=? (read-char port) #\x))
155 (seek port -2 SEEK_END)
156 (pass-if "file: ub r/w 4"
157 (char=? (read-char port) #\s))
159 (delete-file filename))
161 ;;; Buffered output-only and input-only ports with seeking.
162 (let* ((filename (test-file))
163 (port (open-output-file filename)))
164 (display "J'Accuse" port)
165 (pass-if "file: out tell"
166 (= (seek port 0 SEEK_CUR) 8))
167 (seek port -1 SEEK_CUR)
168 (write-char #\x port)
170 (let ((iport (open-input-file filename)))
171 (pass-if "file: in tell 0"
172 (= (seek iport 0 SEEK_CUR) 0))
174 (pass-if "file: in tell 1"
175 (= (seek iport 0 SEEK_CUR) 1))
176 (unread-char #\z iport)
177 (pass-if "file: in tell 0 after unread"
178 (= (seek iport 0 SEEK_CUR) 0))
179 (pass-if "file: unread char still there"
180 (char=? (read-char iport) #\z))
181 (seek iport 7 SEEK_SET)
182 (pass-if "file: in last char"
183 (char=? (read-char iport) #\x))
185 (delete-file filename))
187 ;;; unusual characters.
188 (let* ((filename (test-file))
189 (port (open-output-file filename)))
190 (display (string #\nul (integer->char 255) (integer->char 128)
193 (let* ((port (open-input-file filename))
194 (line (read-line port)))
195 (pass-if "file: read back NUL 1"
196 (char=? (string-ref line 0) #\nul))
197 (pass-if "file: read back 255"
198 (char=? (string-ref line 1) (integer->char 255)))
199 (pass-if "file: read back 128"
200 (char=? (string-ref line 2) (integer->char 128)))
201 (pass-if "file: read back NUL 2"
202 (char=? (string-ref line 3) #\nul))
204 (eof-object? (read-char port)))
206 (delete-file filename))
208 ;;; line buffering mode.
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))
214 (line (read-line in-port)))
217 (pass-if "file: line buffering"
218 (string=? line test-string)))
219 (delete-file filename))
221 ;;; read-line should use the port encoding (not the locale encoding).
222 (let ((str "ĉu bone?"))
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)))
233 (pass-if "file: read-line honors port encoding"
234 (string=? line str))))
235 (delete-file filename))))
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"))
246 (uniform-vector->list
247 (string->utf8 test-string))))))
248 (write-line test-string port)
250 (let* ((in-port (open-file filename "rb"))
251 (line (read-line in-port)))
253 (delete-file filename)
254 (string=? line binary-test-string)))))
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"))
265 (uniform-vector->list
266 (string->utf8 test-string))))))
267 (write-line ";; coding: utf-8" port)
268 (write-line test-string port)
270 (let* ((in-port (open-file filename "rb"))
271 (line1 (read-line in-port))
272 (line2 (read-line in-port)))
274 (delete-file filename)
275 (string=? line2 binary-test-string)))))
277 ;; open-file ignores file coding declaration by default
278 (pass-if "file: open-file ignores coding declaration by default"
279 (with-fluids ((%default-port-encoding "UTF-8"))
280 (let* ((filename (test-file))
281 (port (open-output-file filename))
282 (test-string "€100"))
283 (write-line ";; coding: iso-8859-15" port)
284 (write-line test-string port)
286 (let* ((in-port (open-input-file filename))
287 (line1 (read-line in-port))
288 (line2 (read-line in-port)))
290 (delete-file filename)
291 (string=? line2 test-string)))))
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)
303 (let* ((in-port (open-input-file filename
304 #:guess-encoding #t))
305 (line1 (read-line in-port))
306 (line2 (read-line in-port)))
308 (delete-file filename)
309 (string=? line2 test-string)))))
311 (with-test-prefix "keyword arguments for file openers"
312 (with-fluids ((%default-port-encoding "UTF-8"))
313 (let ((filename (test-file)))
315 (with-test-prefix "write #:encoding"
317 (pass-if-equal "open-file"
318 #vu8(116 0 101 0 115 0 116 0)
319 (let ((port (open-file filename "w"
320 #:encoding "UTF-16LE")))
321 (display "test" port)
323 (let* ((port (open-file filename "rb"))
324 (bv (get-bytevector-all port)))
328 (pass-if-equal "open-output-file"
329 #vu8(116 0 101 0 115 0 116 0)
330 (let ((port (open-output-file filename
331 #:encoding "UTF-16LE")))
332 (display "test" port)
334 (let* ((port (open-file filename "rb"))
335 (bv (get-bytevector-all port)))
339 (pass-if-equal "call-with-output-file"
340 #vu8(116 0 101 0 115 0 116 0)
341 (call-with-output-file filename
343 (display "test" port))
344 #:encoding "UTF-16LE")
345 (let* ((port (open-file filename "rb"))
346 (bv (get-bytevector-all port)))
350 (pass-if-equal "with-output-to-file"
351 #vu8(116 0 101 0 115 0 116 0)
352 (with-output-to-file filename
355 #:encoding "UTF-16LE")
356 (let* ((port (open-file filename "rb"))
357 (bv (get-bytevector-all port)))
361 (pass-if-equal "with-error-to-file"
362 #vu8(116 0 101 0 115 0 116 0)
366 (display "test" (current-error-port)))
367 #:encoding "UTF-16LE")
368 (let* ((port (open-file filename "rb"))
369 (bv (get-bytevector-all port)))
373 (with-test-prefix "write #:binary"
375 (pass-if-equal "open-output-file"
377 (let* ((port (open-output-file filename #:binary #t))
378 (enc (port-encoding port)))
382 (pass-if-equal "call-with-output-file"
384 (call-with-output-file filename port-encoding #:binary #t))
386 (pass-if-equal "with-output-to-file"
388 (with-output-to-file filename
389 (lambda () (port-encoding (current-output-port)))
392 (pass-if-equal "with-error-to-file"
396 (lambda () (port-encoding (current-error-port)))
399 (with-test-prefix "read #:encoding"
401 (pass-if-equal "open-file read #:encoding"
403 (call-with-output-file filename
405 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
406 (let* ((port (open-file filename "r" #:encoding "UTF-16LE"))
407 (str (read-string port)))
411 (pass-if-equal "open-input-file #:encoding"
413 (call-with-output-file filename
415 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
416 (let* ((port (open-input-file filename #:encoding "UTF-16LE"))
417 (str (read-string port)))
421 (pass-if-equal "call-with-input-file #:encoding"
423 (call-with-output-file filename
425 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
426 (call-with-input-file filename
428 #:encoding "UTF-16LE"))
430 (pass-if-equal "with-input-from-file #:encoding"
432 (call-with-output-file filename
434 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
435 (with-input-from-file filename
437 #:encoding "UTF-16LE")))
439 (with-test-prefix "read #:binary"
441 (pass-if-equal "open-input-file"
443 (let* ((port (open-input-file filename #:binary #t))
444 (enc (port-encoding port)))
448 (pass-if-equal "call-with-input-file"
450 (call-with-input-file filename port-encoding #:binary #t))
452 (pass-if-equal "with-input-from-file"
454 (with-input-from-file filename
455 (lambda () (port-encoding (current-input-port)))
458 (with-test-prefix "#:guess-encoding with coding declaration"
460 (pass-if-equal "open-file"
462 (with-output-to-file filename
465 (write-line "; coding: ISO-8859-15")
467 #:encoding "ISO-8859-15")
468 (let* ((port (open-file filename "r"
470 #:encoding "UTF-16LE"))
471 (str (begin (read-line port)
477 (pass-if-equal "open-input-file"
479 (with-output-to-file filename
482 (write-line "; coding: ISO-8859-15")
484 #:encoding "ISO-8859-15")
485 (let* ((port (open-input-file filename
487 #:encoding "UTF-16LE"))
488 (str (begin (read-line port)
494 (pass-if-equal "call-with-input-file"
496 (with-output-to-file filename
499 (write-line "; coding: ISO-8859-15")
501 #:encoding "ISO-8859-15")
502 (call-with-input-file filename
508 #:encoding "UTF-16LE"))
510 (pass-if-equal "with-input-from-file"
512 (with-output-to-file filename
515 (write-line "; coding: ISO-8859-15")
517 #:encoding "ISO-8859-15")
518 (with-input-from-file filename
524 #:encoding "UTF-16LE")))
526 (with-test-prefix "#:guess-encoding without coding declaration"
528 (pass-if-equal "open-file"
530 (with-output-to-file filename
531 (lambda () (write-line "€100"))
532 #:encoding "ISO-8859-15")
533 (let* ((port (open-file filename "r"
535 #:encoding "ISO-8859-15"))
536 (str (read-line port)))
540 (pass-if-equal "open-input-file"
542 (with-output-to-file filename
543 (lambda () (write-line "€100"))
544 #:encoding "ISO-8859-15")
545 (let* ((port (open-input-file filename
547 #:encoding "ISO-8859-15"))
548 (str (read-line port)))
552 (pass-if-equal "call-with-input-file"
554 (with-output-to-file filename
555 (lambda () (write-line "€100"))
556 #:encoding "ISO-8859-15")
557 (call-with-input-file filename
560 #:encoding "ISO-8859-15"))
562 (pass-if-equal "with-input-from-file"
564 (with-output-to-file filename
565 (lambda () (write-line "€100"))
566 #:encoding "ISO-8859-15")
567 (with-input-from-file filename
570 #:encoding "ISO-8859-15")))
572 (delete-file filename))))
574 ;;; ungetting characters and strings.
575 (with-input-from-string "walk on the moon\nmoon"
578 (unread-char #\a (current-input-port))
579 (pass-if "unread-char"
580 (char=? (read-char) #\a))
582 (let ((replacenoid "chicken enchilada"))
583 (unread-char #\newline (current-input-port))
584 (unread-string replacenoid (current-input-port))
585 (pass-if "unread-string"
586 (string=? (read-line) replacenoid)))
587 (pass-if "unread residue"
588 (string=? (read-line) "moon"))))
590 ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
591 ;;; the reading end. try to read a byte: should get EAGAIN or
592 ;;; EWOULDBLOCK error.
595 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
596 (pass-if "non-blocking-I/O"
598 (lambda () (read-char r) #f)
600 (and (eq? key 'system-error)
601 (let ((errno (car (list-ref args 3))))
603 (= errno EWOULDBLOCK))))))))
606 ;;;; Pipe (popen) ports.
608 ;;; Run a command, and read its output.
609 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
610 (in-string (read-all pipe)))
612 (pass-if "pipe: read"
613 (equal? in-string "Howdy there, partner!\n")))
615 ;;; Run a command, send some output to it, and see if it worked.
616 (let* ((filename (test-file))
617 (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
618 (display "Now Jimmy lives on a mushroom cloud\n" pipe)
619 (display "Mommy, why does everybody have a bomb?\n" pipe)
621 (let ((in-string (read-file filename)))
622 (pass-if "pipe: write"
623 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
624 (delete-file filename))
627 ;;;; Void ports. These are so trivial we don't test them.
632 (with-test-prefix "string ports"
634 ;; Write text to a string port.
635 (let* ((string "Howdy there, partner!")
636 (in-string (call-with-output-string
638 (display string port)
640 (pass-if "display text"
641 (equal? in-string (string-append string "\n"))))
643 ;; Write an s-expression to a string port.
644 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
646 (call-with-input-string (call-with-output-string
650 (pass-if "write/read sexpr"
651 (equal? in-sexpr sexpr)))
653 ;; seeking and unreading from an input string.
654 (let ((text "that text didn't look random to me"))
655 (call-with-input-string text
657 (pass-if "input tell 0"
658 (= (seek p 0 SEEK_CUR) 0))
660 (pass-if "input tell 1"
661 (= (seek p 0 SEEK_CUR) 1))
663 (pass-if "input tell back to 0"
664 (= (seek p 0 SEEK_CUR) 0))
665 (pass-if "input ungetted char"
666 (char=? (read-char p) #\x))
668 (pass-if "input seek to end"
669 (= (seek p 0 SEEK_CUR)
670 (string-length text)))
672 (pass-if "input seek to beginning"
673 (= (seek p 0 SEEK_SET) 0))
674 (pass-if "input reread first char"
675 (char=? (read-char p)
676 (string-ref text 0))))))
678 ;; seeking an output string.
679 (let* ((text (string-copy "123456789"))
680 (len (string-length text))
681 (result (call-with-output-string
683 (pass-if "output tell 0"
684 (= (seek p 0 SEEK_CUR) 0))
686 (pass-if "output tell end"
687 (= (seek p 0 SEEK_CUR) len))
688 (pass-if "output seek to beginning"
689 (= (seek p 0 SEEK_SET) 0))
692 (pass-if "output seek to last char"
693 (= (seek p 0 SEEK_CUR)
695 (write-char #\b p)))))
696 (string-set! text 0 #\a)
697 (string-set! text (- len 1) #\b)
698 (pass-if "output check"
699 (string=? text result)))
701 (pass-if "encoding failure leads to exception"
702 ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
703 ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
704 (catch 'encoding-error
706 (with-fluids ((%default-port-encoding "ISO-8859-1"))
707 (let ((p (open-input-string "λ"))) ; raise an exception
712 ;; At this point, the port-table mutex used to be still held,
713 ;; hence the deadlock. This situation would occur when trying
714 ;; to print a backtrace, for instance.
715 (input-port? (open-input-string "foo")))))
717 (pass-if "%default-port-encoding is honored"
718 (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
719 (equal? (map (lambda (e)
720 (with-fluids ((%default-port-encoding e))
721 (call-with-output-string
723 (and (string=? e (port-encoding p))
724 (display (port-encoding p) p))))))
728 (pass-if "%default-port-conversion-strategy is honored"
729 (let ((strategies '(error substitute escape)))
730 (equal? (map (lambda (s)
731 (with-fluids ((%default-port-conversion-strategy s))
732 (call-with-output-string
734 (and (eq? s (port-conversion-strategy p))
736 (set-port-conversion-strategy! p s)
737 (display (port-conversion-strategy p)
740 (map symbol->string strategies))))
742 (pass-if "suitable encoding [latin-1]"
743 (let ((str "hello, world"))
744 (with-fluids ((%default-port-encoding "ISO-8859-1"))
746 (with-output-to-string
750 (pass-if "suitable encoding [latin-3]"
751 (let ((str "ĉu bone?"))
752 (with-fluids ((%default-port-encoding "ISO-8859-3"))
754 (with-output-to-string
758 (pass-if "wrong encoding, error"
759 (let ((str "ĉu bone?"))
760 (catch 'encoding-error
762 ;; Latin-1 cannot represent ‘ĉ’.
763 (with-fluids ((%default-port-encoding "ISO-8859-1")
764 (%default-port-conversion-strategy 'error))
765 (with-output-to-string
768 #f) ; so the test really fails here
769 (lambda (key subr message errno port chr)
771 (string? (strerror errno)))))))
773 (pass-if "wrong encoding, substitute"
774 (let ((str "ĉu bone?"))
775 (with-fluids ((%default-port-encoding "ISO-8859-1"))
776 (string=? (with-output-to-string
778 (set-port-conversion-strategy! (current-output-port)
783 (pass-if "wrong encoding, escape"
784 (let ((str "ĉu bone?"))
785 (with-fluids ((%default-port-encoding "ISO-8859-1"))
786 (string=? (with-output-to-string
788 (set-port-conversion-strategy! (current-output-port)
793 (pass-if "peek-char [latin-1]"
794 (let ((p (with-fluids ((%default-port-encoding #f))
795 (open-input-string "hello, world"))))
796 (and (char=? (peek-char p) #\h)
797 (char=? (peek-char p) #\h)
798 (char=? (peek-char p) #\h)
800 (= (port-column p) 0))))
802 (pass-if "peek-char [utf-8]"
803 (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
804 (open-input-string "안녕하세요"))))
805 (and (char=? (peek-char p) #\안)
806 (char=? (peek-char p) #\안)
807 (char=? (peek-char p) #\안)
809 (= (port-column p) 0))))
811 (pass-if "peek-char [utf-16]"
812 (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
813 (open-input-string "안녕하세요"))))
814 (and (char=? (peek-char p) #\안)
815 (char=? (peek-char p) #\안)
816 (char=? (peek-char p) #\안)
818 (= (port-column p) 0))))
820 ;; Mini DSL to test decoding error handling.
821 (letrec-syntax ((decoding-error?
824 (catch 'decoding-error
828 (lambda (key subr message errno p)
830 (not (= 0 errno))))))))
832 (syntax-rules (-> error eof)
833 ((_ port (proc -> error))
835 (port-conversion-strategy port))
836 (eqv? (proc port) #\?)
837 (decoding-error? port (proc port))))
838 ((_ port (proc -> eof))
839 (eof-object? (proc port)))
840 ((_ port (proc -> char))
841 (eqv? (proc port) char))))
845 (and (make-check port check) ...))))
846 (make-peek+read-checks
848 ((_ port (result ...) e1 expected ...)
849 (make-peek+read-checks port
854 ((_ port (result ...))
855 (make-checks port result ...))
856 ((_ port #f e1 expected ...)
857 (make-peek+read-checks port
862 (test-decoding-error*
864 ((_ sequence encoding strategy (expected ...))
866 (pass-if (format #f "test-decoding-error: ~s ~s ~s"
867 'sequence encoding strategy)
868 (let ((p (open-bytevector-input-port
869 (u8-list->bytevector 'sequence))))
870 (set-port-encoding! p encoding)
871 (set-port-conversion-strategy! p strategy)
873 (read-char -> expected) ...)))
875 ;; Generate the same test, but with one
876 ;; `peek-char' call before each `read-char'.
877 ;; Both should yield the same result.
878 (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
879 'sequence encoding strategy)
880 (let ((p (open-bytevector-input-port
881 (u8-list->bytevector 'sequence))))
882 (set-port-encoding! p encoding)
883 (set-port-conversion-strategy! p strategy)
884 (make-peek+read-checks p #f expected
888 ((_ sequence encoding (expected ...))
890 (test-decoding-error* sequence encoding 'error
893 ;; `escape' should behave exactly like `error'.
894 (test-decoding-error* sequence encoding 'escape
897 (test-decoding-error* sequence encoding 'substitute
900 (test-decoding-error (255 65 66 67) "UTF-8"
901 (error #\A #\B #\C eof))
903 (test-decoding-error (255 206 187 206 188) "UTF-8"
906 (test-decoding-error (206 187 206) "UTF-8"
907 ;; Unterminated sequence.
910 ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
911 ;; of the "Conformance" chapter of Unicode 6.0.0.)
913 (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
914 (error ;; C0: should be in the C2..DF range
919 (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
920 ;; Section 3.9 of Unicode 6.0.0 reads:
921 ;; "If the converter encounters an ill-formed UTF-8 code unit
922 ;; sequence which starts with a valid first byte, but which does
923 ;; not continue with valid successor bytes (see Table 3-7), it
924 ;; must not consume the successor bytes".
925 ;; Glibc/libiconv do not conform to it and instead swallow the
926 ;; #x41. This example appears literally in Section 3.9.
927 (error ;; 41: invalid successor
928 #\A ;; 41: valid starting byte
932 (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
933 ;; According to Unicode 6.0.0, Section 3.9, "the only formal
934 ;; requirement mandated by Unicode conformance for a converter is
935 ;; that the <41> be processed and correctly interpreted as
937 (error ;; 2nd byte should be in the A0..BF range
938 error ;; 80: not a valid starting byte
939 error ;; 80: not a valid starting byte
943 (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
944 (error ;; 3rd byte should be in the 80..BF range
949 (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
950 (error ;; 2nd byte should be in the 90..BF range
951 error ;; 88: not a valid starting byte
952 error ;; 88: not a valid starting byte
953 error ;; 88: not a valid starting byte
956 (with-test-prefix "call-with-output-string"
958 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
960 (pass-if-exception "proc closes port" exception:wrong-type-arg
961 (call-with-output-string close-port)))
965 ;;;; Soft ports. No tests implemented yet.
968 ;;;; Generic operations across all port types.
970 (let ((port-loop-temp (test-file)))
972 ;; Return a list of input ports that all return the same text.
973 ;; We map tests over this list.
974 (define (input-port-list text)
976 ;; Create a text file some of the ports will use.
977 (let ((out-port (open-output-file port-loop-temp)))
978 (display text out-port)
979 (close-port out-port))
981 (list (open-input-file port-loop-temp)
982 (open-input-pipe (string-append "cat " port-loop-temp))
983 (call-with-input-string text (lambda (x) x))
984 ;; We don't test soft ports at the moment.
987 (define port-list-names '("file" "pipe" "string"))
989 ;; Test the line counter.
990 (define (test-line-counter text second-line final-column)
991 (with-test-prefix "line counter"
992 (let ((ports (input-port-list text)))
994 (lambda (port port-name)
995 (with-test-prefix port-name
996 (pass-if "at beginning of input"
997 (= (port-line port) 0))
998 (pass-if "read first character"
999 (eqv? (read-char port) #\x))
1000 (pass-if "after reading one character"
1001 (= (port-line port) 0))
1002 (pass-if "read first newline"
1003 (eqv? (read-char port) #\newline))
1004 (pass-if "after reading first newline char"
1005 (= (port-line port) 1))
1006 (pass-if "second line read correctly"
1007 (equal? (read-line port) second-line))
1008 (pass-if "read-line increments line number"
1009 (= (port-line port) 2))
1010 (pass-if "read-line returns EOF"
1013 ((eof-object? (read-line port)) #t)
1015 (else (loop (+ i 1))))))
1016 (pass-if "line count is 5 at EOF"
1017 (= (port-line port) 5))
1018 (pass-if "column is correct at EOF"
1019 (= (port-column port) final-column))))
1020 ports port-list-names)
1021 (for-each close-port ports)
1022 (delete-file port-loop-temp))))
1024 (with-test-prefix "newline"
1026 (string-append "x\n"
1027 "He who receives an idea from me, receives instruction\n"
1028 "himself without lessening mine; as he who lights his\n"
1029 "taper at mine, receives light without darkening me.\n"
1030 " --- Thomas Jefferson\n")
1031 "He who receives an idea from me, receives instruction"
1034 (with-test-prefix "no newline"
1036 (string-append "x\n"
1037 "He who receives an idea from me, receives instruction\n"
1038 "himself without lessening mine; as he who lights his\n"
1039 "taper at mine, receives light without darkening me.\n"
1040 " --- Thomas Jefferson\n"
1042 "He who receives an idea from me, receives instruction"
1045 ;; Test port-line and port-column for output ports
1047 (define (test-output-line-counter text final-column)
1048 (with-test-prefix "port-line and port-column for output ports"
1049 (let ((port (open-output-string)))
1050 (pass-if "at beginning of input"
1051 (and (= (port-line port) 0)
1052 (= (port-column port) 0)))
1053 (write-char #\x port)
1054 (pass-if "after writing one character"
1055 (and (= (port-line port) 0)
1056 (= (port-column port) 1)))
1057 (write-char #\newline port)
1058 (pass-if "after writing first newline char"
1059 (and (= (port-line port) 1)
1060 (= (port-column port) 0)))
1062 (pass-if "line count is 5 at end"
1063 (= (port-line port) 5))
1064 (pass-if "column is correct at end"
1065 (= (port-column port) final-column)))))
1067 (test-output-line-counter
1068 (string-append "He who receives an idea from me, receives instruction\n"
1069 "himself without lessening mine; as he who lights his\n"
1070 "taper at mine, receives light without darkening me.\n"
1071 " --- Thomas Jefferson\n"
1075 (with-test-prefix "port-column"
1077 (with-test-prefix "output"
1080 (let ((port (open-output-string)))
1082 (= 1 (port-column port))))
1085 (let ((port (open-output-string)))
1087 (= 0 (port-column port))))
1090 (let ((port (open-output-string)))
1091 (display "x\a" port)
1092 (= 1 (port-column port))))
1094 (pass-if "\\x08 backspace"
1095 (let ((port (open-output-string)))
1096 (display "\x08" port)
1097 (= 0 (port-column port))))
1099 (pass-if "x\\x08 backspace"
1100 (let ((port (open-output-string)))
1101 (display "x\x08" port)
1102 (= 0 (port-column port))))
1105 (let ((port (open-output-string)))
1107 (= 0 (port-column port))))
1110 (let ((port (open-output-string)))
1111 (display "x\n" port)
1112 (= 0 (port-column port))))
1115 (let ((port (open-output-string)))
1117 (= 0 (port-column port))))
1120 (let ((port (open-output-string)))
1121 (display "x\r" port)
1122 (= 0 (port-column port))))
1125 (let ((port (open-output-string)))
1127 (= 8 (port-column port))))
1130 (let ((port (open-output-string)))
1131 (display "x\t" port)
1132 (= 8 (port-column port)))))
1134 (with-test-prefix "input"
1137 (let ((port (open-input-string "x")))
1138 (while (not (eof-object? (read-char port))))
1139 (= 1 (port-column port))))
1142 (let ((port (open-input-string "\a")))
1143 (while (not (eof-object? (read-char port))))
1144 (= 0 (port-column port))))
1147 (let ((port (open-input-string "x\a")))
1148 (while (not (eof-object? (read-char port))))
1149 (= 1 (port-column port))))
1151 (pass-if "\\x08 backspace"
1152 (let ((port (open-input-string "\x08")))
1153 (while (not (eof-object? (read-char port))))
1154 (= 0 (port-column port))))
1156 (pass-if "x\\x08 backspace"
1157 (let ((port (open-input-string "x\x08")))
1158 (while (not (eof-object? (read-char port))))
1159 (= 0 (port-column port))))
1162 (let ((port (open-input-string "\n")))
1163 (while (not (eof-object? (read-char port))))
1164 (= 0 (port-column port))))
1167 (let ((port (open-input-string "x\n")))
1168 (while (not (eof-object? (read-char port))))
1169 (= 0 (port-column port))))
1172 (let ((port (open-input-string "\r")))
1173 (while (not (eof-object? (read-char port))))
1174 (= 0 (port-column port))))
1177 (let ((port (open-input-string "x\r")))
1178 (while (not (eof-object? (read-char port))))
1179 (= 0 (port-column port))))
1182 (let ((port (open-input-string "\t")))
1183 (while (not (eof-object? (read-char port))))
1184 (= 8 (port-column port))))
1187 (let ((port (open-input-string "x\t")))
1188 (while (not (eof-object? (read-char port))))
1189 (= 8 (port-column port))))))
1191 (with-test-prefix "port-line"
1193 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
1194 ;; scm_t_port actually holds a long; this restricted the range on 64-bit
1196 (pass-if "set most-positive-fixnum/2"
1197 (let ((n (quotient most-positive-fixnum 2))
1198 (port (open-output-string)))
1199 (set-port-line! port n)
1200 (eqv? n (port-line port)))))
1202 (with-test-prefix "port-encoding"
1204 (pass-if-exception "set-port-encoding!, wrong encoding"
1205 exception:miscellaneous-error
1206 (let ((p (open-input-string "")))
1207 (set-port-encoding! p "does-not-exist")
1210 (pass-if-exception "%default-port-encoding, wrong encoding"
1211 exception:miscellaneous-error
1212 (read (with-fluids ((%default-port-encoding "does-not-exist"))
1213 (open-input-string "")))))
1219 (with-test-prefix "port-for-each"
1221 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
1222 ;; its iterator func if a port was inaccessible in the last gc mark but
1223 ;; the lazy sweeping has not yet reached it to remove it from the port
1224 ;; table (scm_i_port_table). Provoking those gc conditions is a little
1225 ;; tricky, but the following code made it happen in 1.8.2.
1226 (pass-if "passing freed cell"
1228 ;; clear out the heap
1230 ;; allocate cells so the opened ports aren't at the start of the heap
1232 (open-input-file "/dev/null")
1234 (open-input-file "/dev/null")
1235 ;; this gc leaves the above ports unmarked, ie. inaccessible
1237 ;; but they're still in the port table, so this sees them
1238 (port-for-each (lambda (port)
1239 (set! lst (cons port lst))))
1240 ;; this forces completion of the sweeping
1242 ;; and (if the bug is present) the cells accumulated in LST are now
1243 ;; freed cells, which give #f from `port?'
1244 (not (memq #f (map port? lst))))))
1248 (pass-if "fdes->ports finds port"
1249 (let ((port (open-file (test-file) "w")))
1251 (not (not (memq port (fdes->ports (port->fdes port))))))))
1257 (with-test-prefix "seek"
1259 (with-test-prefix "file port"
1262 (call-with-output-file (test-file)
1264 (display "abcde" port)))
1265 (let ((port (open-file (test-file) "r")))
1267 (seek port 2 SEEK_CUR)
1268 (eqv? #\d (read-char port))))
1271 (call-with-output-file (test-file)
1273 (display "abcde" port)))
1274 (let ((port (open-file (test-file) "r")))
1276 (seek port 3 SEEK_SET)
1277 (eqv? #\d (read-char port))))
1280 (call-with-output-file (test-file)
1282 (display "abcde" port)))
1283 (let ((port (open-file (test-file) "r")))
1285 (seek port -2 SEEK_END)
1286 (eqv? #\d (read-char port))))))
1292 (with-test-prefix "truncate-file"
1294 (pass-if-exception "flonum file" exception:wrong-type-arg
1295 (truncate-file 1.0 123))
1297 (pass-if-exception "frac file" exception:wrong-type-arg
1298 (truncate-file 7/3 123))
1300 (with-test-prefix "filename"
1302 (pass-if-exception "flonum length" exception:wrong-type-arg
1303 (call-with-output-file (test-file)
1305 (display "hello" port)))
1306 (truncate-file (test-file) 1.0))
1309 (call-with-output-file (test-file)
1311 (display "hello" port)))
1312 (truncate-file (test-file) 1)
1313 (eqv? 1 (stat:size (stat (test-file)))))
1315 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
1316 (call-with-output-file (test-file)
1318 (display "hello" port)))
1319 (truncate-file (test-file))))
1321 (with-test-prefix "file descriptor"
1324 (call-with-output-file (test-file)
1326 (display "hello" port)))
1327 (let ((fd (open-fdes (test-file) O_RDWR)))
1328 (truncate-file fd 1)
1330 (eqv? 1 (stat:size (stat (test-file)))))
1332 (pass-if "shorten to current pos"
1333 (call-with-output-file (test-file)
1335 (display "hello" port)))
1336 (let ((fd (open-fdes (test-file) O_RDWR)))
1337 (seek fd 1 SEEK_SET)
1340 (eqv? 1 (stat:size (stat (test-file))))))
1342 (with-test-prefix "file port"
1345 (call-with-output-file (test-file)
1347 (display "hello" port)))
1348 (let ((port (open-file (test-file) "r+")))
1349 (truncate-file port 1))
1350 (eqv? 1 (stat:size (stat (test-file)))))
1352 (pass-if "shorten to current pos"
1353 (call-with-output-file (test-file)
1355 (display "hello" port)))
1356 (let ((port (open-file (test-file) "r+")))
1358 (truncate-file port))
1359 (eqv? 1 (stat:size (stat (test-file)))))))
1362 ;;;; testing read-delimited and friends
1364 (with-test-prefix "read-delimited!"
1365 (let ((c (make-string 20 #\!)))
1366 (call-with-input-string
1370 (read-delimited! "\n" c port 'concat)
1371 (pass-if "read-delimited! reads a first line"
1372 (string=? c "defdef\n!!!!!!!!!!!!!"))
1374 (read-delimited! "\n" c port 'concat 3)
1375 (pass-if "read-delimited! reads a first line"
1376 (string=? c "defghighi\n!!!!!!!!!!"))))))
1381 (call-with-input-string
1384 (pass-if "char-ready? returns true on string port"
1385 (char-ready? port))))
1387 ;;; This segfaults on some versions of Guile. We really should run
1388 ;;; the tests in a subprocess...
1390 (call-with-input-string
1393 (with-input-from-port
1396 (pass-if "char-ready? returns true on string port as default port"
1400 ;;;; pending-eof behavior
1402 (with-test-prefix "pending EOF behavior"
1403 ;; Make a test port that will produce the given sequence. Each
1404 ;; element of 'lst' may be either a character or #f (which means EOF).
1405 (define (test-soft-port . lst)
1407 (vector (lambda (c) #f) ; write char
1408 (lambda (s) #f) ; write string
1409 (lambda () #f) ; flush
1410 (lambda () ; read char
1411 (let ((c (car lst)))
1412 (set! lst (cdr lst))
1414 (lambda () #f)) ; close
1417 (define (call-with-port p proc)
1420 (lambda () (proc p))
1421 (lambda () (close-port p))))
1423 (define (call-with-test-file str proc)
1424 (let ((filename (test-file)))
1426 (lambda () (call-with-output-file filename
1427 (lambda (p) (display str p))))
1428 (lambda () (call-with-input-file filename proc))
1429 (lambda () (delete-file (test-file))))))
1431 (pass-if "peek-char does not swallow EOF (soft port)"
1432 (call-with-port (test-soft-port #\a #f #\b)
1434 (and (char=? #\a (peek-char p))
1435 (char=? #\a (read-char p))
1436 (eof-object? (peek-char p))
1437 (eof-object? (read-char p))
1438 (char=? #\b (peek-char p))
1439 (char=? #\b (read-char p))))))
1441 (pass-if "unread clears pending EOF (soft port)"
1442 (call-with-port (test-soft-port #\a #f #\b)
1444 (and (char=? #\a (read-char p))
1445 (eof-object? (peek-char p))
1446 (begin (unread-char #\u p)
1447 (char=? #\u (read-char p)))))))
1449 (pass-if "unread clears pending EOF (string port)"
1450 (call-with-input-string "a"
1452 (and (char=? #\a (read-char p))
1453 (eof-object? (peek-char p))
1454 (begin (unread-char #\u p)
1455 (char=? #\u (read-char p)))))))
1457 (pass-if "unread clears pending EOF (file port)"
1458 (call-with-test-file
1461 (and (char=? #\a (read-char p))
1462 (eof-object? (peek-char p))
1463 (begin (unread-char #\u p)
1464 (char=? #\u (read-char p)))))))
1466 (pass-if "seek clears pending EOF (string port)"
1467 (call-with-input-string "a"
1469 (and (char=? #\a (read-char p))
1470 (eof-object? (peek-char p))
1471 (begin (seek p 0 SEEK_SET)
1472 (char=? #\a (read-char p)))))))
1474 (pass-if "seek clears pending EOF (file port)"
1475 (call-with-test-file
1478 (and (char=? #\a (read-char p))
1479 (eof-object? (peek-char p))
1480 (begin (seek p 0 SEEK_SET)
1481 (char=? #\a (read-char p))))))))
1484 ;;;; Close current-input-port, and make sure everyone can handle it.
1486 (with-test-prefix "closing current-input-port"
1487 (for-each (lambda (procedure name)
1488 (with-input-from-port
1489 (call-with-input-string "foo" (lambda (p) p))
1491 (close-port (current-input-port))
1492 (pass-if-exception name
1493 exception:wrong-type-arg
1495 (list read read-char read-line)
1496 '("read" "read-char" "read-line")))
1500 (with-test-prefix "setvbuf"
1502 (pass-if "line/column number preserved"
1503 ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1504 ;; line and/or column number.
1505 (call-with-output-file (test-file)
1507 (display "This is GNU Guile.\nWelcome." p)))
1508 (call-with-input-file (test-file)
1510 (and (eqv? #\T (read-char p))
1511 (let ((line (port-line p))
1512 (col (port-column p)))
1513 (and (= line 0) (= col 1)
1515 (setvbuf p _IOFBF 777)
1516 (let ((line* (port-line p))
1517 (col* (port-column p)))
1519 (= col col*)))))))))))
1523 (pass-if-equal "unget-bytevector"
1524 #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
1525 1 2 3 4 251 253 254 255)
1526 (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
1527 (unget-bytevector port #vu8(200 201 202 203))
1528 (unget-bytevector port #vu8(20 21 22 23 24))
1529 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
1530 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
1531 (unget-bytevector port #vu8(10 11))
1532 (get-bytevector-all port)))
1536 (with-test-prefix "unicode byte-order marks (BOMs)"
1538 (define (bv-read-test* encoding bv proc)
1539 (let ((port (open-bytevector-input-port bv)))
1540 (set-port-encoding! port encoding)
1543 (define (bv-read-test encoding bv)
1544 (bv-read-test* encoding bv read-string))
1546 (define (bv-write-test* encoding proc)
1548 (lambda () (open-bytevector-output-port))
1549 (lambda (port get-bytevector)
1550 (set-port-encoding! port encoding)
1554 (define (bv-write-test encoding str)
1555 (bv-write-test* encoding
1559 (pass-if-equal "BOM not discarded from Latin-1 stream"
1561 (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
1563 (pass-if-equal "BOM not discarded from Latin-2 stream"
1564 "\u010F\u0165\u017C\x61"
1565 (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
1567 (pass-if-equal "BOM not discarded from UTF-16BE stream"
1569 (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
1571 (pass-if-equal "BOM not discarded from UTF-16LE stream"
1573 (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
1575 (pass-if-equal "BOM not discarded from UTF-32BE stream"
1577 (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
1578 #x00 #x00 #x00 #x61)))
1580 (pass-if-equal "BOM not discarded from UTF-32LE stream"
1582 (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
1583 #x61 #x00 #x00 #x00)))
1585 (pass-if-equal "BOM not written to UTF-8 stream"
1587 (bv-write-test "UTF-8" "a"))
1589 (pass-if-equal "BOM not written to UTF-16BE stream"
1591 (bv-write-test "UTF-16BE" "a"))
1593 (pass-if-equal "BOM not written to UTF-16LE stream"
1595 (bv-write-test "UTF-16LE" "a"))
1597 (pass-if-equal "BOM not written to UTF-32BE stream"
1598 #vu8(#x00 #x00 #x00 #x61)
1599 (bv-write-test "UTF-32BE" "a"))
1601 (pass-if-equal "BOM not written to UTF-32LE stream"
1602 #vu8(#x61 #x00 #x00 #x00)
1603 (bv-write-test "UTF-32LE" "a"))
1605 (pass-if "Don't read from the port unless user asks to"
1606 (let* ((p (make-soft-port
1608 (lambda (c) #f) ; write char
1609 (lambda (s) #f) ; write string
1610 (lambda () #f) ; flush
1611 (lambda () (throw 'fail)) ; read char
1614 (set-port-encoding! p "UTF-16")
1616 (set-port-encoding! p "UTF-32")
1620 ;; TODO: test that input and output streams are independent when
1621 ;; appropriate, and linked when appropriate.
1623 (pass-if-equal "BOM discarded from start of UTF-8 stream"
1625 (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
1627 (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
1629 (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
1631 (let ((c (read-char p)))
1633 (let ((s (read-string p)))
1636 (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
1638 (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
1640 (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
1642 (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
1647 (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
1649 (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
1651 (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
1652 #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
1653 (bv-write-test "UTF-16" "ab"))
1655 (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
1656 #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
1657 (bv-write-test* "UTF-16"
1660 (set-port-encoding! p "UTF-16")
1663 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
1665 (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
1667 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
1669 (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
1671 (let ((c (read-char p)))
1673 (let ((s (read-string p)))
1676 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
1678 (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
1680 (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
1682 (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
1687 (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
1689 (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
1691 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
1693 (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
1695 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
1697 (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
1699 (let ((c (read-char p)))
1701 (let ((s (read-string p)))
1704 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
1706 (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
1708 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
1710 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1711 #x00 #x00 #x00 #x61)))
1713 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
1715 (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
1716 #x00 #x00 #x00 #x61)
1718 (let ((c (read-char p)))
1720 (let ((s (read-string p)))
1723 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
1725 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1727 #x00 #x00 #x00 #x61)))
1729 (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
1731 (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
1733 #x00 #x00 #x00 #x61)
1738 (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
1740 (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
1742 (let ((a (read-char p)))
1743 (set-port-encoding! p "UTF-16")
1744 (string a (read-char p))))))
1746 (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
1748 (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
1750 (let ((a (read-char p)))
1751 (set-port-encoding! p "UTF-16")
1752 (string a (read-char p))))))
1754 (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
1756 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1758 #x00 #x00 #x00 #x62)
1760 (let ((a (read-char p)))
1761 (set-port-encoding! p "UTF-32")
1762 (string a (read-char p))))))
1764 (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
1766 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1768 #x62 #x00 #x00 #x00)
1770 (let ((a (read-char p)))
1771 (set-port-encoding! p "UTF-32")
1772 (string a (read-char p))))))
1774 (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
1776 (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
1778 #x00 #x00 #x00 #x62)))
1780 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
1782 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1783 #x61 #x00 #x00 #x00)))
1785 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
1787 (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
1788 #x61 #x00 #x00 #x00)
1790 (let ((c (read-char p)))
1792 (let ((s (read-string p)))
1795 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
1797 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1799 #x61 #x00 #x00 #x00))))
1803 (define-syntax-rule (with-load-path path body ...)
1808 (set! %load-path new))
1812 (set! %load-path old)))))
1814 (with-test-prefix "%file-port-name-canonicalization"
1816 (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
1817 ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
1818 ;; of "/dev/null". See
1819 ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
1820 ;; for a discussion.
1821 (with-load-path (cons "" (delete "/" %load-path))
1822 (with-fluids ((%file-port-name-canonicalization 'relative))
1823 (port-filename (open-input-file "/dev/null")))))
1825 (pass-if-equal "relative canonicalization with /" "dev/null"
1826 (with-load-path (cons "/" %load-path)
1827 (with-fluids ((%file-port-name-canonicalization 'relative))
1828 (port-filename (open-input-file "/dev/null")))))
1830 (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
1831 ;; If an entry in %LOAD-PATH is not canonical, then
1832 ;; `scm_i_relativize_path' is unable to do its job.
1833 (if (equal? (map canonicalize-path %load-path) %load-path)
1834 (with-fluids ((%file-port-name-canonicalization 'relative))
1836 (open-input-file (%search-load-path "ice-9/q.scm"))))
1837 (throw 'unresolved)))
1839 (pass-if-equal "absolute canonicalization from ice-9"
1841 (string-append (assoc-ref %guile-build-info 'top_srcdir)
1842 "/module/ice-9/q.scm"))
1843 (with-fluids ((%file-port-name-canonicalization 'absolute))
1844 (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
1846 (delete-file (test-file))
1848 ;;; Local Variables:
1849 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
1850 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)