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, 2014, 2015 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"))
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"))
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 (pass-if-exception "invalid wide mode string"
312 exception:out-of-range
313 (open-file "/dev/null" "λ"))
315 (pass-if "valid wide mode string"
316 ;; Pass 'open-file' a valid mode string, but as a wide string.
318 (string-set! mode 0 #\r)
319 (let ((port (open-file "/dev/null" mode)))
320 (and (input-port? port)
325 (with-test-prefix "keyword arguments for file openers"
326 (with-fluids ((%default-port-encoding "UTF-8"))
327 (let ((filename (test-file)))
329 (with-test-prefix "write #:encoding"
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)
337 (let* ((port (open-file filename "rb"))
338 (bv (get-bytevector-all port)))
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)
348 (let* ((port (open-file filename "rb"))
349 (bv (get-bytevector-all port)))
353 (pass-if-equal "call-with-output-file"
354 #vu8(116 0 101 0 115 0 116 0)
355 (call-with-output-file filename
357 (display "test" port))
358 #:encoding "UTF-16LE")
359 (let* ((port (open-file filename "rb"))
360 (bv (get-bytevector-all port)))
364 (pass-if-equal "with-output-to-file"
365 #vu8(116 0 101 0 115 0 116 0)
366 (with-output-to-file filename
369 #:encoding "UTF-16LE")
370 (let* ((port (open-file filename "rb"))
371 (bv (get-bytevector-all port)))
375 (pass-if-equal "with-error-to-file"
376 #vu8(116 0 101 0 115 0 116 0)
380 (display "test" (current-error-port)))
381 #:encoding "UTF-16LE")
382 (let* ((port (open-file filename "rb"))
383 (bv (get-bytevector-all port)))
387 (with-test-prefix "write #:binary"
389 (pass-if-equal "open-output-file"
391 (let* ((port (open-output-file filename #:binary #t))
392 (enc (port-encoding port)))
396 (pass-if-equal "call-with-output-file"
398 (call-with-output-file filename port-encoding #:binary #t))
400 (pass-if-equal "with-output-to-file"
402 (with-output-to-file filename
403 (lambda () (port-encoding (current-output-port)))
406 (pass-if-equal "with-error-to-file"
410 (lambda () (port-encoding (current-error-port)))
413 (with-test-prefix "read #:encoding"
415 (pass-if-equal "open-file read #:encoding"
417 (call-with-output-file filename
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)))
425 (pass-if-equal "open-input-file #:encoding"
427 (call-with-output-file filename
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)))
435 (pass-if-equal "call-with-input-file #:encoding"
437 (call-with-output-file filename
439 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
440 (call-with-input-file filename
442 #:encoding "UTF-16LE"))
444 (pass-if-equal "with-input-from-file #:encoding"
446 (call-with-output-file filename
448 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
449 (with-input-from-file filename
451 #:encoding "UTF-16LE")))
453 (with-test-prefix "read #:binary"
455 (pass-if-equal "open-input-file"
457 (let* ((port (open-input-file filename #:binary #t))
458 (enc (port-encoding port)))
462 (pass-if-equal "call-with-input-file"
464 (call-with-input-file filename port-encoding #:binary #t))
466 (pass-if-equal "with-input-from-file"
468 (with-input-from-file filename
469 (lambda () (port-encoding (current-input-port)))
472 (with-test-prefix "#:guess-encoding with coding declaration"
474 (pass-if-equal "open-file"
476 (with-output-to-file filename
479 (write-line "; coding: ISO-8859-15")
481 #:encoding "ISO-8859-15")
482 (let* ((port (open-file filename "r"
484 #:encoding "UTF-16LE"))
485 (str (begin (read-line port)
491 (pass-if-equal "open-input-file"
493 (with-output-to-file filename
496 (write-line "; coding: ISO-8859-15")
498 #:encoding "ISO-8859-15")
499 (let* ((port (open-input-file filename
501 #:encoding "UTF-16LE"))
502 (str (begin (read-line port)
508 (pass-if-equal "call-with-input-file"
510 (with-output-to-file filename
513 (write-line "; coding: ISO-8859-15")
515 #:encoding "ISO-8859-15")
516 (call-with-input-file filename
522 #:encoding "UTF-16LE"))
524 (pass-if-equal "with-input-from-file"
526 (with-output-to-file filename
529 (write-line "; coding: ISO-8859-15")
531 #:encoding "ISO-8859-15")
532 (with-input-from-file filename
538 #:encoding "UTF-16LE")))
540 (with-test-prefix "#:guess-encoding without coding declaration"
542 (pass-if-equal "open-file"
544 (with-output-to-file filename
545 (lambda () (write-line "€100"))
546 #:encoding "ISO-8859-15")
547 (let* ((port (open-file filename "r"
549 #:encoding "ISO-8859-15"))
550 (str (read-line port)))
554 (pass-if-equal "open-input-file"
556 (with-output-to-file filename
557 (lambda () (write-line "€100"))
558 #:encoding "ISO-8859-15")
559 (let* ((port (open-input-file filename
561 #:encoding "ISO-8859-15"))
562 (str (read-line port)))
566 (pass-if-equal "call-with-input-file"
568 (with-output-to-file filename
569 (lambda () (write-line "€100"))
570 #:encoding "ISO-8859-15")
571 (call-with-input-file filename
574 #:encoding "ISO-8859-15"))
576 (pass-if-equal "with-input-from-file"
578 (with-output-to-file filename
579 (lambda () (write-line "€100"))
580 #:encoding "ISO-8859-15")
581 (with-input-from-file filename
584 #:encoding "ISO-8859-15")))
586 (delete-file filename))))
588 ;;; ungetting characters and strings.
589 (with-input-from-string "walk on the moon\nmoon"
592 (unread-char #\a (current-input-port))
593 (pass-if "unread-char"
594 (char=? (read-char) #\a))
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"))))
604 ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
605 ;;; the reading end. try to read a byte: should get EAGAIN or
606 ;;; EWOULDBLOCK error.
609 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
610 (pass-if "non-blocking-I/O"
612 (lambda () (read-char r) #f)
614 (and (eq? key 'system-error)
615 (let ((errno (car (list-ref args 3))))
617 (= errno EWOULDBLOCK))))))))
620 ;;;; Pipe (popen) ports.
622 ;;; Run a command, and read its output.
623 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
624 (in-string (read-all pipe)))
626 (pass-if "pipe: read"
627 (equal? in-string "Howdy there, partner!\n")))
629 ;;; Run a command, send some output to it, and see if it worked.
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)
635 (let ((in-string (read-file filename)))
636 (pass-if "pipe: write"
637 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
638 (delete-file filename))
640 (pass-if-equal "pipe, fdopen, and _IOLBF"
642 (let ((in+out (pipe))
643 (pid (primitive-fork)))
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)))
657 (primitive-_exit 0)))
659 (close-port (cdr in+out))
660 (let ((str (read-all (car in+out))))
665 ;;;; Void ports. These are so trivial we don't test them.
670 (with-test-prefix "string ports"
672 ;; Write text to a string port.
673 (let* ((string "Howdy there, partner!")
674 (in-string (call-with-output-string
676 (display string port)
678 (pass-if "display text"
679 (equal? in-string (string-append string "\n"))))
681 ;; Write an s-expression to a string port.
682 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
684 (call-with-input-string (call-with-output-string
688 (pass-if "write/read sexpr"
689 (equal? in-sexpr sexpr)))
691 ;; seeking and unreading from an input string.
692 (let ((text "that text didn't look random to me"))
693 (call-with-input-string text
695 (pass-if "input tell 0"
696 (= (seek p 0 SEEK_CUR) 0))
698 (pass-if "input tell 1"
699 (= (seek p 0 SEEK_CUR) 1))
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))
706 (pass-if "input seek to end"
707 (= (seek p 0 SEEK_CUR)
708 (string-length text)))
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))))))
716 ;; seeking an output string.
717 (let* ((text (string-copy "123456789"))
718 (len (string-length text))
719 (result (call-with-output-string
721 (pass-if "output tell 0"
722 (= (seek p 0 SEEK_CUR) 0))
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))
730 (pass-if "output seek to last char"
731 (= (seek p 0 SEEK_CUR)
733 (write-char #\b p)))))
734 (string-set! text 0 #\a)
735 (string-set! text (- len 1) #\b)
736 (pass-if "output check"
737 (string=? text result)))
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
745 (set-port-conversion-strategy! p 'substitute)
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
755 (and (eq? s (port-conversion-strategy p))
757 (set-port-conversion-strategy! p s)
758 (display (port-conversion-strategy p)
761 (map symbol->string strategies))))
763 (pass-if "suitable encoding [latin-1]"
764 (let ((str "hello, world")
765 (encoding "ISO-8859-1"))
767 (call-with-output-string
769 (set-port-encoding! p encoding)
772 (pass-if "suitable encoding [latin-3]"
773 (let ((str "ĉu bone?")
774 (encoding "ISO-8859-3"))
776 (call-with-output-string
778 (set-port-encoding! p encoding)
781 (pass-if "wrong encoding, error"
782 (let ((str "ĉu bone?"))
783 (catch 'encoding-error
785 (with-fluids ((%default-port-conversion-strategy 'error))
786 (call-with-output-string
788 ;; Latin-1 cannot represent ‘ĉ’.
789 (set-port-encoding! p "ISO-8859-1")
791 #f) ; so the test really fails here
792 (lambda (key subr message errno port chr)
794 (string? (strerror errno)))))))
796 (pass-if "wrong encoding, substitute"
797 (let ((str "ĉu bone?"))
798 (string=? (call-with-output-string
800 (set-port-encoding! p "ISO-8859-1")
801 (set-port-conversion-strategy! p 'substitute)
805 (pass-if "wrong encoding, escape"
806 (let ((str "ĉu bone?"))
807 (string=? (call-with-output-string
809 (set-port-encoding! p "ISO-8859-1")
810 (set-port-conversion-strategy! p 'escape)
815 (let ((p (open-input-string "안녕하세요")))
816 (and (char=? (peek-char p) #\안)
817 (char=? (peek-char p) #\안)
818 (char=? (peek-char p) #\안)
820 (= (port-column p) 0))))
822 ;; Mini DSL to test decoding error handling.
823 (letrec-syntax ((decoding-error?
826 (catch 'decoding-error
830 (lambda (key subr message errno p)
832 (not (= 0 errno))))))))
834 (syntax-rules (-> error eof)
835 ((_ port (proc -> error))
837 (port-conversion-strategy port))
838 (eqv? (proc port) #\?)
839 (decoding-error? port (proc port))))
840 ((_ port (proc -> eof))
841 (eof-object? (proc port)))
842 ((_ port (proc -> char))
843 (eqv? (proc port) char))))
847 (and (make-check port check) ...))))
848 (make-peek+read-checks
850 ((_ port (result ...) e1 expected ...)
851 (make-peek+read-checks port
856 ((_ port (result ...))
857 (make-checks port result ...))
858 ((_ port #f e1 expected ...)
859 (make-peek+read-checks port
864 (test-decoding-error*
866 ((_ sequence encoding strategy (expected ...))
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)
875 (read-char -> expected) ...)))
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)
886 (make-peek+read-checks p #f expected
890 ((_ sequence encoding (expected ...))
892 (test-decoding-error* sequence encoding 'error
895 ;; `escape' should behave exactly like `error'.
896 (test-decoding-error* sequence encoding 'escape
899 (test-decoding-error* sequence encoding 'substitute
902 (test-decoding-error (255 65 66 67) "UTF-8"
903 (error #\A #\B #\C eof))
905 (test-decoding-error (255 206 187 206 188) "UTF-8"
908 (test-decoding-error (206 187 206) "UTF-8"
909 ;; Unterminated sequence.
912 ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
913 ;; of the "Conformance" chapter of Unicode 6.0.0.)
915 (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
916 (error ;; C0: should be in the C2..DF range
921 (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
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
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
939 (error ;; 2nd byte should be in the A0..BF range
940 error ;; 80: not a valid starting byte
941 error ;; 80: not a valid starting byte
945 (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
946 (error ;; 3rd byte should be in the 80..BF range
951 (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
952 (error ;; 2nd byte should be in the 90..BF range
953 error ;; 88: not a valid starting byte
954 error ;; 88: not a valid starting byte
955 error ;; 88: not a valid starting byte
958 (with-test-prefix "call-with-output-string"
960 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
962 (pass-if-exception "proc closes port" exception:wrong-type-arg
963 (call-with-output-string close-port)))
967 ;;;; Soft ports. No tests implemented yet.
970 ;;;; Generic operations across all port types.
972 (let ((port-loop-temp (test-file)))
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)
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))
983 (list (open-input-file port-loop-temp)
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.
989 (define port-list-names '("file" "pipe" "string"))
991 ;; Test the line counter.
992 (define (test-line-counter text second-line final-column)
993 (with-test-prefix "line counter"
994 (let ((ports (input-port-list text)))
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"
1015 ((eof-object? (read-line port)) #t)
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))))
1026 (with-test-prefix "newline"
1028 (string-append "x\n"
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")
1033 "He who receives an idea from me, receives instruction"
1036 (with-test-prefix "no newline"
1038 (string-append "x\n"
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"
1044 "He who receives an idea from me, receives instruction"
1047 ;; Test port-line and port-column for output ports
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"
1053 (and (= (port-line port) 0)
1054 (= (port-column port) 0)))
1055 (write-char #\x port)
1056 (pass-if "after writing one character"
1057 (and (= (port-line port) 0)
1058 (= (port-column port) 1)))
1059 (write-char #\newline port)
1060 (pass-if "after writing first newline char"
1061 (and (= (port-line port) 1)
1062 (= (port-column port) 0)))
1064 (pass-if "line count is 5 at end"
1065 (= (port-line port) 5))
1066 (pass-if "column is correct at end"
1067 (= (port-column port) final-column)))))
1069 (test-output-line-counter
1070 (string-append "He who receives an idea from me, receives instruction\n"
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"
1077 (with-test-prefix "port-column"
1079 (with-test-prefix "output"
1082 (let ((port (open-output-string)))
1084 (= 1 (port-column port))))
1087 (let ((port (open-output-string)))
1089 (= 0 (port-column port))))
1092 (let ((port (open-output-string)))
1093 (display "x\a" port)
1094 (= 1 (port-column port))))
1096 (pass-if "\\x08 backspace"
1097 (let ((port (open-output-string)))
1098 (display "\x08" port)
1099 (= 0 (port-column port))))
1101 (pass-if "x\\x08 backspace"
1102 (let ((port (open-output-string)))
1103 (display "x\x08" port)
1104 (= 0 (port-column port))))
1107 (let ((port (open-output-string)))
1109 (= 0 (port-column port))))
1112 (let ((port (open-output-string)))
1113 (display "x\n" port)
1114 (= 0 (port-column port))))
1117 (let ((port (open-output-string)))
1119 (= 0 (port-column port))))
1122 (let ((port (open-output-string)))
1123 (display "x\r" port)
1124 (= 0 (port-column port))))
1127 (let ((port (open-output-string)))
1129 (= 8 (port-column port))))
1132 (let ((port (open-output-string)))
1133 (display "x\t" port)
1134 (= 8 (port-column port)))))
1136 (with-test-prefix "input"
1139 (let ((port (open-input-string "x")))
1140 (while (not (eof-object? (read-char port))))
1141 (= 1 (port-column port))))
1144 (let ((port (open-input-string "\a")))
1145 (while (not (eof-object? (read-char port))))
1146 (= 0 (port-column port))))
1149 (let ((port (open-input-string "x\a")))
1150 (while (not (eof-object? (read-char port))))
1151 (= 1 (port-column port))))
1153 (pass-if "\\x08 backspace"
1154 (let ((port (open-input-string "\x08")))
1155 (while (not (eof-object? (read-char port))))
1156 (= 0 (port-column port))))
1158 (pass-if "x\\x08 backspace"
1159 (let ((port (open-input-string "x\x08")))
1160 (while (not (eof-object? (read-char port))))
1161 (= 0 (port-column port))))
1164 (let ((port (open-input-string "\n")))
1165 (while (not (eof-object? (read-char port))))
1166 (= 0 (port-column port))))
1169 (let ((port (open-input-string "x\n")))
1170 (while (not (eof-object? (read-char port))))
1171 (= 0 (port-column port))))
1174 (let ((port (open-input-string "\r")))
1175 (while (not (eof-object? (read-char port))))
1176 (= 0 (port-column port))))
1179 (let ((port (open-input-string "x\r")))
1180 (while (not (eof-object? (read-char port))))
1181 (= 0 (port-column port))))
1184 (let ((port (open-input-string "\t")))
1185 (while (not (eof-object? (read-char port))))
1186 (= 8 (port-column port))))
1189 (let ((port (open-input-string "x\t")))
1190 (while (not (eof-object? (read-char port))))
1191 (= 8 (port-column port))))))
1193 (with-test-prefix "port-line"
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
1198 (pass-if "set most-positive-fixnum/2"
1199 (let ((n (quotient most-positive-fixnum 2))
1200 (port (open-output-string)))
1201 (set-port-line! port n)
1202 (eqv? n (port-line port)))))
1204 (with-test-prefix "port-encoding"
1206 (pass-if-exception "set-port-encoding!, wrong encoding"
1207 exception:miscellaneous-error
1208 (let ((p (open-input-string "")))
1209 (set-port-encoding! p "does-not-exist")
1212 (let ((filename (test-file)))
1213 (with-output-to-file filename (lambda () (write 'test)))
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))))
1220 (delete-file filename)))
1226 (with-test-prefix "port-for-each"
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"
1235 ;; clear out the heap
1237 ;; allocate cells so the opened ports aren't at the start of the heap
1239 (open-input-file "/dev/null")
1241 (open-input-file "/dev/null")
1242 ;; this gc leaves the above ports unmarked, ie. inaccessible
1244 ;; but they're still in the port table, so this sees them
1245 (port-for-each (lambda (port)
1246 (set! lst (cons port lst))))
1247 ;; this forces completion of the sweeping
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))))))
1255 (pass-if "fdes->ports finds port"
1256 (let* ((port (open-file (test-file) "w"))
1257 (res (not (not (memq port (fdes->ports (port->fdes port)))))))
1265 (with-test-prefix "seek"
1267 (with-test-prefix "file port"
1270 (call-with-output-file (test-file)
1272 (display "abcde" port)))
1273 (let ((port (open-file (test-file) "r")))
1275 (seek port 2 SEEK_CUR)
1276 (let ((res (eqv? #\d (read-char port))))
1281 (call-with-output-file (test-file)
1283 (display "abcde" port)))
1284 (let ((port (open-file (test-file) "r")))
1286 (seek port 3 SEEK_SET)
1287 (let ((res (eqv? #\d (read-char port))))
1292 (call-with-output-file (test-file)
1294 (display "abcde" port)))
1295 (let ((port (open-file (test-file) "r")))
1297 (seek port -2 SEEK_END)
1298 (let ((res (eqv? #\d (read-char port))))
1306 (with-test-prefix "truncate-file"
1308 (pass-if-exception "flonum file" exception:wrong-type-arg
1309 (truncate-file 1.0 123))
1311 (pass-if-exception "frac file" exception:wrong-type-arg
1312 (truncate-file 7/3 123))
1314 (with-test-prefix "filename"
1316 (pass-if-exception "flonum length" exception:wrong-type-arg
1317 (call-with-output-file (test-file)
1319 (display "hello" port)))
1320 (truncate-file (test-file) 1.0))
1323 (call-with-output-file (test-file)
1325 (display "hello" port)))
1326 (truncate-file (test-file) 1)
1327 (eqv? 1 (stat:size (stat (test-file)))))
1329 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
1330 (call-with-output-file (test-file)
1332 (display "hello" port)))
1333 (truncate-file (test-file))))
1335 (with-test-prefix "file descriptor"
1338 (call-with-output-file (test-file)
1340 (display "hello" port)))
1341 (let ((fd (open-fdes (test-file) O_RDWR)))
1342 (truncate-file fd 1)
1344 (eqv? 1 (stat:size (stat (test-file)))))
1346 (pass-if "shorten to current pos"
1347 (call-with-output-file (test-file)
1349 (display "hello" port)))
1350 (let ((fd (open-fdes (test-file) O_RDWR)))
1351 (seek fd 1 SEEK_SET)
1354 (eqv? 1 (stat:size (stat (test-file))))))
1356 (with-test-prefix "file port"
1359 (call-with-output-file (test-file)
1361 (display "hello" port)))
1362 (let ((port (open-file (test-file) "r+")))
1363 (truncate-file port 1)
1365 (eqv? 1 (stat:size (stat (test-file)))))
1367 (pass-if "shorten to current pos"
1368 (call-with-output-file (test-file)
1370 (display "hello" port)))
1371 (let ((port (open-file (test-file) "r+")))
1373 (truncate-file port)
1375 (eqv? 1 (stat:size (stat (test-file)))))))
1378 ;;;; testing read-delimited and friends
1380 (with-test-prefix "read-delimited!"
1381 (let ((c (make-string 20 #\!)))
1382 (call-with-input-string
1386 (read-delimited! "\n" c port 'concat)
1387 (pass-if "read-delimited! reads a first line"
1388 (string=? c "defdef\n!!!!!!!!!!!!!"))
1390 (read-delimited! "\n" c port 'concat 3)
1391 (pass-if "read-delimited! reads a first line"
1392 (string=? c "defghighi\n!!!!!!!!!!"))))))
1397 (call-with-input-string
1400 (pass-if "char-ready? returns true on string port"
1401 (char-ready? port))))
1403 ;;; This segfaults on some versions of Guile. We really should run
1404 ;;; the tests in a subprocess...
1406 (call-with-input-string
1409 (with-input-from-port
1412 (pass-if "char-ready? returns true on string port as default port"
1416 ;;;; pending-eof behavior
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)
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))
1430 (lambda () #f)) ; close
1433 (define (call-with-port p proc)
1436 (lambda () (proc p))
1437 (lambda () (close-port p))))
1439 (define (call-with-test-file str proc)
1440 (let ((filename (test-file)))
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))))))
1447 (pass-if "peek-char does not swallow EOF (soft port)"
1448 (call-with-port (test-soft-port #\a #f #\b)
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))))))
1457 (pass-if "unread clears pending EOF (soft port)"
1458 (call-with-port (test-soft-port #\a #f #\b)
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)))))))
1465 (pass-if "unread clears pending EOF (string port)"
1466 (call-with-input-string "a"
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)))))))
1473 (pass-if "unread clears pending EOF (file port)"
1474 (call-with-test-file
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)))))))
1482 (pass-if "seek clears pending EOF (string port)"
1483 (call-with-input-string "a"
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)))))))
1490 (pass-if "seek clears pending EOF (file port)"
1491 (call-with-test-file
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))))))))
1500 ;;;; Close current-input-port, and make sure everyone can handle it.
1502 (with-test-prefix "closing current-input-port"
1503 (for-each (lambda (procedure name)
1504 (with-input-from-port
1505 (call-with-input-string "foo" (lambda (p) p))
1507 (close-port (current-input-port))
1508 (pass-if-exception name
1509 exception:wrong-type-arg
1511 (list read read-char read-line)
1512 '("read" "read-char" "read-line")))
1516 (with-test-prefix "setvbuf"
1518 (pass-if-exception "closed port"
1519 exception:wrong-type-arg
1520 (let ((port (open-input-file "/dev/null")))
1522 (setvbuf port _IOFBF)))
1524 (pass-if-exception "string port"
1525 exception:wrong-type-arg
1526 (let ((port (open-input-string "Hey!")))
1528 (setvbuf port _IOFBF)))
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)
1535 (display "This is GNU Guile.\nWelcome." p)))
1536 (call-with-input-file (test-file)
1538 (and (eqv? #\T (read-char p))
1539 (let ((line (port-line p))
1540 (col (port-column p)))
1541 (and (= line 0) (= col 1)
1543 (setvbuf p _IOFBF 777)
1544 (let ((line* (port-line p))
1545 (col* (port-column p)))
1547 (= col col*)))))))))))
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)))
1564 (with-test-prefix "unicode byte-order marks (BOMs)"
1566 (define (bv-read-test* encoding bv proc)
1567 (let ((port (open-bytevector-input-port bv)))
1568 (set-port-encoding! port encoding)
1571 (define (bv-read-test encoding bv)
1572 (bv-read-test* encoding bv read-string))
1574 (define (bv-write-test* encoding proc)
1576 (lambda () (open-bytevector-output-port))
1577 (lambda (port get-bytevector)
1578 (set-port-encoding! port encoding)
1582 (define (bv-write-test encoding str)
1583 (bv-write-test* encoding
1587 (pass-if-equal "BOM not discarded from Latin-1 stream"
1589 (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
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)))
1595 (pass-if-equal "BOM not discarded from UTF-16BE stream"
1597 (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
1599 (pass-if-equal "BOM not discarded from UTF-16LE stream"
1601 (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
1603 (pass-if-equal "BOM not discarded from UTF-32BE stream"
1605 (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
1606 #x00 #x00 #x00 #x61)))
1608 (pass-if-equal "BOM not discarded from UTF-32LE stream"
1610 (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
1611 #x61 #x00 #x00 #x00)))
1613 (pass-if-equal "BOM not written to UTF-8 stream"
1615 (bv-write-test "UTF-8" "a"))
1617 (pass-if-equal "BOM not written to UTF-16BE stream"
1619 (bv-write-test "UTF-16BE" "a"))
1621 (pass-if-equal "BOM not written to UTF-16LE stream"
1623 (bv-write-test "UTF-16LE" "a"))
1625 (pass-if-equal "BOM not written to UTF-32BE stream"
1626 #vu8(#x00 #x00 #x00 #x61)
1627 (bv-write-test "UTF-32BE" "a"))
1629 (pass-if-equal "BOM not written to UTF-32LE stream"
1630 #vu8(#x61 #x00 #x00 #x00)
1631 (bv-write-test "UTF-32LE" "a"))
1633 (pass-if "Don't read from the port unless user asks to"
1634 (let* ((p (make-soft-port
1636 (lambda (c) #f) ; write char
1637 (lambda (s) #f) ; write string
1638 (lambda () #f) ; flush
1639 (lambda () (throw 'fail)) ; read char
1642 (set-port-encoding! p "UTF-16")
1644 (set-port-encoding! p "UTF-32")
1648 ;; TODO: test that input and output streams are independent when
1649 ;; appropriate, and linked when appropriate.
1651 (pass-if-equal "BOM discarded from start of UTF-8 stream"
1653 (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
1655 (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
1657 (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
1659 (let ((c (read-char p)))
1661 (let ((s (read-string p)))
1664 (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
1666 (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
1668 (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
1670 (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
1675 (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
1677 (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
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"))
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"
1688 (set-port-encoding! p "UTF-16")
1691 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
1693 (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
1695 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
1697 (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
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 (BE)"
1706 (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
1708 (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
1710 (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
1715 (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
1717 (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
1719 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
1721 (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
1723 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
1725 (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
1727 (let ((c (read-char p)))
1729 (let ((s (read-string p)))
1732 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
1734 (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
1736 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
1738 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1739 #x00 #x00 #x00 #x61)))
1741 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
1743 (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
1744 #x00 #x00 #x00 #x61)
1746 (let ((c (read-char p)))
1748 (let ((s (read-string p)))
1751 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
1753 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1755 #x00 #x00 #x00 #x61)))
1757 (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
1759 (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
1761 #x00 #x00 #x00 #x61)
1766 (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
1768 (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
1770 (let ((a (read-char p)))
1771 (set-port-encoding! p "UTF-16")
1772 (string a (read-char p))))))
1774 (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
1776 (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
1778 (let ((a (read-char p)))
1779 (set-port-encoding! p "UTF-16")
1780 (string a (read-char p))))))
1782 (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
1784 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1786 #x00 #x00 #x00 #x62)
1788 (let ((a (read-char p)))
1789 (set-port-encoding! p "UTF-32")
1790 (string a (read-char p))))))
1792 (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
1794 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1796 #x62 #x00 #x00 #x00)
1798 (let ((a (read-char p)))
1799 (set-port-encoding! p "UTF-32")
1800 (string a (read-char p))))))
1802 (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
1804 (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
1806 #x00 #x00 #x00 #x62)))
1808 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
1810 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1811 #x61 #x00 #x00 #x00)))
1813 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
1815 (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
1816 #x61 #x00 #x00 #x00)
1818 (let ((c (read-char p)))
1820 (let ((s (read-string p)))
1823 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
1825 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1827 #x61 #x00 #x00 #x00))))
1831 (define-syntax-rule (with-load-path path body ...)
1836 (set! %load-path new))
1840 (set! %load-path old)))))
1842 (with-test-prefix "%file-port-name-canonicalization"
1844 (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
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.
1849 (with-load-path (cons "" (delete "/" %load-path))
1850 (with-fluids ((%file-port-name-canonicalization 'relative))
1851 (port-filename (open-input-file "/dev/null")))))
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")))))
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))
1864 (open-input-file (%search-load-path "ice-9/q.scm"))))
1865 (throw 'unresolved)))
1867 (pass-if-equal "absolute canonicalization from ice-9"
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"))))))
1874 (with-test-prefix "file name separators"
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)))
1885 (delete-file (test-file))
1887 ;;; Local Variables:
1888 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
1889 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)