-;;;; 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 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
+;;;; 2011, 2012, 2013 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
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(use-modules (test-suite lib)
- (ice-9 popen))
+(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 (rnrs bytevectors)
+ #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
+ open-bytevector-output-port
+ put-bytevector
+ get-bytevector-n
+ get-bytevector-all
+ unget-bytevector)))
(define (display-line . args)
(for-each display args)
(newline))
(define (test-file)
- (tmpnam))
+ (data-file-name "ports-test.tmp"))
\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))
\f
+
+(with-test-prefix "%default-port-conversion-strategy"
+
+ (pass-if "initial value"
+ (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
+
+ (pass-if "file port"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-file "/dev/null"
+ (lambda (p)
+ (port-conversion-strategy p)))))
+ strategies)
+ strategies)))
+
+ (pass-if "(set-port-conversion-strategy! #f sym)"
+ (begin
+ (set-port-conversion-strategy! #f 'error)
+ (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
+ (begin
+ (set-port-conversion-strategy! #f 'substitute)
+ (eq? (fluid-ref %default-port-conversion-strategy)
+ 'substitute)))))
+
+)
+
+\f
;;;; Normal file ports.
;;; Write out an s-expression, and read it back.
-(catch-test-errors
- (let ((string '("From fairest creatures we desire increase,"
- "That thereby beauty's rose might never die,"))
- (filename (test-file)))
- (let ((port (open-output-file filename)))
- (write string port)
- (close-port port))
- (let ((port (open-input-file filename)))
- (let ((in-string (read port)))
- (pass-if "file: write and read back list of strings"
- (equal? string in-string)))
- (close-port port))
- (delete-file filename)))
+(let ((string '("From fairest creatures we desire increase,"
+ "That thereby beauty's rose might never die,"))
+ (filename (test-file)))
+ (let ((port (open-output-file filename)))
+ (write string port)
+ (close-port port))
+ (let ((port (open-input-file filename)))
+ (let ((in-string (read port)))
+ (pass-if "file: write and read back list of strings"
+ (equal? string in-string)))
+ (close-port port))
+ (delete-file filename))
;;; Write out a string, and read it back a character at a time.
-(catch-test-errors
- (let ((string "This is a test string\nwith no newline at the end")
- (filename (test-file)))
- (let ((port (open-output-file filename)))
- (display string port)
- (close-port port))
- (let ((in-string (read-file filename)))
- (pass-if "file: write and read back characters"
- (equal? string in-string)))
- (delete-file filename)))
+(let ((string "This is a test string\nwith no newline at the end")
+ (filename (test-file)))
+ (let ((port (open-output-file filename)))
+ (display string port)
+ (close-port port))
+ (let ((in-string (read-file filename)))
+ (pass-if "file: write and read back characters"
+ (equal? string in-string)))
+ (delete-file filename))
;;; Buffered input/output port with seeking.
-(catch-test-errors
- (let* ((filename (test-file))
- (port (open-file filename "w+")))
- (display "J'Accuse" port)
- (seek port -1 SEEK_CUR)
- (pass-if "file: r/w 1"
- (char=? (read-char port) #\e))
- (pass-if "file: r/w 2"
- (eof-object? (read-char port)))
- (seek port -1 SEEK_CUR)
- (write-char #\x port)
- (seek port 7 SEEK_SET)
- (pass-if "file: r/w 3"
- (char=? (read-char port) #\x))
- (seek port -2 SEEK_END)
- (pass-if "file: r/w 4"
- (char=? (read-char port) #\s))
- (delete-file filename)))
+(let* ((filename (test-file))
+ (port (open-file filename "w+")))
+ (display "J'Accuse" port)
+ (seek port -1 SEEK_CUR)
+ (pass-if "file: r/w 1"
+ (char=? (read-char port) #\e))
+ (pass-if "file: r/w 2"
+ (eof-object? (read-char port)))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (seek port 7 SEEK_SET)
+ (pass-if "file: r/w 3"
+ (char=? (read-char port) #\x))
+ (seek port -2 SEEK_END)
+ (pass-if "file: r/w 4"
+ (char=? (read-char port) #\s))
+ (close-port port)
+ (delete-file filename))
;;; Unbuffered input/output port with seeking.
-(catch-test-errors
- (let* ((filename (test-file))
- (port (open-file filename "w+0")))
- (display "J'Accuse" port)
- (seek port -1 SEEK_CUR)
- (pass-if "file: ub r/w 1"
- (char=? (read-char port) #\e))
- (pass-if "file: ub r/w 2"
- (eof-object? (read-char port)))
- (seek port -1 SEEK_CUR)
- (write-char #\x port)
- (seek port 7 SEEK_SET)
- (pass-if "file: ub r/w 3"
- (char=? (read-char port) #\x))
- (seek port -2 SEEK_END)
- (pass-if "file: ub r/w 4"
- (char=? (read-char port) #\s))
- (delete-file filename)))
+(let* ((filename (test-file))
+ (port (open-file filename "w+0")))
+ (display "J'Accuse" port)
+ (seek port -1 SEEK_CUR)
+ (pass-if "file: ub r/w 1"
+ (char=? (read-char port) #\e))
+ (pass-if "file: ub r/w 2"
+ (eof-object? (read-char port)))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (seek port 7 SEEK_SET)
+ (pass-if "file: ub r/w 3"
+ (char=? (read-char port) #\x))
+ (seek port -2 SEEK_END)
+ (pass-if "file: ub r/w 4"
+ (char=? (read-char port) #\s))
+ (close-port port)
+ (delete-file filename))
+
+;;; Buffered output-only and input-only ports with seeking.
+(let* ((filename (test-file))
+ (port (open-output-file filename)))
+ (display "J'Accuse" port)
+ (pass-if "file: out tell"
+ (= (seek port 0 SEEK_CUR) 8))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (close-port port)
+ (let ((iport (open-input-file filename)))
+ (pass-if "file: in tell 0"
+ (= (seek iport 0 SEEK_CUR) 0))
+ (read-char iport)
+ (pass-if "file: in tell 1"
+ (= (seek iport 0 SEEK_CUR) 1))
+ (unread-char #\z iport)
+ (pass-if "file: in tell 0 after unread"
+ (= (seek iport 0 SEEK_CUR) 0))
+ (pass-if "file: unread char still there"
+ (char=? (read-char iport) #\z))
+ (seek iport 7 SEEK_SET)
+ (pass-if "file: in last char"
+ (char=? (read-char iport) #\x))
+ (close-port iport))
+ (delete-file filename))
;;; unusual characters.
-(catch-test-errors
- (let* ((filename (test-file))
- (port (open-output-file filename)))
- (display (string #\nul (integer->char 255) (integer->char 128)
- #\nul) port)
- (close-port port)
- (let* ((port (open-input-file filename))
- (line (read-line port)))
- (pass-if "file: read back NUL 1"
- (char=? (string-ref line 0) #\nul))
- (pass-if "file: read back 255"
- (char=? (string-ref line 1) (integer->char 255)))
- (pass-if "file: read back 128"
- (char=? (string-ref line 2) (integer->char 128)))
- (pass-if "file: read back NUL 2"
- (char=? (string-ref line 3) #\nul))
- (pass-if "file: EOF"
- (eof-object? (read-char port))))
- (delete-file filename)))
+(let* ((filename (test-file))
+ (port (open-output-file filename)))
+ (display (string #\nul (integer->char 255) (integer->char 128)
+ #\nul) port)
+ (close-port port)
+ (let* ((port (open-input-file filename))
+ (line (read-line port)))
+ (pass-if "file: read back NUL 1"
+ (char=? (string-ref line 0) #\nul))
+ (pass-if "file: read back 255"
+ (char=? (string-ref line 1) (integer->char 255)))
+ (pass-if "file: read back 128"
+ (char=? (string-ref line 2) (integer->char 128)))
+ (pass-if "file: read back NUL 2"
+ (char=? (string-ref line 3) #\nul))
+ (pass-if "file: EOF"
+ (eof-object? (read-char port)))
+ (close-port port))
+ (delete-file filename))
;;; line buffering mode.
-(catch-test-errors
- (let* ((filename (test-file))
- (port (open-file filename "wl"))
- (test-string "one line more or less"))
- (write-line test-string port)
- (let* ((in-port (open-input-file filename))
- (line (read-line in-port)))
- (close-port in-port)
- (close-port port)
- (pass-if "file: line buffering"
- (string=? line test-string)))
- (delete-file filename)))
+(let* ((filename (test-file))
+ (port (open-file filename "wl"))
+ (test-string "one line more or less"))
+ (write-line test-string port)
+ (let* ((in-port (open-input-file filename))
+ (line (read-line in-port)))
+ (close-port in-port)
+ (close-port port)
+ (pass-if "file: line buffering"
+ (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 ignores file coding declaration by default
+(pass-if "file: open-file ignores coding declaration by default"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let* ((filename (test-file))
+ (port (open-output-file filename))
+ (test-string "€100"))
+ (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)))))
+
+;; open-input-file with guess-encoding honors coding declaration
+(pass-if "file: open-input-file with guess-encoding honors coding declaration"
+ (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
+ #:guess-encoding #t))
+ (line1 (read-line in-port))
+ (line2 (read-line in-port)))
+ (close-port in-port)
+ (delete-file filename)
+ (string=? line2 test-string)))))
+
+(with-test-prefix "keyword arguments for file openers"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (let ((filename (test-file)))
+
+ (with-test-prefix "write #:encoding"
+
+ (pass-if-equal "open-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (let ((port (open-file filename "w"
+ #:encoding "UTF-16LE")))
+ (display "test" port)
+ (close-port port))
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "open-output-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (let ((port (open-output-file filename
+ #:encoding "UTF-16LE")))
+ (display "test" port)
+ (close-port port))
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "call-with-output-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (call-with-output-file filename
+ (lambda (port)
+ (display "test" port))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "with-output-to-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (with-output-to-file filename
+ (lambda ()
+ (display "test"))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv))
+
+ (pass-if-equal "with-error-to-file"
+ #vu8(116 0 101 0 115 0 116 0)
+ (with-error-to-file
+ filename
+ (lambda ()
+ (display "test" (current-error-port)))
+ #:encoding "UTF-16LE")
+ (let* ((port (open-file filename "rb"))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv)))
+
+ (with-test-prefix "write #:binary"
+
+ (pass-if-equal "open-output-file"
+ "ISO-8859-1"
+ (let* ((port (open-output-file filename #:binary #t))
+ (enc (port-encoding port)))
+ (close-port port)
+ enc))
+
+ (pass-if-equal "call-with-output-file"
+ "ISO-8859-1"
+ (call-with-output-file filename port-encoding #:binary #t))
+
+ (pass-if-equal "with-output-to-file"
+ "ISO-8859-1"
+ (with-output-to-file filename
+ (lambda () (port-encoding (current-output-port)))
+ #:binary #t))
+
+ (pass-if-equal "with-error-to-file"
+ "ISO-8859-1"
+ (with-error-to-file
+ filename
+ (lambda () (port-encoding (current-error-port)))
+ #:binary #t)))
+
+ (with-test-prefix "read #:encoding"
+
+ (pass-if-equal "open-file read #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (let* ((port (open-file filename "r" #:encoding "UTF-16LE"))
+ (str (read-string port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (let* ((port (open-input-file filename #:encoding "UTF-16LE"))
+ (str (read-string port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (call-with-input-file filename
+ read-string
+ #:encoding "UTF-16LE"))
+
+ (pass-if-equal "with-input-from-file #:encoding"
+ "test"
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+ (with-input-from-file filename
+ read-string
+ #:encoding "UTF-16LE")))
+
+ (with-test-prefix "read #:binary"
+
+ (pass-if-equal "open-input-file"
+ "ISO-8859-1"
+ (let* ((port (open-input-file filename #:binary #t))
+ (enc (port-encoding port)))
+ (close-port port)
+ enc))
+
+ (pass-if-equal "call-with-input-file"
+ "ISO-8859-1"
+ (call-with-input-file filename port-encoding #:binary #t))
+
+ (pass-if-equal "with-input-from-file"
+ "ISO-8859-1"
+ (with-input-from-file filename
+ (lambda () (port-encoding (current-input-port)))
+ #:binary #t)))
+
+ (with-test-prefix "#:guess-encoding with coding declaration"
+
+ (pass-if-equal "open-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-file filename "r"
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+ (str (begin (read-line port)
+ (read-line port)
+ (read-line port))))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-input-file filename
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+ (str (begin (read-line port)
+ (read-line port)
+ (read-line port))))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (call-with-input-file filename
+ (lambda (port)
+ (read-line port)
+ (read-line port)
+ (read-line port))
+ #:guess-encoding #t
+ #:encoding "UTF-16LE"))
+
+ (pass-if-equal "with-input-from-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda ()
+ (write-line "test")
+ (write-line "; coding: ISO-8859-15")
+ (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (with-input-from-file filename
+ (lambda ()
+ (read-line)
+ (read-line)
+ (read-line))
+ #:guess-encoding #t
+ #:encoding "UTF-16LE")))
+
+ (with-test-prefix "#:guess-encoding without coding declaration"
+
+ (pass-if-equal "open-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda () (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-file filename "r"
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+ (str (read-line port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "open-input-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda () (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (let* ((port (open-input-file filename
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+ (str (read-line port)))
+ (close-port port)
+ str))
+
+ (pass-if-equal "call-with-input-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda () (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (call-with-input-file filename
+ read-line
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15"))
+
+ (pass-if-equal "with-input-from-file"
+ "€100"
+ (with-output-to-file filename
+ (lambda () (write-line "€100"))
+ #:encoding "ISO-8859-15")
+ (with-input-from-file filename
+ read-line
+ #:guess-encoding #t
+ #:encoding "ISO-8859-15")))
+
+ (delete-file filename))))
;;; ungetting characters and strings.
-(catch-test-errors
- (with-input-from-string "walk on the moon\nmoon"
- (lambda ()
- (read-char)
- (unread-char #\a (current-input-port))
- (pass-if "unread-char"
- (char=? (read-char) #\a))
- (read-line)
- (let ((replacenoid "chicken enchilada"))
- (unread-char #\newline (current-input-port))
- (unread-string replacenoid (current-input-port))
- (pass-if "unread-string"
- (string=? (read-line) replacenoid)))
- (pass-if "unread residue"
- (string=? (read-line) "moon")))))
+(with-input-from-string "walk on the moon\nmoon"
+ (lambda ()
+ (read-char)
+ (unread-char #\a (current-input-port))
+ (pass-if "unread-char"
+ (char=? (read-char) #\a))
+ (read-line)
+ (let ((replacenoid "chicken enchilada"))
+ (unread-char #\newline (current-input-port))
+ (unread-string replacenoid (current-input-port))
+ (pass-if "unread-string"
+ (string=? (read-line) replacenoid)))
+ (pass-if "unread residue"
+ (string=? (read-line) "moon"))))
;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
-;;; the reading end. try to read a byte: should get EAGAIN error.
-(catch-test-errors
- (let* ((p (pipe))
- (r (car p)))
- (fcntl r F_SETFL O_NONBLOCK)
- (pass-if "non-blocking-I/O"
- (catch 'system-error
- (lambda () (read-char r) #f)
- (lambda (key . args)
- (and (eq? key 'system-error)
- (= (car (list-ref args 3)) EAGAIN)))))))
+;;; the reading end. try to read a byte: should get EAGAIN or
+;;; EWOULDBLOCK error.
+(let* ((p (pipe))
+ (r (car p)))
+ (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
+ (pass-if "non-blocking-I/O"
+ (catch 'system-error
+ (lambda () (read-char r) #f)
+ (lambda (key . args)
+ (and (eq? key 'system-error)
+ (let ((errno (car (list-ref args 3))))
+ (or (= errno EAGAIN)
+ (= errno EWOULDBLOCK))))))))
\f
;;;; Pipe (popen) ports.
;;; Run a command, and read its output.
-(catch-test-errors
- (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
- (in-string (read-all pipe)))
- (close-pipe pipe)
- (pass-if "pipe: read"
- (equal? in-string "Howdy there, partner!\n"))))
+(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
+ (in-string (read-all pipe)))
+ (close-pipe pipe)
+ (pass-if "pipe: read"
+ (equal? in-string "Howdy there, partner!\n")))
;;; Run a command, send some output to it, and see if it worked.
-(catch-test-errors
- (let* ((filename (test-file))
- (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
- (display "Now Jimmy lives on a mushroom cloud\n" pipe)
- (display "Mommy, why does everybody have a bomb?\n" pipe)
- (close-pipe pipe)
- (let ((in-string (read-file filename)))
- (pass-if "pipe: write"
- (equal? in-string "Mommy, why does everybody have a bomb?\n")))
- (delete-file filename)))
+(let* ((filename (test-file))
+ (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
+ (display "Now Jimmy lives on a mushroom cloud\n" pipe)
+ (display "Mommy, why does everybody have a bomb?\n" pipe)
+ (close-pipe pipe)
+ (let ((in-string (read-file filename)))
+ (pass-if "pipe: write"
+ (equal? in-string "Mommy, why does everybody have a bomb?\n")))
+ (delete-file filename))
\f
;;;; Void ports. These are so trivial we don't test them.
(with-test-prefix "string ports"
;; Write text to a string port.
- (catch-test-errors
- (let* ((string "Howdy there, partner!")
- (in-string (call-with-output-string
- (lambda (port)
- (display string port)
- (newline port)))))
- (pass-if "display text"
- (equal? in-string (string-append string "\n")))))
+ (let* ((string "Howdy there, partner!")
+ (in-string (call-with-output-string
+ (lambda (port)
+ (display string port)
+ (newline port)))))
+ (pass-if "display text"
+ (equal? in-string (string-append string "\n"))))
;; Write an s-expression to a string port.
- (catch-test-errors
- (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
- (in-sexpr
- (call-with-input-string (call-with-output-string
- (lambda (port)
- (write sexpr port)))
- read)))
- (pass-if "write/read sexpr"
- (equal? in-sexpr sexpr)))))
+ (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
+ (in-sexpr
+ (call-with-input-string (call-with-output-string
+ (lambda (port)
+ (write sexpr port)))
+ read)))
+ (pass-if "write/read sexpr"
+ (equal? in-sexpr sexpr)))
+
+ ;; seeking and unreading from an input string.
+ (let ((text "that text didn't look random to me"))
+ (call-with-input-string text
+ (lambda (p)
+ (pass-if "input tell 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (read-char p)
+ (pass-if "input tell 1"
+ (= (seek p 0 SEEK_CUR) 1))
+ (unread-char #\x p)
+ (pass-if "input tell back to 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (pass-if "input ungetted char"
+ (char=? (read-char p) #\x))
+ (seek p 0 SEEK_END)
+ (pass-if "input seek to end"
+ (= (seek p 0 SEEK_CUR)
+ (string-length text)))
+ (unread-char #\x p)
+ (pass-if "input seek to beginning"
+ (= (seek p 0 SEEK_SET) 0))
+ (pass-if "input reread first char"
+ (char=? (read-char p)
+ (string-ref text 0))))))
+
+ ;; seeking an output string.
+ (let* ((text (string-copy "123456789"))
+ (len (string-length text))
+ (result (call-with-output-string
+ (lambda (p)
+ (pass-if "output tell 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (display text p)
+ (pass-if "output tell end"
+ (= (seek p 0 SEEK_CUR) len))
+ (pass-if "output seek to beginning"
+ (= (seek p 0 SEEK_SET) 0))
+ (write-char #\a p)
+ (seek p -1 SEEK_END)
+ (pass-if "output seek to last char"
+ (= (seek p 0 SEEK_CUR)
+ (- len 1)))
+ (write-char #\b p)))))
+ (string-set! text 0 #\a)
+ (string-set! text (- len 1) #\b)
+ (pass-if "output check"
+ (string=? text result)))
+
+ (pass-if "encoding failure leads to exception"
+ ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
+ ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((p (open-input-string "λ"))) ; raise an exception
+ #f)))
+ (lambda (key . rest)
+ #t)
+ (lambda (key . rest)
+ ;; At this point, the port-table mutex used to be still held,
+ ;; hence the deadlock. This situation would occur when trying
+ ;; to print a backtrace, for instance.
+ (input-port? (open-input-string "foo")))))
+
+ (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 "%default-port-conversion-strategy is honored"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-string
+ (lambda (p)
+ (and (eq? s (port-conversion-strategy p))
+ (begin
+ (set-port-conversion-strategy! p s)
+ (display (port-conversion-strategy p)
+ p)))))))
+ strategies)
+ (map symbol->string strategies))))
+
+ (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, error"
+ (let ((str "ĉu bone?"))
+ (catch 'encoding-error
+ (lambda ()
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1")
+ (%default-port-conversion-strategy 'error))
+ (with-output-to-string
+ (lambda ()
+ (display str))))
+ #f) ; so the test really fails here
+ (lambda (key subr message errno port chr)
+ (and (eqv? 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))
+ (eqv? (proc port) #\?)
+ (decoding-error? port (proc port))))
+ ((_ port (proc -> eof))
+ (eof-object? (proc port)))
+ ((_ port (proc -> char))
+ (eqv? (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"
+
+ ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
+ ;; occur.
+ (pass-if-exception "proc closes port" exception:wrong-type-arg
+ (call-with-output-string close-port)))
+
\f
;;;; Soft ports. No tests implemented yet.
(for-each close-port ports)
(delete-file port-loop-temp))))
- (catch-test-errors
- (with-test-prefix "newline"
- (test-line-counter
- (string-append "x\n"
- "He who receives an idea from me, receives instruction\n"
- "himself without lessening mine; as he who lights his\n"
- "taper at mine, receives light without darkening me.\n"
- " --- Thomas Jefferson\n")
- "He who receives an idea from me, receives instruction"
- 0)))
-
- (catch-test-errors
- (with-test-prefix "no newline"
- (test-line-counter
- (string-append "x\n"
- "He who receives an idea from me, receives instruction\n"
- "himself without lessening mine; as he who lights his\n"
- "taper at mine, receives light without darkening me.\n"
- " --- Thomas Jefferson\n"
- "no newline here")
- "He who receives an idea from me, receives instruction"
- 15))))
+ (with-test-prefix "newline"
+ (test-line-counter
+ (string-append "x\n"
+ "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n")
+ "He who receives an idea from me, receives instruction"
+ 0))
+
+ (with-test-prefix "no newline"
+ (test-line-counter
+ (string-append "x\n"
+ "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n"
+ "no newline here")
+ "He who receives an idea from me, receives instruction"
+ 15)))
+
+;; Test port-line and port-column for output ports
+
+(define (test-output-line-counter text final-column)
+ (with-test-prefix "port-line and port-column for output ports"
+ (let ((port (open-output-string)))
+ (pass-if "at beginning of input"
+ (and (= (port-line port) 0)
+ (= (port-column port) 0)))
+ (write-char #\x port)
+ (pass-if "after writing one character"
+ (and (= (port-line port) 0)
+ (= (port-column port) 1)))
+ (write-char #\newline port)
+ (pass-if "after writing first newline char"
+ (and (= (port-line port) 1)
+ (= (port-column port) 0)))
+ (display text port)
+ (pass-if "line count is 5 at end"
+ (= (port-line port) 5))
+ (pass-if "column is correct at end"
+ (= (port-column port) final-column)))))
+
+(test-output-line-counter
+ (string-append "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n"
+ "no newline here")
+ 15)
+
+(with-test-prefix "port-column"
+
+ (with-test-prefix "output"
+
+ (pass-if "x"
+ (let ((port (open-output-string)))
+ (display "x" port)
+ (= 1 (port-column port))))
+
+ (pass-if "\\a"
+ (let ((port (open-output-string)))
+ (display "\a" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\a"
+ (let ((port (open-output-string)))
+ (display "x\a" port)
+ (= 1 (port-column port))))
+
+ (pass-if "\\x08 backspace"
+ (let ((port (open-output-string)))
+ (display "\x08" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\x08 backspace"
+ (let ((port (open-output-string)))
+ (display "x\x08" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\n"
+ (let ((port (open-output-string)))
+ (display "\n" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\n"
+ (let ((port (open-output-string)))
+ (display "x\n" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\r"
+ (let ((port (open-output-string)))
+ (display "\r" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\r"
+ (let ((port (open-output-string)))
+ (display "x\r" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\t"
+ (let ((port (open-output-string)))
+ (display "\t" port)
+ (= 8 (port-column port))))
+
+ (pass-if "x\\t"
+ (let ((port (open-output-string)))
+ (display "x\t" port)
+ (= 8 (port-column port)))))
+
+ (with-test-prefix "input"
+
+ (pass-if "x"
+ (let ((port (open-input-string "x")))
+ (while (not (eof-object? (read-char port))))
+ (= 1 (port-column port))))
+
+ (pass-if "\\a"
+ (let ((port (open-input-string "\a")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\a"
+ (let ((port (open-input-string "x\a")))
+ (while (not (eof-object? (read-char port))))
+ (= 1 (port-column port))))
+
+ (pass-if "\\x08 backspace"
+ (let ((port (open-input-string "\x08")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\x08 backspace"
+ (let ((port (open-input-string "x\x08")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\n"
+ (let ((port (open-input-string "\n")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\n"
+ (let ((port (open-input-string "x\n")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\r"
+ (let ((port (open-input-string "\r")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\r"
+ (let ((port (open-input-string "x\r")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\t"
+ (let ((port (open-input-string "\t")))
+ (while (not (eof-object? (read-char port))))
+ (= 8 (port-column port))))
+
+ (pass-if "x\\t"
+ (let ((port (open-input-string "x\t")))
+ (while (not (eof-object? (read-char port))))
+ (= 8 (port-column port))))))
+
+(with-test-prefix "port-line"
+
+ ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
+ ;; scm_t_port actually holds a long; this restricted the range on 64-bit
+ ;; systems
+ (pass-if "set most-positive-fixnum/2"
+ (let ((n (quotient most-positive-fixnum 2))
+ (port (open-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
+ (let ((p (open-input-string "")))
+ (set-port-encoding! p "does-not-exist")
+ (read p)))
+
+ (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
+;;;
+
+(with-test-prefix "port-for-each"
+
+ ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
+ ;; its iterator func if a port was inaccessible in the last gc mark but
+ ;; the lazy sweeping has not yet reached it to remove it from the port
+ ;; table (scm_i_port_table). Provoking those gc conditions is a little
+ ;; tricky, but the following code made it happen in 1.8.2.
+ (pass-if "passing freed cell"
+ (let ((lst '()))
+ ;; clear out the heap
+ (gc) (gc) (gc)
+ ;; allocate cells so the opened ports aren't at the start of the heap
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ ;; this gc leaves the above ports unmarked, ie. inaccessible
+ (gc)
+ ;; but they're still in the port table, so this sees them
+ (port-for-each (lambda (port)
+ (set! lst (cons port lst))))
+ ;; this forces completion of the sweeping
+ (gc) (gc) (gc)
+ ;; and (if the bug is present) the cells accumulated in LST are now
+ ;; freed cells, which give #f from `port?'
+ (not (memq #f (map port? lst))))))
+
+(with-test-prefix
+ "fdes->port"
+ (pass-if "fdes->ports finds port"
+ (let ((port (open-file (test-file) "w")))
+
+ (not (not (memq port (fdes->ports (port->fdes port))))))))
+
+;;;
+;;; seek
+;;;
+
+(with-test-prefix "seek"
+
+ (with-test-prefix "file port"
+
+ (pass-if "SEEK_CUR"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port 2 SEEK_CUR)
+ (eqv? #\d (read-char port))))
+
+ (pass-if "SEEK_SET"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port 3 SEEK_SET)
+ (eqv? #\d (read-char port))))
+
+ (pass-if "SEEK_END"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port -2 SEEK_END)
+ (eqv? #\d (read-char port))))))
+
+;;;
+;;; truncate-file
+;;;
+
+(with-test-prefix "truncate-file"
+
+ (pass-if-exception "flonum file" exception:wrong-type-arg
+ (truncate-file 1.0 123))
+
+ (pass-if-exception "frac file" exception:wrong-type-arg
+ (truncate-file 7/3 123))
+
+ (with-test-prefix "filename"
+
+ (pass-if-exception "flonum length" exception:wrong-type-arg
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file) 1.0))
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file) 1)
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if-exception "shorten to current pos" exception:miscellaneous-error
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file))))
+
+ (with-test-prefix "file descriptor"
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((fd (open-fdes (test-file) O_RDWR)))
+ (truncate-file fd 1)
+ (close-fdes fd))
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if "shorten to current pos"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((fd (open-fdes (test-file) O_RDWR)))
+ (seek fd 1 SEEK_SET)
+ (truncate-file fd)
+ (close-fdes fd))
+ (eqv? 1 (stat:size (stat (test-file))))))
+
+ (with-test-prefix "file port"
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((port (open-file (test-file) "r+")))
+ (truncate-file port 1))
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if "shorten to current pos"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((port (open-file (test-file) "r+")))
+ (read-char port)
+ (truncate-file port))
+ (eqv? 1 (stat:size (stat (test-file)))))))
+
-\f
;;;; testing read-delimited and friends
(with-test-prefix "read-delimited!"
(char-ready?))))))
\f
+;;;; pending-eof behavior
+
+(with-test-prefix "pending EOF behavior"
+ ;; Make a test port that will produce the given sequence. Each
+ ;; element of 'lst' may be either a character or #f (which means EOF).
+ (define (test-soft-port . lst)
+ (make-soft-port
+ (vector (lambda (c) #f) ; write char
+ (lambda (s) #f) ; write string
+ (lambda () #f) ; flush
+ (lambda () ; read char
+ (let ((c (car lst)))
+ (set! lst (cdr lst))
+ c))
+ (lambda () #f)) ; close
+ "rw"))
+
+ (define (call-with-port p proc)
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (proc p))
+ (lambda () (close-port p))))
+
+ (define (call-with-test-file str proc)
+ (let ((filename (test-file)))
+ (dynamic-wind
+ (lambda () (call-with-output-file filename
+ (lambda (p) (display str p))))
+ (lambda () (call-with-input-file filename proc))
+ (lambda () (delete-file (test-file))))))
+
+ (pass-if "peek-char does not swallow EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (peek-char p))
+ (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (eof-object? (read-char p))
+ (char=? #\b (peek-char p))
+ (char=? #\b (read-char p))))))
+
+ (pass-if "unread clears pending EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p))))))))
+
+\f
;;;; Close current-input-port, and make sure everyone can handle it.
(with-test-prefix "closing current-input-port"
(call-with-input-string "foo" (lambda (p) p))
(lambda ()
(close-port (current-input-port))
- (pass-if name
- (signals-error? 'wrong-type-arg (procedure))))))
+ (pass-if-exception name
+ exception:wrong-type-arg
+ (procedure)))))
(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 (eqv? #\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
+
+(pass-if-equal "unget-bytevector"
+ #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
+ 1 2 3 4 251 253 254 255)
+ (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
+ (unget-bytevector port #vu8(200 201 202 203))
+ (unget-bytevector port #vu8(20 21 22 23 24))
+ (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
+ (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
+ (unget-bytevector port #vu8(10 11))
+ (get-bytevector-all port)))
+
+\f
+
+(with-test-prefix "unicode byte-order marks (BOMs)"
+
+ (define (bv-read-test* encoding bv proc)
+ (let ((port (open-bytevector-input-port bv)))
+ (set-port-encoding! port encoding)
+ (proc port)))
+
+ (define (bv-read-test encoding bv)
+ (bv-read-test* encoding bv read-string))
+
+ (define (bv-write-test* encoding proc)
+ (call-with-values
+ (lambda () (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (set-port-encoding! port encoding)
+ (proc port)
+ (get-bytevector))))
+
+ (define (bv-write-test encoding str)
+ (bv-write-test* encoding
+ (lambda (p)
+ (display str p))))
+
+ (pass-if-equal "BOM not discarded from Latin-1 stream"
+ "\xEF\xBB\xBF\x61"
+ (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from Latin-2 stream"
+ "\u010F\u0165\u017C\x61"
+ (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16BE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16LE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM not discarded from UTF-32BE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-32LE stream"
+ "\uFEFF\x61"
+ (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)))
+
+ (pass-if-equal "BOM not written to UTF-8 stream"
+ #vu8(#x61)
+ (bv-write-test "UTF-8" "a"))
+
+ (pass-if-equal "BOM not written to UTF-16BE stream"
+ #vu8(#x00 #x61)
+ (bv-write-test "UTF-16BE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-16LE stream"
+ #vu8(#x61 #x00)
+ (bv-write-test "UTF-16LE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-32BE stream"
+ #vu8(#x00 #x00 #x00 #x61)
+ (bv-write-test "UTF-32BE" "a"))
+
+ (pass-if-equal "BOM not written to UTF-32LE stream"
+ #vu8(#x61 #x00 #x00 #x00)
+ (bv-write-test "UTF-32LE" "a"))
+
+ (pass-if "Don't read from the port unless user asks to"
+ (let* ((p (make-soft-port
+ (vector
+ (lambda (c) #f) ; write char
+ (lambda (s) #f) ; write string
+ (lambda () #f) ; flush
+ (lambda () (throw 'fail)) ; read char
+ (lambda () #f))
+ "rw")))
+ (set-port-encoding! p "UTF-16")
+ (display "abc" p)
+ (set-port-encoding! p "UTF-32")
+ (display "def" p)
+ #t))
+
+ ;; TODO: test that input and output streams are independent when
+ ;; appropriate, and linked when appropriate.
+
+ (pass-if-equal "BOM discarded from start of UTF-8 stream"
+ "a"
+ (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
+ "\uFEFFa"
+ (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
+ "\uFEFFb"
+ (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
+ (lambda (p)
+ (seek p 1 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
+ "a\uFEFFb"
+ (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
+
+ (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
+ #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
+ (bv-write-test "UTF-16" "ab"))
+
+ (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
+ #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
+ (bv-write-test* "UTF-16"
+ (lambda (p)
+ (display "ab" p)
+ (set-port-encoding! p "UTF-16")
+ (display "cd" p))))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
+ "a"
+ (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
+ "\uFEFFa"
+ (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
+ "\uFEFFa"
+ (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
+ (lambda (p)
+ (seek p 2 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
+ "a\uFEFFb"
+ (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
+ "a"
+ (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
+ "\uFEFFa"
+ (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
+ "a"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
+ "\uFEFFa"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)))
+
+ (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
+ "\uFEFFa"
+ (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x61)
+ (lambda (p)
+ (seek p 4 SEEK_SET)
+ (read-string p))))
+
+ (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-16")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
+ "ab"
+ (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-16")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-32")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
+ "ab"
+ (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #xFF #xFE #x00 #x00
+ #x62 #x00 #x00 #x00)
+ (lambda (p)
+ (let ((a (read-char p)))
+ (set-port-encoding! p "UTF-32")
+ (string a (read-char p))))))
+
+ (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
+ "a\uFEFFb"
+ (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
+ "a"
+ (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)))
+
+ (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
+ '(#\a "a")
+ (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00)
+ (lambda (p)
+ (let ((c (read-char p)))
+ (seek p 0 SEEK_SET)
+ (let ((s (read-string p)))
+ (list c s))))))
+
+ (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
+ "\uFEFFa"
+ (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+ #xFF #xFE #x00 #x00
+ #x61 #x00 #x00 #x00))))
+
+\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-equal "absolute file name & empty %load-path entry" "/dev/null"
+ ;; 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.
+ (with-load-path (cons "" (delete "/" %load-path))
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null")))))
+
+ (pass-if-equal "relative canonicalization with /" "dev/null"
+ (with-load-path (cons "/" %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null")))))
+
+ (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
+ ;; If an entry in %LOAD-PATH is not canonical, then
+ ;; `scm_i_relativize_path' is unable to do its job.
+ (if (equal? (map canonicalize-path %load-path) %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename
+ (open-input-file (%search-load-path "ice-9/q.scm"))))
+ (throw 'unresolved)))
+
+ (pass-if-equal "absolute canonicalization from ice-9"
+ (canonicalize-path
+ (string-append (assoc-ref %guile-build-info 'top_srcdir)
+ "/module/ice-9/q.scm"))
+ (with-fluids ((%file-port-name-canonicalization 'absolute))
+ (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
+
+(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: