1 ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
4 ;;;; 2014 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-io-ports)
22 #:use-module (test-suite lib)
23 #:use-module (test-suite guile-test)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-11)
26 #:use-module (ice-9 match)
27 #:use-module (rnrs io ports)
28 #:use-module (rnrs io simple)
29 #:use-module (rnrs exceptions)
30 #:use-module (rnrs bytevectors))
32 (define-syntax pass-if-condition
34 ((_ name predicate body0 body ...)
35 (let ((cookie (list 'cookie)))
37 (eq? cookie (guard (c ((predicate c) cookie))
41 (data-file-name "ports-test.tmp"))
43 ;; A input/output port that swallows all output, and produces just
44 ;; spaces on input. Reading and writing beyond `failure-position'
45 ;; produces `system-error' exceptions. Used for testing exception
47 (define* (make-failing-port #:optional (failure-position 0))
48 (define (maybe-fail index errno)
49 (if (> index failure-position)
50 (scm-error 'system-error
52 "I/O beyond failure position" '()
56 (define (write-char chr)
57 (set! write-index (+ 1 write-index))
58 (maybe-fail write-index ENOSPC))
61 (lambda (str) ;; write-string
62 (for-each write-char (string->list str)))
63 (lambda () #t) ;; flush-output
64 (lambda () ;; read-char
65 (set! read-index (+ read-index 1))
66 (maybe-fail read-index EIO)
68 (lambda () #t)) ;; close-port
71 (define (call-with-bytevector-output-port/transcoded transcoder receiver)
72 (call-with-bytevector-output-port
74 (call-with-port (transcoded-port bv-port transcoder)
78 (with-test-prefix "7.2.5 End-of-File Object"
81 (and (eqv? (eof-object) (eof-object))
82 (eq? (eof-object) (eof-object))))
85 (port-eof? (open-input-string ""))))
88 (with-test-prefix "7.2.8 Binary Input"
91 (let ((port (open-input-string "A")))
92 (and (= (char->integer #\A) (get-u8 port))
93 (eof-object? (get-u8 port)))))
95 (pass-if "lookahead-u8"
96 (let ((port (open-input-string "A")))
97 (and (= (char->integer #\A) (lookahead-u8 port))
98 (= (char->integer #\A) (lookahead-u8 port))
99 (= (char->integer #\A) (get-u8 port))
100 (eof-object? (get-u8 port)))))
102 (pass-if "lookahead-u8 non-ASCII"
103 (let ((port (open-input-string "λ")))
104 (and (= 206 (lookahead-u8 port))
105 (= 206 (lookahead-u8 port))
106 (= 206 (get-u8 port))
107 (= 187 (lookahead-u8 port))
108 (= 187 (lookahead-u8 port))
109 (= 187 (get-u8 port))
110 (eof-object? (lookahead-u8 port))
111 (eof-object? (get-u8 port)))))
113 (pass-if "lookahead-u8: result is unsigned"
115 (let ((port (open-bytevector-input-port #vu8(255))))
116 (= (lookahead-u8 port) 255)))
118 (pass-if "get-bytevector-n [short]"
119 (let* ((port (open-input-string "GNU Guile"))
120 (bv (get-bytevector-n port 4)))
121 (and (bytevector? bv)
122 (equal? (bytevector->u8-list bv)
123 (map char->integer (string->list "GNU "))))))
125 (pass-if "get-bytevector-n [long]"
126 (let* ((port (open-input-string "GNU Guile"))
127 (bv (get-bytevector-n port 256)))
128 (and (bytevector? bv)
129 (equal? (bytevector->u8-list bv)
130 (map char->integer (string->list "GNU Guile"))))))
132 (pass-if-exception "get-bytevector-n with closed port"
133 exception:wrong-type-arg
135 (let ((port (%make-void-port "r")))
138 (get-bytevector-n port 3)))
140 (pass-if "get-bytevector-n! [short]"
141 (let* ((port (open-input-string "GNU Guile"))
142 (bv (make-bytevector 4))
143 (read (get-bytevector-n! port bv 0 4)))
145 (equal? (bytevector->u8-list bv)
146 (map char->integer (string->list "GNU "))))))
148 (pass-if "get-bytevector-n! [long]"
149 (let* ((str "GNU Guile")
150 (port (open-input-string str))
151 (bv (make-bytevector 256))
152 (read (get-bytevector-n! port bv 0 256)))
153 (and (equal? read (string-length str))
154 (equal? (map (lambda (i)
155 (bytevector-u8-ref bv i))
157 (map char->integer (string->list str))))))
159 (pass-if "get-bytevector-some [simple]"
160 (let* ((str "GNU Guile")
161 (port (open-input-string str))
162 (bv (get-bytevector-some port)))
163 (and (bytevector? bv)
164 (equal? (bytevector->u8-list bv)
165 (map char->integer (string->list str))))))
167 (pass-if "get-bytevector-all"
168 (let* ((str "GNU Guile")
170 (port (make-soft-port
173 (if (>= index (string-length str))
175 (let ((c (string-ref str index)))
176 (set! index (+ index 1))
181 ;; Number of readily available octets: falls to
182 ;; zero after 4 octets have been read and then
185 (- (string-length str) index)
186 (- 4 (modulo index 5)))))
187 (if (= 0 a) (set! cont? #t))
190 (bv (get-bytevector-all port)))
191 (and (bytevector? bv)
192 (= index (string-length str))
193 (= (bytevector-length bv) (string-length str))
194 (equal? (bytevector->u8-list bv)
195 (map char->integer (string->list str)))))))
198 (define (make-soft-output-port)
199 (let* ((bv (make-bytevector 1024))
202 (write-char (lambda (chr)
203 (bytevector-u8-set! bv write-index
205 (set! write-index (+ 1 write-index)))))
208 (lambda (str) ;; write-string
209 (for-each write-char (string->list str)))
210 (lambda () #t) ;; flush-output
211 (lambda () ;; read-char
212 (if (>= read-index (bytevector-length bv))
214 (let ((c (bytevector-u8-ref bv read-index)))
215 (set! read-index (+ read-index 1))
217 (lambda () #t)) ;; close-port
220 (with-test-prefix "7.2.11 Binary Output"
223 (let ((port (make-soft-output-port)))
225 (equal? (get-u8 port) 77)))
227 ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
228 ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
229 ;; the bytes through, unmodified. This is hacky, but we can't use
230 ;; "custom binary output ports" here because they're only tested
233 (pass-if "put-bytevector [2 args]"
235 (let ((port (make-soft-output-port))
236 (bv (make-bytevector 256)))
237 (put-bytevector port bv)
238 (equal? (bytevector->u8-list bv)
240 (get-bytevector-n port (bytevector-length bv)))))))
242 (pass-if "put-bytevector [3 args]"
244 (let ((port (make-soft-output-port))
245 (bv (make-bytevector 256))
247 (put-bytevector port bv start)
248 (equal? (drop (bytevector->u8-list bv) start)
250 (get-bytevector-n port (- (bytevector-length bv) start)))))))
252 (pass-if "put-bytevector [4 args]"
254 (let ((port (make-soft-output-port))
255 (bv (make-bytevector 256))
258 (put-bytevector port bv start count)
259 (equal? (take (drop (bytevector->u8-list bv) start) count)
261 (get-bytevector-n port count))))))
263 (pass-if-exception "put-bytevector with closed port"
264 exception:wrong-type-arg
266 (let* ((bv (make-bytevector 4))
267 (port (%make-void-port "w")))
270 (put-bytevector port bv)))
272 (pass-if "put-bytevector with UTF-16 string port"
273 (let* ((str "hello, world")
274 (bv (string->utf16 str)))
276 (call-with-output-string
278 (set-port-encoding! port "UTF-16BE")
279 (put-bytevector port bv))))))
281 (pass-if "put-bytevector with wrong-encoding string port"
282 (let* ((str "hello, world")
283 (bv (string->utf16 str)))
284 (catch 'decoding-error
286 (with-fluids ((%default-port-conversion-strategy 'error))
287 (call-with-output-string
289 (set-port-encoding! port "UTF-32")
290 (put-bytevector port bv)))
291 #f)) ; fail if we reach this point
292 (lambda (key subr message errno port)
293 (string? (strerror errno)))))))
296 (define (test-input-file-opener open filename)
297 (let ((contents (string->utf8 "GNU λ")))
299 (call-with-output-file filename
300 (lambda (port) (put-bytevector port contents)))
302 (pass-if "opens binary input port with correct contents"
303 (with-fluids ((%default-port-encoding "UTF-8"))
304 (call-with-port (open-file-input-port filename)
306 (and (binary-port? port)
308 (bytevector=? contents (get-bytevector-all port))))))))
310 (delete-file filename))
312 (with-test-prefix "7.2.7 Input Ports"
314 (with-test-prefix "open-file-input-port"
315 (test-input-file-opener open-file-input-port (test-file)))
317 ;; This section appears here so that it can use the binary input
320 (pass-if "open-bytevector-input-port [1 arg]"
321 (let* ((str "Hello Port!")
322 (bv (u8-list->bytevector (map char->integer
323 (string->list str))))
324 (port (open-bytevector-input-port bv))
327 (let loop ((chr (read-char port))
329 (if (eof-object? chr)
330 (apply string (reverse! result))
331 (loop (read-char port)
332 (cons chr result)))))))
334 (equal? (read-to-string port) str)))
336 (pass-if "bytevector-input-port is binary"
337 (with-fluids ((%default-port-encoding "UTF-8"))
338 (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
340 (pass-if-exception "bytevector-input-port is read-only"
341 exception:wrong-type-arg
343 (let* ((str "Hello Port!")
344 (bv (u8-list->bytevector (map char->integer
345 (string->list str))))
346 (port (open-bytevector-input-port bv #f)))
348 (write "hello" port)))
350 (pass-if "bytevector input port supports seeking"
351 (let* ((str "Hello Port!")
352 (bv (u8-list->bytevector (map char->integer
353 (string->list str))))
354 (port (open-bytevector-input-port bv #f)))
356 (and (port-has-port-position? port)
357 (= 0 (port-position port))
358 (port-has-set-port-position!? port)
360 (set-port-position! port 6)
361 (= 6 (port-position port)))
362 (bytevector=? (get-bytevector-all port)
364 (map char->integer (string->list "Port!")))))))
366 (pass-if "bytevector input port can seek to very end"
367 (let ((empty (open-bytevector-input-port '#vu8()))
368 (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
369 (and (begin (set-port-position! empty (port-position empty))
370 (= 0 (port-position empty)))
371 (begin (get-bytevector-n not-empty 3)
372 (set-port-position! not-empty (port-position not-empty))
373 (= 3 (port-position not-empty))))))
375 (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
376 exception:wrong-num-args
378 ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
380 (make-custom-binary-input-port "port" (lambda args #t)))
382 (pass-if "make-custom-binary-input-port"
383 (let* ((source (make-bytevector 7777))
385 (len (bytevector-length source)))
386 (lambda (bv start count)
387 (let ((amount (min count (- len pos))))
389 (bytevector-copy! source pos
391 (set! pos (+ pos amount))
393 (port (make-custom-binary-input-port "the port" read!
396 (and (binary-port? port)
398 (bytevector=? (get-bytevector-all port) source))))
400 (pass-if "custom binary input port does not support `port-position'"
401 (let* ((str "Hello Port!")
402 (source (open-bytevector-input-port
404 (map char->integer (string->list str)))))
405 (read! (lambda (bv start count)
406 (let ((r (get-bytevector-n! source bv start count)))
410 (port (make-custom-binary-input-port "the port" read!
412 (not (or (port-has-port-position? port)
413 (port-has-set-port-position!? port)))))
415 (pass-if-exception "custom binary input port 'read!' returns too much"
416 exception:out-of-range
417 ;; In Guile <= 2.0.9 this would segfault.
418 (let* ((read! (lambda (bv start count)
420 (port (make-custom-binary-input-port "the port" read!
422 (get-bytevector-all port)))
424 (pass-if-equal "custom binary input port supports `port-position', \
425 not `set-port-position!'"
427 (let ((port (make-custom-binary-input-port "the port" (const 0)
429 (and (port-has-port-position? port)
430 (not (port-has-set-port-position!? port))
431 (port-position port))))
433 (pass-if "custom binary input port supports `port-position'"
434 (let* ((str "Hello Port!")
435 (source (open-bytevector-input-port
437 (map char->integer (string->list str)))))
438 (read! (lambda (bv start count)
439 (let ((r (get-bytevector-n! source bv start count)))
444 (port-position source)))
445 (set-pos! (lambda (pos)
446 (set-port-position! source pos)))
447 (port (make-custom-binary-input-port "the port" read!
448 get-pos set-pos! #f)))
450 (and (port-has-port-position? port)
451 (= 0 (port-position port))
452 (port-has-set-port-position!? port)
454 (set-port-position! port 6)
455 (= 6 (port-position port)))
456 (bytevector=? (get-bytevector-all port)
458 (map char->integer (string->list "Port!")))))))
460 (pass-if-equal "custom binary input port buffered partial reads"
462 ;; Check what happens when READ! returns less than COUNT bytes.
463 (let* ((src (string->utf8 "Hello Port!"))
464 (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc.
466 (read! (lambda (bv start count)
469 (bytevector-copy! src offset bv start count)
471 (set! offset (+ offset count))
475 (port (make-custom-binary-input-port "the port"
477 (get-string-all port)))
479 (pass-if-equal "custom binary input port unbuffered & 'port-position'"
481 ;; Check that the value returned by 'port-position' is correct, and
482 ;; that each 'port-position' call leads one call to the
483 ;; 'get-position' method.
484 (let* ((str "Hello Port!")
485 (output (make-bytevector (string-length str)))
486 (source (with-fluids ((%default-port-encoding "UTF-8"))
487 (open-string-input-port str)))
488 (read! (lambda (bv start count)
489 (let ((r (get-bytevector-n! source bv start count)))
495 (let ((p (port-position source)))
496 (set! pos (cons p pos))
498 (port (make-custom-binary-input-port "the port" read!
500 (setvbuf port _IONBF)
501 (and (= 0 (port-position port))
503 (get-bytevector-n! port output 0 2)
504 (= 2 (port-position port)))
506 (get-bytevector-n! port output 2 3)
507 (= 5 (port-position port)))
508 (let ((bv (string->utf8 (get-string-all port))))
509 (bytevector-copy! bv 0 output 5 (bytevector-length bv))
510 (= (string-length str) (port-position port)))
511 (bytevector=? output (string->utf8 str))
514 (pass-if-equal "custom binary input port unbuffered & 'read!' calls"
515 `((2 "He") (3 "llo") (42 " Port!"))
516 (let* ((str "Hello Port!")
517 (source (with-fluids ((%default-port-encoding "UTF-8"))
518 (open-string-input-port str)))
520 (read! (lambda (bv start count)
521 (set! reads (cons count reads))
522 (let ((r (get-bytevector-n! source bv start count)))
526 (port (make-custom-binary-input-port "the port" read!
529 (setvbuf port _IONBF)
530 (let ((ret (list (get-bytevector-n port 2)
531 (get-bytevector-n port 3)
532 (get-bytevector-n port 42))))
535 (if (bytevector? obj)
540 (pass-if-equal "custom binary input port, unbuffered then buffered"
541 `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
543 (let* ((str "Lorem ipsum dolor sit amet, consectetur…")
544 (source (with-fluids ((%default-port-encoding "UTF-8"))
545 (open-string-input-port str)))
547 (read! (lambda (bv start count)
548 (set! reads (cons count reads))
549 (let ((r (get-bytevector-n! source bv start count)))
553 (port (make-custom-binary-input-port "the port" read!
556 (setvbuf port _IONBF)
557 (let ((ret (list (get-bytevector-n port 6)
558 (get-bytevector-n port 12)
560 (setvbuf port _IOFBF 777)
561 (get-bytevector-n port 42))
562 (get-bytevector-n port 42))))
565 (if (bytevector? obj)
570 (pass-if-equal "custom binary input port, buffered then unbuffered"
572 42 14 ; scm_c_read tries to fill the 42-byte buffer
574 ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
575 (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…")
576 (source (with-fluids ((%default-port-encoding "UTF-8"))
577 (open-string-input-port str)))
579 (read! (lambda (bv start count)
580 (set! reads (cons count reads))
581 (let ((r (get-bytevector-n! source bv start count)))
585 (port (make-custom-binary-input-port "the port" read!
588 (setvbuf port _IOFBF 18)
589 (let ((ret (list (get-bytevector-n port 6)
590 (get-bytevector-n port 12)
592 (setvbuf port _IONBF)
593 (get-bytevector-n port 42))
594 (get-bytevector-n port 42))))
595 (list (reverse reads)
597 (if (bytevector? obj)
602 (pass-if "custom binary input port `close-proc' is called"
604 (read! (lambda (bv start count) 0))
605 (get-pos (lambda () 0))
606 (set-pos! (lambda (pos) #f))
607 (close! (lambda () (set! closed? #t)))
608 (port (make-custom-binary-input-port "the port" read!
613 (gc) ; Test for marking a closed port.
616 (pass-if "standard-input-port is binary"
617 (with-fluids ((%default-port-encoding "UTF-8"))
618 (binary-port? (standard-input-port)))))
621 (define (test-output-file-opener open filename)
622 (with-fluids ((%default-port-encoding "UTF-8"))
623 (pass-if "opens binary output port"
624 (call-with-port (open filename)
626 (put-bytevector port '#vu8(1 2 3))
627 (and (binary-port? port)
628 (output-port? port))))))
630 (pass-if-condition "exception: already-exists"
631 i/o-file-already-exists-error?
634 (pass-if "no-fail no-truncate"
636 (call-with-port (open filename (file-options no-fail no-truncate))
638 (= 0 (port-position port))))
639 (= 3 (stat:size (stat filename)))))
643 (call-with-port (open filename (file-options no-fail))
645 (= 0 (stat:size (stat filename)))))
647 (delete-file filename)
649 (pass-if-condition "exception: does-not-exist"
650 i/o-file-does-not-exist-error?
651 (open filename (file-options no-create))))
653 (with-test-prefix "8.2.10 Output ports"
655 (with-test-prefix "open-file-output-port"
656 (test-output-file-opener open-file-output-port (test-file)))
658 (pass-if "open-bytevector-output-port"
659 (let-values (((port get-content)
660 (open-bytevector-output-port #f)))
661 (let ((source (make-bytevector 7777)))
662 (put-bytevector port source)
663 (and (bytevector=? (get-content) source)
664 (bytevector=? (get-content) (make-bytevector 0))))))
666 (pass-if "bytevector-output-port is binary"
667 (binary-port? (open-bytevector-output-port)))
669 (pass-if "open-bytevector-output-port [extract after close]"
670 (let-values (((port get-content)
671 (open-bytevector-output-port)))
672 (let ((source (make-bytevector 12345 #xFE)))
673 (put-bytevector port source)
675 (bytevector=? (get-content) source))))
677 (pass-if "open-bytevector-output-port [put-u8]"
678 (let-values (((port get-content)
679 (open-bytevector-output-port)))
681 (and (bytevector=? (get-content) (make-bytevector 1 77))
682 (bytevector=? (get-content) (make-bytevector 0)))))
684 (pass-if "open-bytevector-output-port [display]"
685 (let-values (((port get-content)
686 (open-bytevector-output-port)))
687 (display "hello" port)
688 (and (bytevector=? (get-content) (string->utf8 "hello"))
689 (bytevector=? (get-content) (make-bytevector 0)))))
691 (pass-if "bytevector output port supports `port-position'"
692 (let-values (((port get-content)
693 (open-bytevector-output-port)))
694 (let ((source (make-bytevector 7777))
695 (overwrite (make-bytevector 33)))
696 (and (port-has-port-position? port)
697 (port-has-set-port-position!? port)
699 (put-bytevector port source)
700 (= (bytevector-length source)
701 (port-position port)))
703 (set-port-position! port 10)
704 (= 10 (port-position port)))
706 (put-bytevector port overwrite)
707 (bytevector-copy! overwrite 0 source 10
708 (bytevector-length overwrite))
709 (= (port-position port)
710 (+ 10 (bytevector-length overwrite))))
711 (bytevector=? (get-content) source)
712 (bytevector=? (get-content) (make-bytevector 0))))))
714 (pass-if "make-custom-binary-output-port"
715 (let ((port (make-custom-binary-output-port "cbop"
718 (and (output-port? port)
720 (not (port-has-port-position? port))
721 (not (port-has-set-port-position!? port)))))
723 (pass-if "make-custom-binary-output-port [partial writes]"
724 (let* ((source (uint-list->bytevector (iota 333)
725 (native-endianness) 2))
726 (sink (make-bytevector (bytevector-length source)))
729 (write! (lambda (bv start count)
734 (let ((u8 (bytevector-u8-ref bv start)))
735 ;; Get one byte at a time.
736 (bytevector-u8-set! sink sink-pos u8)
737 (set! sink-pos (+ 1 sink-pos))
739 (port (make-custom-binary-output-port "cbop" write!
741 (put-bytevector port source)
742 (and (= sink-pos (bytevector-length source))
744 (bytevector=? sink source))))
746 (pass-if "make-custom-binary-output-port [full writes]"
747 (let* ((source (uint-list->bytevector (iota 333)
748 (native-endianness) 2))
749 (sink (make-bytevector (bytevector-length source)))
752 (write! (lambda (bv start count)
758 (bytevector-copy! bv start
761 (set! sink-pos (+ sink-pos count))
763 (port (make-custom-binary-output-port "cbop" write!
765 (put-bytevector port source)
766 (and (= sink-pos (bytevector-length source))
768 (bytevector=? sink source))))
770 (pass-if "standard-output-port is binary"
771 (with-fluids ((%default-port-encoding "UTF-8"))
772 (binary-port? (standard-output-port))))
774 (pass-if "standard-error-port is binary"
775 (with-fluids ((%default-port-encoding "UTF-8"))
776 (binary-port? (standard-error-port)))))
779 (with-test-prefix "8.2.6 Input and output ports"
781 (pass-if "transcoded-port [output]"
782 (let ((s "Hello\nÄÖÜ"))
785 (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
787 (put-string utf8-port s))))))
789 (pass-if "transcoded-port [input]"
790 (let ((s "Hello\nÄÖÜ"))
794 (transcoded-port (open-bytevector-input-port (string->utf8 s))
795 (make-transcoder (utf-8-codec)))))))
797 (pass-if "transcoded-port [input line]"
799 (get-line (transcoded-port
800 (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
801 (make-transcoder (utf-8-codec))))))
803 (pass-if "transcoded-port [error handling mode = raise]"
804 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
805 (error-handling-mode raise)))
806 (b (open-bytevector-input-port #vu8(255 2 1)))
807 (tp (transcoded-port b t)))
808 (guard (c ((i/o-decoding-error? c)
809 (eq? (i/o-error-port c) tp)))
811 #f))) ; fail if we reach this point
813 (pass-if "transcoded-port [error handling mode = replace]"
814 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
815 (error-handling-mode replace)))
816 (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
817 (tp (transcoded-port b t)))
818 (string-suffix? "gnu" (get-line tp))))
820 (pass-if "transcoded-port, output [error handling mode = raise]"
821 (let-values (((p get)
822 (open-bytevector-output-port)))
823 (let* ((t (make-transcoder (latin-1-codec) (native-eol-style)
824 (error-handling-mode raise)))
825 (tp (transcoded-port p t)))
826 (guard (c ((i/o-encoding-error? c)
827 (and (eq? (i/o-error-port c) tp)
828 (char=? (i/o-encoding-error-char c) #\λ)
829 (bytevector=? (get) (string->utf8 "The letter ")))))
830 (put-string tp "The letter λ cannot be represented in Latin-1.")
833 (pass-if "port-transcoder [transcoded port]"
834 (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
835 (make-transcoder (utf-8-codec))))
836 (t (port-transcoder p)))
839 (eq? (native-eol-style)
840 (transcoder-eol-style t))
841 (eq? (error-handling-mode replace)
842 (transcoder-error-handling-mode t))))))
844 (with-test-prefix "8.2.9 Textual input"
846 (pass-if "get-string-n [short]"
847 (let ((port (open-input-string "GNU Guile")))
848 (string=? "GNU " (get-string-n port 4))))
849 (pass-if "get-string-n [long]"
850 (let ((port (open-input-string "GNU Guile")))
851 (string=? "GNU Guile" (get-string-n port 256))))
852 (pass-if "get-string-n [eof]"
853 (let ((port (open-input-string "")))
854 (eof-object? (get-string-n port 4))))
856 (pass-if "get-string-n! [short]"
857 (let ((port (open-input-string "GNU Guile"))
858 (s (string-copy "Isn't XXX great?")))
859 (and (= 3 (get-string-n! port s 6 3))
860 (string=? s "Isn't GNU great?"))))
862 (with-test-prefix "read error"
863 (pass-if-condition "get-char" i/o-read-error?
864 (get-char (make-failing-port)))
865 (pass-if-condition "lookahead-char" i/o-read-error?
866 (lookahead-char (make-failing-port)))
867 ;; FIXME: these are not yet exception-correct
869 (pass-if-condition "get-string-n" i/o-read-error?
870 (get-string-n (make-failing-port) 5))
871 (pass-if-condition "get-string-n!" i/o-read-error?
872 (get-string-n! (make-failing-port) (make-string 5) 0 5))
874 (pass-if-condition "get-string-all" i/o-read-error?
875 (get-string-all (make-failing-port 100)))
876 (pass-if-condition "get-line" i/o-read-error?
877 (get-line (make-failing-port)))
878 (pass-if-condition "get-datum" i/o-read-error?
879 (get-datum (make-failing-port)))))
881 (define (encoding-error-predicate char)
883 (and (i/o-encoding-error? c)
884 (char=? char (i/o-encoding-error-char c)))))
886 (with-test-prefix "8.2.12 Textual Output"
888 (with-test-prefix "write error"
889 (pass-if-condition "put-char" i/o-write-error?
890 (put-char (make-failing-port) #\G))
891 (pass-if-condition "put-string" i/o-write-error?
892 (put-string (make-failing-port) "Hello World!"))
893 (pass-if-condition "put-datum" i/o-write-error?
894 (put-datum (make-failing-port) '(hello world!))))
895 (with-test-prefix "encoding error"
896 (pass-if-condition "put-char" (encoding-error-predicate #\λ)
897 (call-with-bytevector-output-port/transcoded
898 (make-transcoder (latin-1-codec)
900 (error-handling-mode raise))
902 (put-char port #\λ))))
903 (pass-if-condition "put-string" (encoding-error-predicate #\λ)
904 (call-with-bytevector-output-port/transcoded
905 (make-transcoder (latin-1-codec)
907 (error-handling-mode raise))
909 (put-string port "FooλBar"))))))
911 (with-test-prefix "8.3 Simple I/O"
912 (with-test-prefix "read error"
913 (pass-if-condition "read-char" i/o-read-error?
914 (read-char (make-failing-port)))
915 (pass-if-condition "peek-char" i/o-read-error?
916 (peek-char (make-failing-port)))
917 (pass-if-condition "read" i/o-read-error?
918 (read (make-failing-port))))
919 (with-test-prefix "write error"
920 (pass-if-condition "display" i/o-write-error?
921 (display "Hi there!" (make-failing-port)))
922 (pass-if-condition "write" i/o-write-error?
923 (write '(hi there!) (make-failing-port)))
924 (pass-if-condition "write-char" i/o-write-error?
925 (write-char #\G (make-failing-port)))
926 (pass-if-condition "newline" i/o-write-error?
927 (newline (make-failing-port))))
928 (let ((filename (test-file)))
929 ;; ensure the test file exists
930 (call-with-output-file filename
931 (lambda (port) (write "foo" port)))
932 (pass-if "call-with-input-file [port is textual]"
933 (call-with-input-file filename textual-port?))
934 (pass-if-condition "call-with-input-file [exception: not-found]"
935 i/o-file-does-not-exist-error?
936 (call-with-input-file ",this-is-highly-unlikely-to-exist!"
938 (pass-if-condition "call-with-output-file [exception: already-exists]"
939 i/o-file-already-exists-error?
940 (call-with-output-file filename
942 (delete-file filename)))
944 (with-test-prefix "8.2.13 Input/output ports"
945 (with-test-prefix "open-file-input/output-port [output]"
946 (test-output-file-opener open-file-input/output-port (test-file)))
947 (with-test-prefix "open-file-input/output-port [input]"
948 (test-input-file-opener open-file-input/output-port (test-file))))
952 ;;; eval: (put 'guard 'scheme-indent-function 1)