X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/7af531508c5931261ff8957708642cac67bf86a5..f6f4feb0a2222efcb297e634603621126542e63f:/test-suite/tests/r6rs-ports.test

diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index c2b0755f8..4b756cce8 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,7 +1,7 @@
-;;;; 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, 2012 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
@@ -18,24 +18,69 @@
 ;;;; 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))
-
-;;; All these tests assume Guile 1.8's port system, where characters are
-;;; treated as octets.
+  #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs io simple)
+  #:use-module (rnrs exceptions)
+  #:use-module (rnrs bytevectors))
+
+(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 binary
-(setbinary)
+(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))))
 
 
 (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 ""))))
 
 
 (with-test-prefix "7.2.8 Binary Input"
@@ -48,10 +93,27 @@
   (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)))
@@ -101,30 +163,6 @@
            (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)
@@ -185,32 +223,41 @@
       (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
@@ -219,11 +266,53 @@
            (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 'decoding-error
+        (lambda ()
+          (with-fluids ((%default-port-encoding "UTF-32")
+                        (%default-port-conversion-strategy 'error))
+            (call-with-output-string
+              (lambda (port)
+                (put-bytevector port bv)))
+            #f))                           ; fail if we reach this point
+        (lambda (key subr message errno port)
+          (string? (strerror errno)))))))
 
 
+(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.
 
@@ -243,6 +332,10 @@
 
       (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
 
@@ -269,6 +362,15 @@
                          (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
 
@@ -290,7 +392,9 @@
            (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!")
@@ -346,11 +450,50 @@
 
       (close-port port)
       (gc) ; Test for marking a closed port.
-      closed?)))
+      closed?))
+
+  (pass-if "standard-input-port is binary"
+    (with-fluids ((%default-port-encoding "UTF-8"))
+      (binary-port? (standard-input-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)))))
+    
+  (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)))
@@ -359,6 +502,17 @@
         (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)))
+      (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)
                   (open-bytevector-output-port)))
@@ -396,7 +550,7 @@
              (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)))
@@ -450,10 +604,189 @@
       (put-bytevector port source)
       (and (= sink-pos (bytevector-length source))
            (not eof?)
-           (bytevector=? sink source)))))
+           (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)))))
 
+
+(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))))
 
 ;;; Local Variables:
-;;; coding: latin-1
 ;;; mode: scheme
+;;; eval: (put 'guard 'scheme-indent-function 1)
 ;;; End: