+ (bytevector=? sink source))))
+
+ (pass-if "standard-output-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (standard-output-port))))
+
+ (pass-if "standard-error-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (standard-error-port)))))
+
+\f
+(with-test-prefix "8.2.6 Input and output ports"
+
+ (pass-if "transcoded-port [output]"
+ (let ((s "Hello\nÄÖÜ"))
+ (bytevector=?
+ (string->utf8 s)
+ (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
+ (lambda (utf8-port)
+ (put-string utf8-port s))))))
+
+ (pass-if "transcoded-port [input]"
+ (let ((s "Hello\nÄÖÜ"))
+ (string=?
+ s
+ (get-string-all
+ (transcoded-port (open-bytevector-input-port (string->utf8 s))
+ (make-transcoder (utf-8-codec)))))))
+
+ (pass-if "transcoded-port [input line]"
+ (string=? "ÄÖÜ"
+ (get-line (transcoded-port
+ (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
+ (make-transcoder (utf-8-codec))))))
+
+ (pass-if "transcoded-port [error handling mode = raise]"
+ (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
+ (error-handling-mode raise)))
+ (b (open-bytevector-input-port #vu8(255 2 1)))
+ (tp (transcoded-port b t)))
+ (guard (c ((i/o-decoding-error? c)
+ (eq? (i/o-error-port c) tp)))
+ (get-line tp)
+ #f))) ; fail if we reach this point
+
+ (pass-if "transcoded-port [error handling mode = replace]"
+ (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
+ (error-handling-mode replace)))
+ (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
+ (tp (transcoded-port b t)))
+ (string-suffix? "gnu" (get-line tp))))
+
+ (pass-if "transcoded-port, output [error handling mode = raise]"
+ (let-values (((p get)
+ (open-bytevector-output-port)))
+ (let* ((t (make-transcoder (latin-1-codec) (native-eol-style)
+ (error-handling-mode raise)))
+ (tp (transcoded-port p t)))
+ (guard (c ((i/o-encoding-error? c)
+ (and (eq? (i/o-error-port c) tp)
+ (char=? (i/o-encoding-error-char c) #\λ)
+ (bytevector=? (get) (string->utf8 "The letter ")))))
+ (put-string tp "The letter λ cannot be represented in Latin-1.")
+ #f))))
+
+ (pass-if "port-transcoder [transcoded port]"
+ (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
+ (make-transcoder (utf-8-codec))))
+ (t (port-transcoder p)))
+ (and t
+ (transcoder-codec t)
+ (eq? (native-eol-style)
+ (transcoder-eol-style t))
+ (eq? (error-handling-mode replace)
+ (transcoder-error-handling-mode t))))))
+
+(with-test-prefix "8.2.9 Textual input"
+
+ (pass-if "get-string-n [short]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU " (get-string-n port 4))))
+ (pass-if "get-string-n [long]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU Guile" (get-string-n port 256))))
+ (pass-if "get-string-n [eof]"
+ (let ((port (open-input-string "")))
+ (eof-object? (get-string-n port 4))))
+
+ (pass-if "get-string-n! [short]"
+ (let ((port (open-input-string "GNU Guile"))
+ (s (string-copy "Isn't XXX great?")))
+ (and (= 3 (get-string-n! port s 6 3))
+ (string=? s "Isn't GNU great?"))))
+
+ (with-test-prefix "read error"
+ (pass-if-condition "get-char" i/o-read-error?
+ (get-char (make-failing-port)))
+ (pass-if-condition "lookahead-char" i/o-read-error?
+ (lookahead-char (make-failing-port)))
+ ;; FIXME: these are not yet exception-correct
+ #|
+ (pass-if-condition "get-string-n" i/o-read-error?
+ (get-string-n (make-failing-port) 5))
+ (pass-if-condition "get-string-n!" i/o-read-error?
+ (get-string-n! (make-failing-port) (make-string 5) 0 5))
+ |#
+ (pass-if-condition "get-string-all" i/o-read-error?
+ (get-string-all (make-failing-port 100)))
+ (pass-if-condition "get-line" i/o-read-error?
+ (get-line (make-failing-port)))
+ (pass-if-condition "get-datum" i/o-read-error?
+ (get-datum (make-failing-port)))))
+
+(define (encoding-error-predicate char)
+ (lambda (c)
+ (and (i/o-encoding-error? c)
+ (char=? char (i/o-encoding-error-char c)))))
+
+(with-test-prefix "8.2.12 Textual Output"
+
+ (with-test-prefix "write error"
+ (pass-if-condition "put-char" i/o-write-error?
+ (put-char (make-failing-port) #\G))
+ (pass-if-condition "put-string" i/o-write-error?
+ (put-string (make-failing-port) "Hello World!"))
+ (pass-if-condition "put-datum" i/o-write-error?
+ (put-datum (make-failing-port) '(hello world!))))
+ (with-test-prefix "encoding error"
+ (pass-if-condition "put-char" (encoding-error-predicate #\λ)
+ (call-with-bytevector-output-port/transcoded
+ (make-transcoder (latin-1-codec)
+ (native-eol-style)
+ (error-handling-mode raise))
+ (lambda (port)
+ (put-char port #\λ))))
+ (pass-if-condition "put-string" (encoding-error-predicate #\λ)
+ (call-with-bytevector-output-port/transcoded
+ (make-transcoder (latin-1-codec)
+ (native-eol-style)
+ (error-handling-mode raise))
+ (lambda (port)
+ (put-string port "FooλBar"))))))
+
+(with-test-prefix "8.3 Simple I/O"
+ (with-test-prefix "read error"
+ (pass-if-condition "read-char" i/o-read-error?
+ (read-char (make-failing-port)))
+ (pass-if-condition "peek-char" i/o-read-error?
+ (peek-char (make-failing-port)))
+ (pass-if-condition "read" i/o-read-error?
+ (read (make-failing-port))))
+ (with-test-prefix "write error"
+ (pass-if-condition "display" i/o-write-error?
+ (display "Hi there!" (make-failing-port)))
+ (pass-if-condition "write" i/o-write-error?
+ (write '(hi there!) (make-failing-port)))
+ (pass-if-condition "write-char" i/o-write-error?
+ (write-char #\G (make-failing-port)))
+ (pass-if-condition "newline" i/o-write-error?
+ (newline (make-failing-port))))
+ (let ((filename (test-file)))
+ ;; ensure the test file exists
+ (call-with-output-file filename
+ (lambda (port) (write "foo" port)))
+ (pass-if "call-with-input-file [port is textual]"
+ (call-with-input-file filename textual-port?))
+ (pass-if-condition "call-with-input-file [exception: not-found]"
+ i/o-file-does-not-exist-error?
+ (call-with-input-file ",this-is-highly-unlikely-to-exist!"
+ values))
+ (pass-if-condition "call-with-output-file [exception: already-exists]"
+ i/o-file-already-exists-error?
+ (call-with-output-file filename
+ values))
+ (delete-file filename)))
+
+(with-test-prefix "8.2.13 Input/output ports"
+ (with-test-prefix "open-file-input/output-port [output]"
+ (test-output-file-opener open-file-input/output-port (test-file)))
+ (with-test-prefix "open-file-input/output-port [input]"
+ (test-input-file-opener open-file-input/output-port (test-file))))