;;;; 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, 2014 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
(define-module (test-io-ports)
#:use-module (test-suite lib)
+ #:use-module (test-suite guile-test)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (ice-9 match)
#:use-module (rnrs io ports)
+ #:use-module (rnrs io simple)
#:use-module (rnrs exceptions)
#:use-module (rnrs bytevectors))
-;;; All these tests assume Guile 1.8's port system, where characters are
-;;; treated as octets.
+(define-syntax pass-if-condition
+ (syntax-rules ()
+ ((_ name predicate body0 body ...)
+ (let ((cookie (list 'cookie)))
+ (pass-if name
+ (eq? cookie (guard (c ((predicate c) cookie))
+ body0 body ...)))))))
+
+(define (test-file)
+ (data-file-name "ports-test.tmp"))
+
+;; A input/output port that swallows all output, and produces just
+;; spaces on input. Reading and writing beyond `failure-position'
+;; produces `system-error' exceptions. Used for testing exception
+;; behavior.
+(define* (make-failing-port #:optional (failure-position 0))
+ (define (maybe-fail index errno)
+ (if (> index failure-position)
+ (scm-error 'system-error
+ 'failing-port
+ "I/O beyond failure position" '()
+ (list errno))))
+ (let ((read-index 0)
+ (write-index 0))
+ (define (write-char chr)
+ (set! write-index (+ 1 write-index))
+ (maybe-fail write-index ENOSPC))
+ (make-soft-port
+ (vector write-char
+ (lambda (str) ;; write-string
+ (for-each write-char (string->list str)))
+ (lambda () #t) ;; flush-output
+ (lambda () ;; read-char
+ (set! read-index (+ read-index 1))
+ (maybe-fail read-index EIO)
+ #\space)
+ (lambda () #t)) ;; close-port
+ "rw")))
-;; Set the default encoding of future ports to be Latin-1.
-(fluid-set! %default-port-encoding #f)
+(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.
(equal? (read-to-string port) str)))
+ (pass-if "bytevector-input-port is binary"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
+
(pass-if-exception "bytevector-input-port is read-only"
exception:wrong-type-arg
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
+ (pass-if "bytevector input port can seek to very end"
+ (let ((empty (open-bytevector-input-port '#vu8()))
+ (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
+ (and (begin (set-port-position! empty (port-position empty))
+ (= 0 (port-position empty)))
+ (begin (get-bytevector-n not-empty 3)
+ (set-port-position! not-empty (port-position not-empty))
+ (= 3 (port-position not-empty))))))
+
(pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
exception:wrong-num-args
(port (make-custom-binary-input-port "the port" read!
#f #f #f)))
- (bytevector=? (get-bytevector-all port) source)))
+ (and (binary-port? port)
+ (input-port? port)
+ (bytevector=? (get-bytevector-all port) source))))
(pass-if "custom binary input port does not support `port-position'"
(let* ((str "Hello Port!")
(not (or (port-has-port-position? port)
(port-has-set-port-position!? port)))))
+ (pass-if-exception "custom binary input port 'read!' returns too much"
+ exception:out-of-range
+ ;; In Guile <= 2.0.9 this would segfault.
+ (let* ((read! (lambda (bv start count)
+ (+ count 4242)))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+ (get-bytevector-all port)))
+
+ (pass-if-equal "custom binary input port supports `port-position', \
+not `set-port-position!'"
+ 42
+ (let ((port (make-custom-binary-input-port "the port" (const 0)
+ (const 42) #f #f)))
+ (and (port-has-port-position? port)
+ (not (port-has-set-port-position!? port))
+ (port-position port))))
+
(pass-if "custom binary input port supports `port-position'"
(let* ((str "Hello Port!")
(source (open-bytevector-input-port
(u8-list->bytevector
(map char->integer (string->list "Port!")))))))
+ (pass-if-equal "custom binary input port buffered partial reads"
+ "Hello Port!"
+ ;; Check what happens when READ! returns less than COUNT bytes.
+ (let* ((src (string->utf8 "Hello Port!"))
+ (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc.
+ (offset 0)
+ (read! (lambda (bv start count)
+ (match chunks
+ ((count rest ...)
+ (bytevector-copy! src offset bv start count)
+ (set! chunks rest)
+ (set! offset (+ offset count))
+ count)
+ (()
+ 0))))
+ (port (make-custom-binary-input-port "the port"
+ read! #f #f #f)))
+ (get-string-all port)))
+
+ (pass-if-equal "custom binary input port unbuffered & 'port-position'"
+ '(0 2 5 11)
+ ;; Check that the value returned by 'port-position' is correct, and
+ ;; that each 'port-position' call leads one call to the
+ ;; 'get-position' method.
+ (let* ((str "Hello Port!")
+ (output (make-bytevector (string-length str)))
+ (source (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-string-input-port str)))
+ (read! (lambda (bv start count)
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (pos '())
+ (get-pos (lambda ()
+ (let ((p (port-position source)))
+ (set! pos (cons p pos))
+ p)))
+ (port (make-custom-binary-input-port "the port" read!
+ get-pos #f #f)))
+ (setvbuf port _IONBF)
+ (and (= 0 (port-position port))
+ (begin
+ (get-bytevector-n! port output 0 2)
+ (= 2 (port-position port)))
+ (begin
+ (get-bytevector-n! port output 2 3)
+ (= 5 (port-position port)))
+ (let ((bv (string->utf8 (get-string-all port))))
+ (bytevector-copy! bv 0 output 5 (bytevector-length bv))
+ (= (string-length str) (port-position port)))
+ (bytevector=? output (string->utf8 str))
+ (reverse pos))))
+
+ (pass-if-equal "custom binary input port unbuffered & 'read!' calls"
+ `((2 "He") (3 "llo") (42 " Port!"))
+ (let* ((str "Hello Port!")
+ (source (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-string-input-port str)))
+ (reads '())
+ (read! (lambda (bv start count)
+ (set! reads (cons count reads))
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+
+ (setvbuf port _IONBF)
+ (let ((ret (list (get-bytevector-n port 2)
+ (get-bytevector-n port 3)
+ (get-bytevector-n port 42))))
+ (zip (reverse reads)
+ (map (lambda (obj)
+ (if (bytevector? obj)
+ (utf8->string obj)
+ obj))
+ ret)))))
+
+ (pass-if-equal "custom binary input port, unbuffered then buffered"
+ `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
+ (777 ,(eof-object)))
+ (let* ((str "Lorem ipsum dolor sit amet, consectetur…")
+ (source (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-string-input-port str)))
+ (reads '())
+ (read! (lambda (bv start count)
+ (set! reads (cons count reads))
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+
+ (setvbuf port _IONBF)
+ (let ((ret (list (get-bytevector-n port 6)
+ (get-bytevector-n port 12)
+ (begin
+ (setvbuf port _IOFBF 777)
+ (get-bytevector-n port 42))
+ (get-bytevector-n port 42))))
+ (zip (reverse reads)
+ (map (lambda (obj)
+ (if (bytevector? obj)
+ (utf8->string obj)
+ obj))
+ ret)))))
+
+ (pass-if-equal "custom binary input port, buffered then unbuffered"
+ `((18
+ 42 14 ; scm_c_read tries to fill the 42-byte buffer
+ 42)
+ ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
+ (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…")
+ (source (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-string-input-port str)))
+ (reads '())
+ (read! (lambda (bv start count)
+ (set! reads (cons count reads))
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+
+ (setvbuf port _IOFBF 18)
+ (let ((ret (list (get-bytevector-n port 6)
+ (get-bytevector-n port 12)
+ (begin
+ (setvbuf port _IONBF)
+ (get-bytevector-n port 42))
+ (get-bytevector-n port 42))))
+ (list (reverse reads)
+ (map (lambda (obj)
+ (if (bytevector? obj)
+ (utf8->string obj)
+ obj))
+ ret)))))
+
(pass-if "custom binary input port `close-proc' is called"
(let* ((closed? #f)
(read! (lambda (bv start count) 0))
(binary-port? (standard-input-port)))))
\f
+(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)))))
+
+ (delete-file filename)
+
+ (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)
(open-bytevector-output-port #f)))
(put-bytevector port source)
(and (bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
-
+
+ (pass-if "bytevector-output-port is binary"
+ (binary-port? (open-bytevector-output-port)))
+
(pass-if "open-bytevector-output-port [extract after close]"
(let-values (((port get-content)
(open-bytevector-output-port)))
(bytevector=? (get-content) source)
(bytevector=? (get-content) (make-bytevector 0))))))
- (pass-if "make-custom-binary-output"
+ (pass-if "make-custom-binary-output-port"
(let ((port (make-custom-binary-output-port "cbop"
(lambda (x y z) 0)
#f #f #f)))
(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)
(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?")))))
+ (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))))
;;; Local Variables:
;;; mode: scheme
HCoop / bpt / guile.git / blobdiff