mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
856d318a9f
Conflicts: benchmark-suite/benchmarks/ports.bm libguile/async.h libguile/bytevectors.c libguile/foreign.c libguile/gsubr.c libguile/srfi-1.c libguile/vm-engine.h libguile/vm-i-scheme.c module/Makefile.am module/language/tree-il/analyze.scm module/language/tree-il/peval.scm module/scripts/compile.scm module/scripts/disassemble.scm test-suite/tests/asm-to-bytecode.test test-suite/tests/peval.test test-suite/tests/rdelim.test
1876 lines
67 KiB
Scheme
1876 lines
67 KiB
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, 2009, 2010,
|
||
;;;; 2011, 2012, 2013, 2014 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 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
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; 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
|
||
|
||
(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)
|
||
(data-file-name "ports-test.tmp"))
|
||
|
||
|
||
;;;; 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 '()))
|
||
(let ((char (read-char port)))
|
||
(if (eof-object? char)
|
||
(list->string (reverse! chars))
|
||
(loop (cons char chars))))))
|
||
|
||
(define (read-file filename)
|
||
(let* ((port (open-input-file filename))
|
||
(string (read-all port)))
|
||
(close-port port)
|
||
string))
|
||
|
||
|
||
|
||
(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)))))
|
||
|
||
)
|
||
|
||
|
||
;;;; Normal file ports.
|
||
|
||
;;; Write out an s-expression, and read it back.
|
||
(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.
|
||
(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.
|
||
(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.
|
||
(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.
|
||
(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.
|
||
(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
|
||
(array->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
|
||
(array->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.
|
||
(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 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))))))))
|
||
|
||
|
||
;;;; Pipe (popen) ports.
|
||
|
||
;;; Run a command, and read its output.
|
||
(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.
|
||
(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))
|
||
|
||
(pass-if-equal "pipe, fdopen, and _IOLBF"
|
||
"foo\nbar\n"
|
||
(let ((in+out (pipe))
|
||
(pid (primitive-fork)))
|
||
(if (zero? pid)
|
||
(dynamic-wind
|
||
(const #t)
|
||
(lambda ()
|
||
(close-port (car in+out))
|
||
(let ((port (cdr in+out)))
|
||
(setvbuf port _IOLBF )
|
||
;; Strings containing '\n' or should be flushed; others
|
||
;; should be kept in PORT's buffer.
|
||
(display "foo\n" port)
|
||
(display "bar\n" port)
|
||
(display "this will be kept in PORT's buffer" port)))
|
||
(lambda ()
|
||
(primitive-_exit 0)))
|
||
(begin
|
||
(close-port (cdr in+out))
|
||
(let ((str (read-all (car in+out))))
|
||
(waitpid pid)
|
||
str)))))
|
||
|
||
|
||
;;;; Void ports. These are so trivial we don't test them.
|
||
|
||
|
||
;;;; String ports.
|
||
|
||
(with-test-prefix "string ports"
|
||
|
||
;; Write text to a string port.
|
||
(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.
|
||
(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 "%default-port-encoding is ignored"
|
||
(let ((str "ĉu bone?"))
|
||
;; Latin-1 cannot represent ‘ĉ’.
|
||
(with-fluids ((%default-port-encoding "ISO-8859-1"))
|
||
(string=? (call-with-output-string
|
||
(lambda (p)
|
||
(set-port-conversion-strategy! p 'substitute)
|
||
(display str p)))
|
||
"ĉu bone?"))))
|
||
|
||
(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")
|
||
(encoding "ISO-8859-1"))
|
||
(equal? str
|
||
(call-with-output-string
|
||
(lambda (p)
|
||
(set-port-encoding! p encoding)
|
||
(display str p))))))
|
||
|
||
(pass-if "suitable encoding [latin-3]"
|
||
(let ((str "ĉu bone?")
|
||
(encoding "ISO-8859-3"))
|
||
(equal? str
|
||
(call-with-output-string
|
||
(lambda (p)
|
||
(set-port-encoding! p encoding)
|
||
(display str p))))))
|
||
|
||
(pass-if "wrong encoding, error"
|
||
(let ((str "ĉu bone?"))
|
||
(catch 'encoding-error
|
||
(lambda ()
|
||
(with-fluids ((%default-port-conversion-strategy 'error))
|
||
(call-with-output-string
|
||
(lambda (p)
|
||
;; Latin-1 cannot represent ‘ĉ’.
|
||
(set-port-encoding! p "ISO-8859-1")
|
||
(display str p))))
|
||
#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?"))
|
||
(string=? (call-with-output-string
|
||
(lambda (p)
|
||
(set-port-encoding! p "ISO-8859-1")
|
||
(set-port-conversion-strategy! p 'substitute)
|
||
(display str p)))
|
||
"?u bone?")))
|
||
|
||
(pass-if "wrong encoding, escape"
|
||
(let ((str "ĉu bone?"))
|
||
(string=? (call-with-output-string
|
||
(lambda (p)
|
||
(set-port-encoding! p "ISO-8859-1")
|
||
(set-port-conversion-strategy! p 'escape)
|
||
(display str p)))
|
||
"\\u0109u bone?")))
|
||
|
||
(pass-if "peek-char"
|
||
(let ((p (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)))
|
||
|
||
|
||
|
||
;;;; Soft ports. No tests implemented yet.
|
||
|
||
|
||
;;;; Generic operations across all port types.
|
||
|
||
(let ((port-loop-temp (test-file)))
|
||
|
||
;; Return a list of input ports that all return the same text.
|
||
;; We map tests over this list.
|
||
(define (input-port-list text)
|
||
|
||
;; Create a text file some of the ports will use.
|
||
(let ((out-port (open-output-file port-loop-temp)))
|
||
(display text out-port)
|
||
(close-port out-port))
|
||
|
||
(list (open-input-file port-loop-temp)
|
||
(open-input-pipe (string-append "cat " port-loop-temp))
|
||
(call-with-input-string text (lambda (x) x))
|
||
;; We don't test soft ports at the moment.
|
||
))
|
||
|
||
(define port-list-names '("file" "pipe" "string"))
|
||
|
||
;; Test the line counter.
|
||
(define (test-line-counter text second-line final-column)
|
||
(with-test-prefix "line counter"
|
||
(let ((ports (input-port-list text)))
|
||
(for-each
|
||
(lambda (port port-name)
|
||
(with-test-prefix port-name
|
||
(pass-if "at beginning of input"
|
||
(= (port-line port) 0))
|
||
(pass-if "read first character"
|
||
(eqv? (read-char port) #\x))
|
||
(pass-if "after reading one character"
|
||
(= (port-line port) 0))
|
||
(pass-if "read first newline"
|
||
(eqv? (read-char port) #\newline))
|
||
(pass-if "after reading first newline char"
|
||
(= (port-line port) 1))
|
||
(pass-if "second line read correctly"
|
||
(equal? (read-line port) second-line))
|
||
(pass-if "read-line increments line number"
|
||
(= (port-line port) 2))
|
||
(pass-if "read-line returns EOF"
|
||
(let loop ((i 0))
|
||
(cond
|
||
((eof-object? (read-line port)) #t)
|
||
((> i 20) #f)
|
||
(else (loop (+ i 1))))))
|
||
(pass-if "line count is 5 at EOF"
|
||
(= (port-line port) 5))
|
||
(pass-if "column is correct at EOF"
|
||
(= (port-column port) final-column))))
|
||
ports port-list-names)
|
||
(for-each close-port ports)
|
||
(delete-file port-loop-temp))))
|
||
|
||
(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)))
|
||
|
||
(let ((filename (test-file)))
|
||
(with-output-to-file filename (lambda () (write 'test)))
|
||
|
||
(pass-if-exception "%default-port-encoding, wrong encoding"
|
||
exception:miscellaneous-error
|
||
(read (with-fluids ((%default-port-encoding "does-not-exist"))
|
||
(open-input-file filename))))
|
||
|
||
(delete-file filename)))
|
||
|
||
;;;
|
||
;;; 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"))
|
||
(res (not (not (memq port (fdes->ports (port->fdes port)))))))
|
||
(close-port port)
|
||
res)))
|
||
|
||
;;;
|
||
;;; 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)
|
||
(let ((res (eqv? #\d (read-char port))))
|
||
(close-port port)
|
||
res)))
|
||
|
||
(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)
|
||
(let ((res (eqv? #\d (read-char port))))
|
||
(close-port port)
|
||
res)))
|
||
|
||
(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)
|
||
(let ((res (eqv? #\d (read-char port))))
|
||
(close-port port)
|
||
res)))))
|
||
|
||
;;;
|
||
;;; 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)
|
||
(close-port port))
|
||
(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)
|
||
(close-port port))
|
||
(eqv? 1 (stat:size (stat (test-file)))))))
|
||
|
||
|
||
;;;; testing read-delimited and friends
|
||
|
||
(with-test-prefix "read-delimited!"
|
||
(let ((c (make-string 20 #\!)))
|
||
(call-with-input-string
|
||
"defdef\nghighi\n"
|
||
(lambda (port)
|
||
|
||
(read-delimited! "\n" c port 'concat)
|
||
(pass-if "read-delimited! reads a first line"
|
||
(string=? c "defdef\n!!!!!!!!!!!!!"))
|
||
|
||
(read-delimited! "\n" c port 'concat 3)
|
||
(pass-if "read-delimited! reads a first line"
|
||
(string=? c "defghighi\n!!!!!!!!!!"))))))
|
||
|
||
|
||
;;;; char-ready?
|
||
|
||
(call-with-input-string
|
||
"howdy"
|
||
(lambda (port)
|
||
(pass-if "char-ready? returns true on string port"
|
||
(char-ready? port))))
|
||
|
||
;;; This segfaults on some versions of Guile. We really should run
|
||
;;; the tests in a subprocess...
|
||
|
||
(call-with-input-string
|
||
"howdy"
|
||
(lambda (port)
|
||
(with-input-from-port
|
||
port
|
||
(lambda ()
|
||
(pass-if "char-ready? returns true on string port as default port"
|
||
(char-ready?))))))
|
||
|
||
|
||
;;;; 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))))))))
|
||
|
||
|
||
;;;; Close current-input-port, and make sure everyone can handle it.
|
||
|
||
(with-test-prefix "closing current-input-port"
|
||
(for-each (lambda (procedure name)
|
||
(with-input-from-port
|
||
(call-with-input-string "foo" (lambda (p) p))
|
||
(lambda ()
|
||
(close-port (current-input-port))
|
||
(pass-if-exception name
|
||
exception:wrong-type-arg
|
||
(procedure)))))
|
||
(list read read-char read-line)
|
||
'("read" "read-char" "read-line")))
|
||
|
||
|
||
|
||
(with-test-prefix "setvbuf"
|
||
|
||
(pass-if-exception "closed port"
|
||
exception:wrong-type-arg
|
||
(let ((port (open-input-file "/dev/null")))
|
||
(close-port port)
|
||
(setvbuf port _IOFBF)))
|
||
|
||
(pass-if-exception "string port"
|
||
exception:wrong-type-arg
|
||
(let ((port (open-input-string "Hey!")))
|
||
(close-port port)
|
||
(setvbuf port _IOFBF)))
|
||
|
||
(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*)))))))))))
|
||
|
||
|
||
|
||
(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)))
|
||
|
||
|
||
|
||
(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))))
|
||
|
||
|
||
|
||
(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"))))))
|
||
|
||
(with-test-prefix "file name separators"
|
||
|
||
(pass-if "no backslash separators in Windows file names"
|
||
;; In Guile 2.0.11 and earlier, %load-path on Windows could
|
||
;; include file names with backslashes, and `getcwd' on Windows
|
||
;; would always return a directory name with backslashes.
|
||
(or (not (file-name-separator? #\\))
|
||
(with-load-path (cons (getcwd) %load-path)
|
||
(not (string-index (%search-load-path (basename (test-file)))
|
||
#\\))))))
|
||
|
||
(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:
|