-;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
+;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-io-ports)
- :use-module (test-suite lib)
- :use-module (srfi srfi-1)
- :use-module (srfi srfi-11)
- :use-module (rnrs io ports)
- :use-module (rnrs bytevector))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors))
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
+;; Set the default encoding of future ports to be Latin-1.
+(fluid-set! %default-port-encoding #f)
+
\f
(with-test-prefix "7.2.5 End-of-File Object"
(pass-if "eof-object"
(and (eqv? (eof-object) (eof-object))
- (eq? (eof-object) (eof-object)))))
+ (eq? (eof-object) (eof-object))))
+
+ (pass-if "port-eof?"
+ (port-eof? (open-input-string ""))))
\f
(with-test-prefix "7.2.8 Binary Input"
(pass-if "lookahead-u8"
(let ((port (open-input-string "A")))
(and (= (char->integer #\A) (lookahead-u8 port))
- (not (eof-object? port))
+ (= (char->integer #\A) (lookahead-u8 port))
(= (char->integer #\A) (get-u8 port))
(eof-object? (get-u8 port)))))
+ (pass-if "lookahead-u8 non-ASCII"
+ (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string "λ"))))
+ (and (= 206 (lookahead-u8 port))
+ (= 206 (lookahead-u8 port))
+ (= 206 (get-u8 port))
+ (= 187 (lookahead-u8 port))
+ (= 187 (lookahead-u8 port))
+ (= 187 (get-u8 port))
+ (eof-object? (lookahead-u8 port))
+ (eof-object? (get-u8 port)))))
+
+ (pass-if "lookahead-u8: result is unsigned"
+ ;; Bug #31081.
+ (let ((port (open-bytevector-input-port #vu8(255))))
+ (= (lookahead-u8 port) 255)))
+
(pass-if "get-bytevector-n [short]"
(let* ((port (open-input-string "GNU Guile"))
(bv (get-bytevector-n port 4)))
(put-u8 port 77)
(equal? (get-u8 port) 77)))
+ ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
+ ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
+ ;; the bytes through, unmodified. This is hacky, but we can't use
+ ;; "custom binary output ports" here because they're only tested
+ ;; later.
+
(pass-if "put-bytevector [2 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256)))
- (put-bytevector port bv)
- (equal? (bytevector->u8-list bv)
- (bytevector->u8-list
- (get-bytevector-n port (bytevector-length bv))))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256)))
+ (put-bytevector port bv)
+ (equal? (bytevector->u8-list bv)
+ (bytevector->u8-list
+ (get-bytevector-n port (bytevector-length bv)))))))
(pass-if "put-bytevector [3 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256))
- (start 10))
- (put-bytevector port bv start)
- (equal? (drop (bytevector->u8-list bv) start)
- (bytevector->u8-list
- (get-bytevector-n port (- (bytevector-length bv) start))))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10))
+ (put-bytevector port bv start)
+ (equal? (drop (bytevector->u8-list bv) start)
+ (bytevector->u8-list
+ (get-bytevector-n port (- (bytevector-length bv) start)))))))
(pass-if "put-bytevector [4 args]"
- (let ((port (make-soft-output-port))
- (bv (make-bytevector 256))
- (start 10)
- (count 77))
- (put-bytevector port bv start count)
- (equal? (take (drop (bytevector->u8-list bv) start) count)
- (bytevector->u8-list
- (get-bytevector-n port count)))))
+ (with-latin1-locale
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10)
+ (count 77))
+ (put-bytevector port bv start count)
+ (equal? (take (drop (bytevector->u8-list bv) start) count)
+ (bytevector->u8-list
+ (get-bytevector-n port count))))))
(pass-if-exception "put-bytevector with closed port"
exception:wrong-type-arg
(port (%make-void-port "w")))
(close-port port)
- (put-bytevector port bv))))
+ (put-bytevector port bv)))
+
+ (pass-if "put-bytevector with UTF-16 string port"
+ (let* ((str "hello, world")
+ (bv (string->utf16 str)))
+ (equal? str
+ (with-fluids ((%default-port-encoding "UTF-16BE"))
+ (call-with-output-string
+ (lambda (port)
+ (put-bytevector port bv)))))))
+
+ (pass-if "put-bytevector with wrong-encoding string port"
+ (let* ((str "hello, world")
+ (bv (string->utf16 str)))
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-encoding "UTF-32"))
+ (call-with-output-string
+ (lambda (port)
+ (put-bytevector port bv)))))
+ (lambda (key subr message errno from to faulty-bv)
+ (and (bytevector=? faulty-bv bv)
+ (string=? to "UTF-32")
+ (string? (strerror errno))))))))
\f
(with-test-prefix "7.2.7 Input Ports"
close!)))
(close-port port)
+ (gc) ; Test for marking a closed port.
closed?)))
\f
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "open-bytevector-output-port [extract after close]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (let ((source (make-bytevector 12345 #xFE)))
+ (put-bytevector port source)
+ (close-port port)
+ (bytevector=? (get-content) source))))
(pass-if "open-bytevector-output-port [put-u8]"
(let-values (((port get-content)
(not eof?)
(bytevector=? sink source)))))
+\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
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port (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)))
+ ;; FIXME: Should be (guard (c ((i/o-decoding-error? c) #t)) ...).
+ (catch 'encoding-error
+ (lambda ()
+ (get-line tp)
+ #f)
+ (lambda _
+ #t))))
+
+ (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)))))
;;; Local Variables:
-;;; coding: latin-1
;;; mode: scheme
;;; End: