-;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
+;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
+;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;;
;;;; 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
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-ports)
- :use-module (test-suite lib)
- :use-module (test-suite guile-test)
- :use-module (ice-9 popen)
- :use-module (ice-9 rdelim))
+ #:use-module (test-suite lib)
+ #:use-module (test-suite guile-test)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)))
(define (display-line . args)
(for-each display args)
\f
;;;; Some general utilities for testing ports.
+;; Make sure we are set up for 8-bit Latin-1 data.
+(fluid-set! %default-port-encoding "ISO-8859-1")
+(for-each (lambda (p)
+ (set-port-encoding! p (fluid-ref %default-port-encoding)))
+ (list (current-input-port) (current-output-port)
+ (current-error-port)))
+
;;; Read from PORT until EOF, and return the result as a string.
(define (read-all port)
(let loop ((chars '()))
(string=? line test-string)))
(delete-file filename))
+;;; read-line should use the port encoding (not the locale encoding).
+(let ((str "ĉu bone?"))
+ (with-locale "C"
+ (let* ((filename (test-file))
+ (port (open-file filename "wl")))
+ (set-port-encoding! port "UTF-8")
+ (write-line str port)
+ (let ((in-port (open-input-file filename)))
+ (set-port-encoding! in-port "UTF-8")
+ (let ((line (read-line in-port)))
+ (close-port in-port)
+ (close-port port)
+ (pass-if "file: read-line honors port encoding"
+ (string=? line str))))
+ (delete-file filename))))
+
+;;; binary mode ignores port encoding
+(pass-if "file: binary mode ignores port encoding"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let* ((filename (test-file))
+ (port (open-file filename "w"))
+ (test-string "一二三")
+ (binary-test-string
+ (apply string
+ (map integer->char
+ (uniform-vector->list
+ (string->utf8 test-string))))))
+ (write-line test-string port)
+ (close-port port)
+ (let* ((in-port (open-file filename "rb"))
+ (line (read-line in-port)))
+ (close-port in-port)
+ (delete-file filename)
+ (string=? line binary-test-string)))))
+
+;;; binary mode ignores file coding declaration
+(pass-if "file: binary mode ignores file coding declaration"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let* ((filename (test-file))
+ (port (open-file filename "w"))
+ (test-string "一二三")
+ (binary-test-string
+ (apply string
+ (map integer->char
+ (uniform-vector->list
+ (string->utf8 test-string))))))
+ (write-line ";; coding: utf-8" port)
+ (write-line test-string port)
+ (close-port port)
+ (let* ((in-port (open-file filename "rb"))
+ (line1 (read-line in-port))
+ (line2 (read-line in-port)))
+ (close-port in-port)
+ (delete-file filename)
+ (string=? line2 binary-test-string)))))
+
+;; open-file honors file coding declarations
+(pass-if "file: open-file honors coding declarations"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let* ((filename (test-file))
+ (port (open-output-file filename))
+ (test-string "€100"))
+ (set-port-encoding! port "ISO-8859-15")
+ (write-line ";; coding: iso-8859-15" port)
+ (write-line test-string port)
+ (close-port port)
+ (let* ((in-port (open-input-file filename))
+ (line1 (read-line in-port))
+ (line2 (read-line in-port)))
+ (close-port in-port)
+ (delete-file filename)
+ (string=? line2 test-string)))))
+
;;; ungetting characters and strings.
(with-input-from-string "walk on the moon\nmoon"
(lambda ()
(string-set! text 0 #\a)
(string-set! text (- len 1) #\b)
(pass-if "output check"
- (string=? text result))))
+ (string=? text result)))
+
+ (pass-if "%default-port-encoding is honored"
+ (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
+ (equal? (map (lambda (e)
+ (with-fluids ((%default-port-encoding e))
+ (call-with-output-string
+ (lambda (p)
+ (and (string=? e (port-encoding p))
+ (display (port-encoding p) p))))))
+ encodings)
+ encodings)))
+
+ (pass-if "suitable encoding [latin-1]"
+ (let ((str "hello, world"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (equal? str
+ (with-output-to-string
+ (lambda ()
+ (display str)))))))
+
+ (pass-if "suitable encoding [latin-3]"
+ (let ((str "ĉu bone?"))
+ (with-fluids ((%default-port-encoding "ISO-8859-3"))
+ (equal? str
+ (with-output-to-string
+ (lambda ()
+ (display str)))))))
+
+ (pass-if "wrong encoding"
+ (let ((str "ĉu bone?"))
+ (catch 'encoding-error
+ (lambda ()
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-output-to-string
+ (lambda ()
+ (display str)))))
+ (lambda (key subr message errno port chr)
+ (and (eq? chr #\ĉ)
+ (string? (strerror errno)))))))
+
+ (pass-if "wrong encoding, substitute"
+ (let ((str "ĉu bone?"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (with-output-to-string
+ (lambda ()
+ (set-port-conversion-strategy! (current-output-port)
+ 'substitute)
+ (display str)))
+ "?u bone?"))))
+
+ (pass-if "wrong encoding, escape"
+ (let ((str "ĉu bone?"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (with-output-to-string
+ (lambda ()
+ (set-port-conversion-strategy! (current-output-port)
+ 'escape)
+ (display str)))
+ "\\u0109u bone?"))))
+
+ (pass-if "peek-char [latin-1]"
+ (let ((p (with-fluids ((%default-port-encoding #f))
+ (open-input-string "hello, world"))))
+ (and (char=? (peek-char p) #\h)
+ (char=? (peek-char p) #\h)
+ (char=? (peek-char p) #\h)
+ (= (port-line p) 0)
+ (= (port-column p) 0))))
+
+ (pass-if "peek-char [utf-8]"
+ (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string "안녕하세요"))))
+ (and (char=? (peek-char p) #\안)
+ (char=? (peek-char p) #\안)
+ (char=? (peek-char p) #\안)
+ (= (port-line p) 0)
+ (= (port-column p) 0))))
+
+ (pass-if "peek-char [utf-16]"
+ (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
+ (open-input-string "안녕하세요"))))
+ (and (char=? (peek-char p) #\안)
+ (char=? (peek-char p) #\안)
+ (char=? (peek-char p) #\안)
+ (= (port-line p) 0)
+ (= (port-column p) 0))))
+
+ ;; Mini DSL to test decoding error handling.
+ (letrec-syntax ((decoding-error?
+ (syntax-rules ()
+ ((_ port exp)
+ (catch 'decoding-error
+ (lambda ()
+ (pk 'exp exp)
+ #f)
+ (lambda (key subr message errno p)
+ (and (eq? p port)
+ (not (= 0 errno))))))))
+ (make-check
+ (syntax-rules (-> error eof)
+ ((_ port (proc -> error))
+ (if (eq? 'substitute
+ (port-conversion-strategy port))
+ (eq? (proc port) #\?)
+ (decoding-error? port (proc port))))
+ ((_ port (proc -> eof))
+ (eof-object? (proc port)))
+ ((_ port (proc -> char))
+ (eq? (proc port) char))))
+ (make-checks
+ (syntax-rules ()
+ ((_ port check ...)
+ (and (make-check port check) ...))))
+ (make-peek+read-checks
+ (syntax-rules ()
+ ((_ port (result ...) e1 expected ...)
+ (make-peek+read-checks port
+ (result ...
+ (peek-char -> e1)
+ (read-char -> e1))
+ expected ...))
+ ((_ port (result ...))
+ (make-checks port result ...))
+ ((_ port #f e1 expected ...)
+ (make-peek+read-checks port
+ ((peek-char -> e1)
+ (read-char -> e1))
+ expected ...))))
+
+ (test-decoding-error*
+ (syntax-rules ()
+ ((_ sequence encoding strategy (expected ...))
+ (begin
+ (pass-if (format #f "test-decoding-error: ~s ~s ~s"
+ 'sequence encoding strategy)
+ (let ((p (open-bytevector-input-port
+ (u8-list->bytevector 'sequence))))
+ (set-port-encoding! p encoding)
+ (set-port-conversion-strategy! p strategy)
+ (make-checks p
+ (read-char -> expected) ...)))
+
+ ;; Generate the same test, but with one
+ ;; `peek-char' call before each `read-char'.
+ ;; Both should yield the same result.
+ (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
+ 'sequence encoding strategy)
+ (let ((p (open-bytevector-input-port
+ (u8-list->bytevector 'sequence))))
+ (set-port-encoding! p encoding)
+ (set-port-conversion-strategy! p strategy)
+ (make-peek+read-checks p #f expected
+ ...)))))))
+ (test-decoding-error
+ (syntax-rules ()
+ ((_ sequence encoding (expected ...))
+ (begin
+ (test-decoding-error* sequence encoding 'error
+ (expected ...))
+
+ ;; `escape' should behave exactly like `error'.
+ (test-decoding-error* sequence encoding 'escape
+ (expected ...))
+
+ (test-decoding-error* sequence encoding 'substitute
+ (expected ...)))))))
+
+ (test-decoding-error (255 65 66 67) "UTF-8"
+ (error #\A #\B #\C eof))
+
+ (test-decoding-error (255 206 187 206 188) "UTF-8"
+ (error #\λ #\μ eof))
+
+ (test-decoding-error (206 187 206) "UTF-8"
+ ;; Unterminated sequence.
+ (#\λ error eof))
+
+ ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
+ ;; of the "Conformance" chapter of Unicode 6.0.0.)
+
+ (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
+ (error ;; C0: should be in the C2..DF range
+ error ;; 80: invalid
+ #\A
+ eof))
+
+ (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
+ ;; Section 3.9 of Unicode 6.0.0 reads:
+ ;; "If the converter encounters an ill-formed UTF-8 code unit
+ ;; sequence which starts with a valid first byte, but which does
+ ;; not continue with valid successor bytes (see Table 3-7), it
+ ;; must not consume the successor bytes".
+ ;; Glibc/libiconv do not conform to it and instead swallow the
+ ;; #x41. This example appears literally in Section 3.9.
+ (error ;; 41: invalid successor
+ #\A ;; 41: valid starting byte
+ #\B
+ eof))
+
+ (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
+ ;; According to Unicode 6.0.0, Section 3.9, "the only formal
+ ;; requirement mandated by Unicode conformance for a converter is
+ ;; that the <41> be processed and correctly interpreted as
+ ;; <U+0041>".
+ (error ;; 2nd byte should be in the A0..BF range
+ error ;; 80: not a valid starting byte
+ error ;; 80: not a valid starting byte
+ #\A
+ eof))
+
+ (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
+ (error ;; 3rd byte should be in the 80..BF range
+ #\A
+ #\B
+ eof))
+
+ (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
+ (error ;; 2nd byte should be in the 90..BF range
+ error ;; 88: not a valid starting byte
+ error ;; 88: not a valid starting byte
+ error ;; 88: not a valid starting byte
+ eof))))
(with-test-prefix "call-with-output-string"
(set-port-line! port n)
(eqv? n (port-line port)))))
+(with-test-prefix "port-encoding"
+
+ (pass-if-exception "set-port-encoding!, wrong encoding"
+ exception:miscellaneous-error
+ (set-port-encoding! (open-input-string "") "does-not-exist"))
+
+ (pass-if-exception "%default-port-encoding, wrong encoding"
+ exception:miscellaneous-error
+ (read (with-fluids ((%default-port-encoding "does-not-exist"))
+ (open-input-string "")))))
+
;;;
;;; port-for-each
;;;
(list read read-char read-line)
'("read" "read-char" "read-line")))
+\f
+
+(with-test-prefix "setvbuf"
+
+ (pass-if "line/column number preserved"
+ ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
+ ;; line and/or column number.
+ (call-with-output-file (test-file)
+ (lambda (p)
+ (display "This is GNU Guile.\nWelcome." p)))
+ (call-with-input-file (test-file)
+ (lambda (p)
+ (and (eq? #\T (read-char p))
+ (let ((line (port-line p))
+ (col (port-column p)))
+ (and (= line 0) (= col 1)
+ (begin
+ (setvbuf p _IOFBF 777)
+ (let ((line* (port-line p))
+ (col* (port-column p)))
+ (and (= line line*)
+ (= col col*)))))))))))
+
+\f
+
+(define-syntax-rule (with-load-path path body ...)
+ (let ((new path)
+ (old %load-path))
+ (dynamic-wind
+ (lambda ()
+ (set! %load-path new))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (set! %load-path old)))))
+
+(with-test-prefix "%file-port-name-canonicalization"
+
+ (pass-if "absolute file name & empty %load-path entry"
+ ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
+ ;; of "/dev/null". See
+ ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
+ ;; for a discussion.
+ (equal? "/dev/null"
+ (with-load-path (cons "" (delete "/" %load-path))
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null")))))))
+
(delete-file (test-file))
+
+;;; Local Variables:
+;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
+;;; eval: (put 'with-load-path 'scheme-indent-function 1)
+;;; End:
HCoop / bpt / guile.git / blobdiff