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

diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 7a382b75b..4b756cce8 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
 ;;;; 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
@@ -27,12 +27,6 @@
   #: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 ...)
@@ -72,6 +66,12 @@
              (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))))
+
 
 (with-test-prefix "7.2.5 End-of-File Object"
 
@@ -163,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)
@@ -306,16 +282,37 @@
            (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)))))))
 
 
+(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.
 
@@ -460,38 +457,42 @@
       (binary-port? (standard-input-port)))))
 
 
-(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)
@@ -620,11 +621,9 @@
     (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ÄÖÜ"))
@@ -647,7 +646,8 @@
            (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)
@@ -669,9 +669,6 @@
           (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))))
@@ -720,6 +717,11 @@
     (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"
@@ -728,7 +730,22 @@
     (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"
@@ -763,6 +780,12 @@
         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)