;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
#:use-module (rnrs exceptions)
#: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)
-
(define-syntax pass-if-condition
(syntax-rules ()
((_ name predicate body0 body ...)
(lambda () #t)) ;; close-port
"rw")))
+(define (call-with-bytevector-output-port/transcoded transcoder receiver)
+ (call-with-bytevector-output-port
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port transcoder)
+ receiver))))
+
\f
(with-test-prefix "7.2.5 End-of-File Object"
(equal? (bytevector->u8-list bv)
(map char->integer (string->list str))))))
- (pass-if "get-bytevector-some [only-some]"
- (let* ((str "GNU Guile")
- (index 0)
- (port (make-soft-port
- (vector #f #f #f
- (lambda ()
- (if (>= index (string-length str))
- (eof-object)
- (let ((c (string-ref str index)))
- (set! index (+ index 1))
- c)))
- (lambda () #t)
- (lambda ()
- ;; Number of readily available octets: falls to
- ;; zero after 4 octets have been read.
- (- 4 (modulo index 5))))
- "r"))
- (bv (get-bytevector-some port)))
- (and (bytevector? bv)
- (= index 4)
- (= (bytevector-length bv) index)
- (equal? (bytevector->u8-list bv)
- (map char->integer (string->list "GNU "))))))
-
(pass-if "get-bytevector-all"
(let* ((str "GNU Guile")
(index 0)
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32"))
+ (with-fluids ((%default-port-encoding "UTF-32")
+ (%default-port-conversion-strategy 'error))
(call-with-output-string
(lambda (port)
- (put-bytevector port bv)))))
+ (put-bytevector port bv)))
+ #f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
\f
+(define (test-input-file-opener open filename)
+ (let ((contents (string->utf8 "GNU λ")))
+ ;; Create file
+ (call-with-output-file filename
+ (lambda (port) (put-bytevector port contents)))
+
+ (pass-if "opens binary input port with correct contents"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-port (open-file-input-port filename)
+ (lambda (port)
+ (and (binary-port? port)
+ (input-port? port)
+ (bytevector=? contents (get-bytevector-all port))))))))
+
+ (delete-file filename))
+
(with-test-prefix "7.2.7 Input Ports"
+ (with-test-prefix "open-file-input-port"
+ (test-input-file-opener open-file-input-port (test-file)))
+
;; This section appears here so that it can use the binary input
;; primitives.
(binary-port? (standard-input-port)))))
\f
-(with-test-prefix "8.2.10 Output ports"
-
- (let ((filename (test-file)))
- (pass-if "open-file-output-port [opens binary port]"
- (call-with-port (open-file-output-port filename)
- (lambda (port)
- (put-bytevector port '#vu8(1 2 3))
- (binary-port? port))))
+(define (test-output-file-opener open filename)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (pass-if "opens binary output port"
+ (call-with-port (open filename)
+ (lambda (port)
+ (put-bytevector port '#vu8(1 2 3))
+ (and (binary-port? port)
+ (output-port? port))))))
+
+ (pass-if-condition "exception: already-exists"
+ i/o-file-already-exists-error?
+ (open filename))
+
+ (pass-if "no-fail no-truncate"
+ (and
+ (call-with-port (open filename (file-options no-fail no-truncate))
+ (lambda (port)
+ (= 0 (port-position port))))
+ (= 3 (stat:size (stat filename)))))
+
+ (pass-if "no-fail"
+ (and
+ (call-with-port (open filename (file-options no-fail))
+ binary-port?)
+ (= 0 (stat:size (stat filename)))))
- (pass-if-condition "open-file-output-port [exception: already-exists]"
- i/o-file-already-exists-error?
- (open-file-output-port filename))
-
- (pass-if "open-file-output-port [no-fail no-truncate]"
- (and
- (call-with-port (open-file-output-port filename
- (file-options no-fail no-truncate))
- (lambda (port)
- (= 0 (port-position port))))
- (= 3 (stat:size (stat filename)))))
-
- (pass-if "open-file-output-port [no-fail]"
- (and
- (call-with-port (open-file-output-port filename (file-options no-fail))
- binary-port?)
- (= 0 (stat:size (stat filename)))))
+ (delete-file filename)
- (delete-file filename)
-
- (pass-if-condition "open-file-output-port [exception: does-not-exist]"
- i/o-file-does-not-exist-error?
- (open-file-output-port filename (file-options no-create))))
+ (pass-if-condition "exception: does-not-exist"
+ i/o-file-does-not-exist-error?
+ (open filename (file-options no-create))))
+
+(with-test-prefix "8.2.10 Output ports"
+
+ (with-test-prefix "open-file-output-port"
+ (test-output-file-opener open-file-output-port (test-file)))
(pass-if "open-bytevector-output-port"
(let-values (((port get-content)
(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))))))))
+ (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ÄÖÜ"))
(tp (transcoded-port b t)))
(guard (c ((i/o-decoding-error? c)
(eq? (i/o-error-port c) tp)))
- (get-line 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)
(put-string tp "The letter λ cannot be represented in Latin-1.")
#f))))
- (pass-if "port-transcoder [binary port]"
- (not (port-transcoder (open-bytevector-input-port #vu8()))))
-
(pass-if "port-transcoder [transcoded port]"
(let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
(make-transcoder (utf-8-codec))))
(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-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!)))))
+ (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"
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))))
+
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'guard 'scheme-indent-function 1)
HCoop / bpt / guile.git / blobdiff