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
973 lines
38 KiB
Text
973 lines
38 KiB
Text
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
|
||
;;;; 2014 Free Software Foundation, Inc.
|
||
;;;; Ludovic Courtès
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; 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-io-ports)
|
||
#:use-module (test-suite lib)
|
||
#:use-module (test-suite guile-test)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-11)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (rnrs io ports)
|
||
#:use-module (rnrs io simple)
|
||
#:use-module (rnrs exceptions)
|
||
#:use-module (rnrs bytevectors))
|
||
|
||
(define-syntax pass-if-condition
|
||
(syntax-rules ()
|
||
((_ name predicate body0 body ...)
|
||
(let ((cookie (list 'cookie)))
|
||
(pass-if name
|
||
(eq? cookie (guard (c ((predicate c) cookie))
|
||
body0 body ...)))))))
|
||
|
||
(define (test-file)
|
||
(data-file-name "ports-test.tmp"))
|
||
|
||
;; A input/output port that swallows all output, and produces just
|
||
;; spaces on input. Reading and writing beyond `failure-position'
|
||
;; produces `system-error' exceptions. Used for testing exception
|
||
;; behavior.
|
||
(define* (make-failing-port #:optional (failure-position 0))
|
||
(define (maybe-fail index errno)
|
||
(if (> index failure-position)
|
||
(scm-error 'system-error
|
||
'failing-port
|
||
"I/O beyond failure position" '()
|
||
(list errno))))
|
||
(let ((read-index 0)
|
||
(write-index 0))
|
||
(define (write-char chr)
|
||
(set! write-index (+ 1 write-index))
|
||
(maybe-fail write-index ENOSPC))
|
||
(make-soft-port
|
||
(vector write-char
|
||
(lambda (str) ;; write-string
|
||
(for-each write-char (string->list str)))
|
||
(lambda () #t) ;; flush-output
|
||
(lambda () ;; read-char
|
||
(set! read-index (+ read-index 1))
|
||
(maybe-fail read-index EIO)
|
||
#\space)
|
||
(lambda () #t)) ;; close-port
|
||
"rw")))
|
||
|
||
(define (call-with-bytevector-output-port/transcoded transcoder receiver)
|
||
(call-with-bytevector-output-port
|
||
(lambda (bv-port)
|
||
(call-with-port (transcoded-port bv-port transcoder)
|
||
receiver))))
|
||
|
||
|
||
(with-test-prefix "7.2.5 End-of-File Object"
|
||
|
||
(pass-if "eof-object"
|
||
(and (eqv? (eof-object) (eof-object))
|
||
(eq? (eof-object) (eof-object))))
|
||
|
||
(pass-if "port-eof?"
|
||
(port-eof? (open-input-string ""))))
|
||
|
||
|
||
(with-test-prefix "7.2.8 Binary Input"
|
||
|
||
(pass-if "get-u8"
|
||
(let ((port (open-input-string "A")))
|
||
(and (= (char->integer #\A) (get-u8 port))
|
||
(eof-object? (get-u8 port)))))
|
||
|
||
(pass-if "lookahead-u8"
|
||
(let ((port (open-input-string "A")))
|
||
(and (= (char->integer #\A) (lookahead-u8 port))
|
||
(= (char->integer #\A) (lookahead-u8 port))
|
||
(= (char->integer #\A) (get-u8 port))
|
||
(eof-object? (get-u8 port)))))
|
||
|
||
(pass-if "lookahead-u8 non-ASCII"
|
||
(let ((port (open-input-string "λ")))
|
||
(and (= 206 (lookahead-u8 port))
|
||
(= 206 (lookahead-u8 port))
|
||
(= 206 (get-u8 port))
|
||
(= 187 (lookahead-u8 port))
|
||
(= 187 (lookahead-u8 port))
|
||
(= 187 (get-u8 port))
|
||
(eof-object? (lookahead-u8 port))
|
||
(eof-object? (get-u8 port)))))
|
||
|
||
(pass-if "lookahead-u8: result is unsigned"
|
||
;; Bug #31081.
|
||
(let ((port (open-bytevector-input-port #vu8(255))))
|
||
(= (lookahead-u8 port) 255)))
|
||
|
||
(pass-if "get-bytevector-n [short]"
|
||
(let* ((port (open-input-string "GNU Guile"))
|
||
(bv (get-bytevector-n port 4)))
|
||
(and (bytevector? bv)
|
||
(equal? (bytevector->u8-list bv)
|
||
(map char->integer (string->list "GNU "))))))
|
||
|
||
(pass-if "get-bytevector-n [long]"
|
||
(let* ((port (open-input-string "GNU Guile"))
|
||
(bv (get-bytevector-n port 256)))
|
||
(and (bytevector? bv)
|
||
(equal? (bytevector->u8-list bv)
|
||
(map char->integer (string->list "GNU Guile"))))))
|
||
|
||
(pass-if-exception "get-bytevector-n with closed port"
|
||
exception:wrong-type-arg
|
||
|
||
(let ((port (%make-void-port "r")))
|
||
|
||
(close-port port)
|
||
(get-bytevector-n port 3)))
|
||
|
||
(let ((expected (make-bytevector 20 (char->integer #\a))))
|
||
(pass-if-equal "http://bugs.gnu.org/17466"
|
||
;; <http://bugs.gnu.org/17466> is about a memory corruption
|
||
;; whereas bytevector shrunk in 'get-bytevector-n' would keep
|
||
;; referring to the previous (larger) bytevector.
|
||
expected
|
||
(let loop ((count 50))
|
||
(if (zero? count)
|
||
expected
|
||
(let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa"
|
||
(lambda (port)
|
||
(get-bytevector-n port 4096)))))
|
||
;; Cause the 4 KiB bytevector initially created by
|
||
;; 'get-bytevector-n' to be reclaimed.
|
||
(make-bytevector 4096)
|
||
|
||
(if (equal? bv expected)
|
||
(loop (- count 1))
|
||
bv))))))
|
||
|
||
(pass-if "get-bytevector-n! [short]"
|
||
(let* ((port (open-input-string "GNU Guile"))
|
||
(bv (make-bytevector 4))
|
||
(read (get-bytevector-n! port bv 0 4)))
|
||
(and (equal? read 4)
|
||
(equal? (bytevector->u8-list bv)
|
||
(map char->integer (string->list "GNU "))))))
|
||
|
||
(pass-if "get-bytevector-n! [long]"
|
||
(let* ((str "GNU Guile")
|
||
(port (open-input-string str))
|
||
(bv (make-bytevector 256))
|
||
(read (get-bytevector-n! port bv 0 256)))
|
||
(and (equal? read (string-length str))
|
||
(equal? (map (lambda (i)
|
||
(bytevector-u8-ref bv i))
|
||
(iota read))
|
||
(map char->integer (string->list str))))))
|
||
|
||
(pass-if "get-bytevector-some [simple]"
|
||
(let* ((str "GNU Guile")
|
||
(port (open-input-string str))
|
||
(bv (get-bytevector-some port)))
|
||
(and (bytevector? bv)
|
||
(equal? (bytevector->u8-list bv)
|
||
(map char->integer (string->list str))))))
|
||
|
||
(pass-if "get-bytevector-all"
|
||
(let* ((str "GNU Guile")
|
||
(index 0)
|
||
(port (make-soft-port
|
||
(vector #f #f #f
|
||
(lambda ()
|
||
(if (>= index (string-length str))
|
||
(eof-object)
|
||
(let ((c (string-ref str index)))
|
||
(set! index (+ index 1))
|
||
c)))
|
||
(lambda () #t)
|
||
(let ((cont? #f))
|
||
(lambda ()
|
||
;; Number of readily available octets: falls to
|
||
;; zero after 4 octets have been read and then
|
||
;; starts again.
|
||
(let ((a (if cont?
|
||
(- (string-length str) index)
|
||
(- 4 (modulo index 5)))))
|
||
(if (= 0 a) (set! cont? #t))
|
||
a))))
|
||
"r"))
|
||
(bv (get-bytevector-all port)))
|
||
(and (bytevector? bv)
|
||
(= index (string-length str))
|
||
(= (bytevector-length bv) (string-length str))
|
||
(equal? (bytevector->u8-list bv)
|
||
(map char->integer (string->list str)))))))
|
||
|
||
|
||
(define (make-soft-output-port)
|
||
(let* ((bv (make-bytevector 1024))
|
||
(read-index 0)
|
||
(write-index 0)
|
||
(write-char (lambda (chr)
|
||
(bytevector-u8-set! bv write-index
|
||
(char->integer chr))
|
||
(set! write-index (+ 1 write-index)))))
|
||
(make-soft-port
|
||
(vector write-char
|
||
(lambda (str) ;; write-string
|
||
(for-each write-char (string->list str)))
|
||
(lambda () #t) ;; flush-output
|
||
(lambda () ;; read-char
|
||
(if (>= read-index (bytevector-length bv))
|
||
(eof-object)
|
||
(let ((c (bytevector-u8-ref bv read-index)))
|
||
(set! read-index (+ read-index 1))
|
||
(integer->char c))))
|
||
(lambda () #t)) ;; close-port
|
||
"rw")))
|
||
|
||
(with-test-prefix "7.2.11 Binary Output"
|
||
|
||
(pass-if "put-u8"
|
||
(let ((port (make-soft-output-port)))
|
||
(put-u8 port 77)
|
||
(equal? (get-u8 port) 77)))
|
||
|
||
;; Note: The `put-bytevector' tests below require a Latin-1 locale so
|
||
;; that the `scm_from_locale_stringn' call in `sf_write' will let all
|
||
;; the bytes through, unmodified. This is hacky, but we can't use
|
||
;; "custom binary output ports" here because they're only tested
|
||
;; later.
|
||
|
||
(pass-if "put-bytevector [2 args]"
|
||
(with-latin1-locale
|
||
(let ((port (make-soft-output-port))
|
||
(bv (make-bytevector 256)))
|
||
(put-bytevector port bv)
|
||
(equal? (bytevector->u8-list bv)
|
||
(bytevector->u8-list
|
||
(get-bytevector-n port (bytevector-length bv)))))))
|
||
|
||
(pass-if "put-bytevector [3 args]"
|
||
(with-latin1-locale
|
||
(let ((port (make-soft-output-port))
|
||
(bv (make-bytevector 256))
|
||
(start 10))
|
||
(put-bytevector port bv start)
|
||
(equal? (drop (bytevector->u8-list bv) start)
|
||
(bytevector->u8-list
|
||
(get-bytevector-n port (- (bytevector-length bv) start)))))))
|
||
|
||
(pass-if "put-bytevector [4 args]"
|
||
(with-latin1-locale
|
||
(let ((port (make-soft-output-port))
|
||
(bv (make-bytevector 256))
|
||
(start 10)
|
||
(count 77))
|
||
(put-bytevector port bv start count)
|
||
(equal? (take (drop (bytevector->u8-list bv) start) count)
|
||
(bytevector->u8-list
|
||
(get-bytevector-n port count))))))
|
||
|
||
(pass-if-exception "put-bytevector with closed port"
|
||
exception:wrong-type-arg
|
||
|
||
(let* ((bv (make-bytevector 4))
|
||
(port (%make-void-port "w")))
|
||
|
||
(close-port port)
|
||
(put-bytevector port bv)))
|
||
|
||
(pass-if "put-bytevector with UTF-16 string port"
|
||
(let* ((str "hello, world")
|
||
(bv (string->utf16 str)))
|
||
(equal? str
|
||
(call-with-output-string
|
||
(lambda (port)
|
||
(set-port-encoding! port "UTF-16BE")
|
||
(put-bytevector port bv))))))
|
||
|
||
(pass-if "put-bytevector with wrong-encoding string port"
|
||
(let* ((str "hello, world")
|
||
(bv (string->utf16 str)))
|
||
(catch 'decoding-error
|
||
(lambda ()
|
||
(with-fluids ((%default-port-conversion-strategy 'error))
|
||
(call-with-output-string
|
||
(lambda (port)
|
||
(set-port-encoding! port "UTF-32")
|
||
(put-bytevector port bv)))
|
||
#f)) ; fail if we reach this point
|
||
(lambda (key subr message errno port)
|
||
(string? (strerror errno)))))))
|
||
|
||
|
||
(define (test-input-file-opener open filename)
|
||
(let ((contents (string->utf8 "GNU λ")))
|
||
;; Create file
|
||
(call-with-output-file filename
|
||
(lambda (port) (put-bytevector port contents)))
|
||
|
||
(pass-if "opens binary input port with correct contents"
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(call-with-port (open-file-input-port filename)
|
||
(lambda (port)
|
||
(and (binary-port? port)
|
||
(input-port? port)
|
||
(bytevector=? contents (get-bytevector-all port))))))))
|
||
|
||
(delete-file filename))
|
||
|
||
(with-test-prefix "7.2.7 Input Ports"
|
||
|
||
(with-test-prefix "open-file-input-port"
|
||
(test-input-file-opener open-file-input-port (test-file)))
|
||
|
||
;; This section appears here so that it can use the binary input
|
||
;; primitives.
|
||
|
||
(pass-if "open-bytevector-input-port [1 arg]"
|
||
(let* ((str "Hello Port!")
|
||
(bv (u8-list->bytevector (map char->integer
|
||
(string->list str))))
|
||
(port (open-bytevector-input-port bv))
|
||
(read-to-string
|
||
(lambda (port)
|
||
(let loop ((chr (read-char port))
|
||
(result '()))
|
||
(if (eof-object? chr)
|
||
(apply string (reverse! result))
|
||
(loop (read-char port)
|
||
(cons chr result)))))))
|
||
|
||
(equal? (read-to-string port) str)))
|
||
|
||
(pass-if "bytevector-input-port is binary"
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
|
||
|
||
(pass-if-exception "bytevector-input-port is read-only"
|
||
exception:wrong-type-arg
|
||
|
||
(let* ((str "Hello Port!")
|
||
(bv (u8-list->bytevector (map char->integer
|
||
(string->list str))))
|
||
(port (open-bytevector-input-port bv #f)))
|
||
|
||
(write "hello" port)))
|
||
|
||
(pass-if "bytevector input port supports seeking"
|
||
(let* ((str "Hello Port!")
|
||
(bv (u8-list->bytevector (map char->integer
|
||
(string->list str))))
|
||
(port (open-bytevector-input-port bv #f)))
|
||
|
||
(and (port-has-port-position? port)
|
||
(= 0 (port-position port))
|
||
(port-has-set-port-position!? port)
|
||
(begin
|
||
(set-port-position! port 6)
|
||
(= 6 (port-position port)))
|
||
(bytevector=? (get-bytevector-all port)
|
||
(u8-list->bytevector
|
||
(map char->integer (string->list "Port!")))))))
|
||
|
||
(pass-if "bytevector input port can seek to very end"
|
||
(let ((empty (open-bytevector-input-port '#vu8()))
|
||
(not-empty (open-bytevector-input-port '#vu8(1 2 3))))
|
||
(and (begin (set-port-position! empty (port-position empty))
|
||
(= 0 (port-position empty)))
|
||
(begin (get-bytevector-n not-empty 3)
|
||
(set-port-position! not-empty (port-position not-empty))
|
||
(= 3 (port-position not-empty))))))
|
||
|
||
(pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
|
||
exception:wrong-num-args
|
||
|
||
;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
|
||
;; optional.
|
||
(make-custom-binary-input-port "port" (lambda args #t)))
|
||
|
||
(pass-if "make-custom-binary-input-port"
|
||
(let* ((source (make-bytevector 7777))
|
||
(read! (let ((pos 0)
|
||
(len (bytevector-length source)))
|
||
(lambda (bv start count)
|
||
(let ((amount (min count (- len pos))))
|
||
(if (> amount 0)
|
||
(bytevector-copy! source pos
|
||
bv start amount))
|
||
(set! pos (+ pos amount))
|
||
amount))))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
|
||
(and (binary-port? port)
|
||
(input-port? port)
|
||
(bytevector=? (get-bytevector-all port) source))))
|
||
|
||
(pass-if "custom binary input port does not support `port-position'"
|
||
(let* ((str "Hello Port!")
|
||
(source (open-bytevector-input-port
|
||
(u8-list->bytevector
|
||
(map char->integer (string->list str)))))
|
||
(read! (lambda (bv start count)
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
(not (or (port-has-port-position? port)
|
||
(port-has-set-port-position!? port)))))
|
||
|
||
(pass-if-exception "custom binary input port 'read!' returns too much"
|
||
exception:out-of-range
|
||
;; In Guile <= 2.0.9 this would segfault.
|
||
(let* ((read! (lambda (bv start count)
|
||
(+ count 4242)))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
(get-bytevector-all port)))
|
||
|
||
(pass-if-equal "custom binary input port supports `port-position', \
|
||
not `set-port-position!'"
|
||
42
|
||
(let ((port (make-custom-binary-input-port "the port" (const 0)
|
||
(const 42) #f #f)))
|
||
(and (port-has-port-position? port)
|
||
(not (port-has-set-port-position!? port))
|
||
(port-position port))))
|
||
|
||
(pass-if "custom binary input port supports `port-position'"
|
||
(let* ((str "Hello Port!")
|
||
(source (open-bytevector-input-port
|
||
(u8-list->bytevector
|
||
(map char->integer (string->list str)))))
|
||
(read! (lambda (bv start count)
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(get-pos (lambda ()
|
||
(port-position source)))
|
||
(set-pos! (lambda (pos)
|
||
(set-port-position! source pos)))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
get-pos set-pos! #f)))
|
||
|
||
(and (port-has-port-position? port)
|
||
(= 0 (port-position port))
|
||
(port-has-set-port-position!? port)
|
||
(begin
|
||
(set-port-position! port 6)
|
||
(= 6 (port-position port)))
|
||
(bytevector=? (get-bytevector-all port)
|
||
(u8-list->bytevector
|
||
(map char->integer (string->list "Port!")))))))
|
||
|
||
(pass-if-equal "custom binary input port buffered partial reads"
|
||
"Hello Port!"
|
||
;; Check what happens when READ! returns less than COUNT bytes.
|
||
(let* ((src (string->utf8 "Hello Port!"))
|
||
(chunks '(2 4 5)) ; provide 2 bytes, then 4, etc.
|
||
(offset 0)
|
||
(read! (lambda (bv start count)
|
||
(match chunks
|
||
((count rest ...)
|
||
(bytevector-copy! src offset bv start count)
|
||
(set! chunks rest)
|
||
(set! offset (+ offset count))
|
||
count)
|
||
(()
|
||
0))))
|
||
(port (make-custom-binary-input-port "the port"
|
||
read! #f #f #f)))
|
||
(get-string-all port)))
|
||
|
||
(pass-if-equal "custom binary input port unbuffered & 'port-position'"
|
||
'(0 2 5 11)
|
||
;; Check that the value returned by 'port-position' is correct, and
|
||
;; that each 'port-position' call leads one call to the
|
||
;; 'get-position' method.
|
||
(let* ((str "Hello Port!")
|
||
(output (make-bytevector (string-length str)))
|
||
(source (with-fluids ((%default-port-encoding "UTF-8"))
|
||
(open-string-input-port str)))
|
||
(read! (lambda (bv start count)
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(pos '())
|
||
(get-pos (lambda ()
|
||
(let ((p (port-position source)))
|
||
(set! pos (cons p pos))
|
||
p)))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
get-pos #f #f)))
|
||
(setvbuf port _IONBF)
|
||
(and (= 0 (port-position port))
|
||
(begin
|
||
(get-bytevector-n! port output 0 2)
|
||
(= 2 (port-position port)))
|
||
(begin
|
||
(get-bytevector-n! port output 2 3)
|
||
(= 5 (port-position port)))
|
||
(let ((bv (string->utf8 (get-string-all port))))
|
||
(bytevector-copy! bv 0 output 5 (bytevector-length bv))
|
||
(= (string-length str) (port-position port)))
|
||
(bytevector=? output (string->utf8 str))
|
||
(reverse pos))))
|
||
|
||
(pass-if-equal "custom binary input port unbuffered & 'read!' calls"
|
||
`((2 "He") (3 "llo") (42 " Port!"))
|
||
(let* ((str "Hello Port!")
|
||
(source (with-fluids ((%default-port-encoding "UTF-8"))
|
||
(open-string-input-port str)))
|
||
(reads '())
|
||
(read! (lambda (bv start count)
|
||
(set! reads (cons count reads))
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
|
||
(setvbuf port _IONBF)
|
||
(let ((ret (list (get-bytevector-n port 2)
|
||
(get-bytevector-n port 3)
|
||
(get-bytevector-n port 42))))
|
||
(zip (reverse reads)
|
||
(map (lambda (obj)
|
||
(if (bytevector? obj)
|
||
(utf8->string obj)
|
||
obj))
|
||
ret)))))
|
||
|
||
(pass-if-equal "custom binary input port, unbuffered then buffered"
|
||
`((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
|
||
(777 ,(eof-object)))
|
||
(let* ((str "Lorem ipsum dolor sit amet, consectetur…")
|
||
(source (with-fluids ((%default-port-encoding "UTF-8"))
|
||
(open-string-input-port str)))
|
||
(reads '())
|
||
(read! (lambda (bv start count)
|
||
(set! reads (cons count reads))
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
|
||
(setvbuf port _IONBF)
|
||
(let ((ret (list (get-bytevector-n port 6)
|
||
(get-bytevector-n port 12)
|
||
(begin
|
||
(setvbuf port _IOFBF 777)
|
||
(get-bytevector-n port 42))
|
||
(get-bytevector-n port 42))))
|
||
(zip (reverse reads)
|
||
(map (lambda (obj)
|
||
(if (bytevector? obj)
|
||
(utf8->string obj)
|
||
obj))
|
||
ret)))))
|
||
|
||
(pass-if-equal "custom binary input port, buffered then unbuffered"
|
||
`((18
|
||
42 14 ; scm_c_read tries to fill the 42-byte buffer
|
||
42)
|
||
("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
|
||
(let* ((str "Lorem ipsum dolor sit amet, consectetur bla…")
|
||
(source (with-fluids ((%default-port-encoding "UTF-8"))
|
||
(open-string-input-port str)))
|
||
(reads '())
|
||
(read! (lambda (bv start count)
|
||
(set! reads (cons count reads))
|
||
(let ((r (get-bytevector-n! source bv start count)))
|
||
(if (eof-object? r)
|
||
0
|
||
r))))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
#f #f #f)))
|
||
|
||
(setvbuf port _IOFBF 18)
|
||
(let ((ret (list (get-bytevector-n port 6)
|
||
(get-bytevector-n port 12)
|
||
(begin
|
||
(setvbuf port _IONBF)
|
||
(get-bytevector-n port 42))
|
||
(get-bytevector-n port 42))))
|
||
(list (reverse reads)
|
||
(map (lambda (obj)
|
||
(if (bytevector? obj)
|
||
(utf8->string obj)
|
||
obj))
|
||
ret)))))
|
||
|
||
(pass-if "custom binary input port `close-proc' is called"
|
||
(let* ((closed? #f)
|
||
(read! (lambda (bv start count) 0))
|
||
(get-pos (lambda () 0))
|
||
(set-pos! (lambda (pos) #f))
|
||
(close! (lambda () (set! closed? #t)))
|
||
(port (make-custom-binary-input-port "the port" read!
|
||
get-pos set-pos!
|
||
close!)))
|
||
|
||
(close-port port)
|
||
(gc) ; Test for marking a closed port.
|
||
closed?))
|
||
|
||
(pass-if "standard-input-port is binary"
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(binary-port? (standard-input-port)))))
|
||
|
||
|
||
(define (test-output-file-opener open filename)
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(pass-if "opens binary output port"
|
||
(call-with-port (open filename)
|
||
(lambda (port)
|
||
(put-bytevector port '#vu8(1 2 3))
|
||
(and (binary-port? port)
|
||
(output-port? port))))))
|
||
|
||
(pass-if-condition "exception: already-exists"
|
||
i/o-file-already-exists-error?
|
||
(open filename))
|
||
|
||
(pass-if "no-fail no-truncate"
|
||
(and
|
||
(call-with-port (open filename (file-options no-fail no-truncate))
|
||
(lambda (port)
|
||
(= 0 (port-position port))))
|
||
(= 3 (stat:size (stat filename)))))
|
||
|
||
(pass-if "no-fail"
|
||
(and
|
||
(call-with-port (open filename (file-options no-fail))
|
||
binary-port?)
|
||
(= 0 (stat:size (stat filename)))))
|
||
|
||
(delete-file filename)
|
||
|
||
(pass-if-condition "exception: does-not-exist"
|
||
i/o-file-does-not-exist-error?
|
||
(open filename (file-options no-create))))
|
||
|
||
(with-test-prefix "8.2.10 Output ports"
|
||
|
||
(with-test-prefix "open-file-output-port"
|
||
(test-output-file-opener open-file-output-port (test-file)))
|
||
|
||
(pass-if "open-bytevector-output-port"
|
||
(let-values (((port get-content)
|
||
(open-bytevector-output-port #f)))
|
||
(let ((source (make-bytevector 7777)))
|
||
(put-bytevector port source)
|
||
(and (bytevector=? (get-content) source)
|
||
(bytevector=? (get-content) (make-bytevector 0))))))
|
||
|
||
(pass-if "bytevector-output-port is binary"
|
||
(binary-port? (open-bytevector-output-port)))
|
||
|
||
(pass-if "open-bytevector-output-port [extract after close]"
|
||
(let-values (((port get-content)
|
||
(open-bytevector-output-port)))
|
||
(let ((source (make-bytevector 12345 #xFE)))
|
||
(put-bytevector port source)
|
||
(close-port port)
|
||
(bytevector=? (get-content) source))))
|
||
|
||
(pass-if "open-bytevector-output-port [put-u8]"
|
||
(let-values (((port get-content)
|
||
(open-bytevector-output-port)))
|
||
(put-u8 port 77)
|
||
(and (bytevector=? (get-content) (make-bytevector 1 77))
|
||
(bytevector=? (get-content) (make-bytevector 0)))))
|
||
|
||
(pass-if "open-bytevector-output-port [display]"
|
||
(let-values (((port get-content)
|
||
(open-bytevector-output-port)))
|
||
(display "hello" port)
|
||
(and (bytevector=? (get-content) (string->utf8 "hello"))
|
||
(bytevector=? (get-content) (make-bytevector 0)))))
|
||
|
||
(pass-if "bytevector output port supports `port-position'"
|
||
(let-values (((port get-content)
|
||
(open-bytevector-output-port)))
|
||
(let ((source (make-bytevector 7777))
|
||
(overwrite (make-bytevector 33)))
|
||
(and (port-has-port-position? port)
|
||
(port-has-set-port-position!? port)
|
||
(begin
|
||
(put-bytevector port source)
|
||
(= (bytevector-length source)
|
||
(port-position port)))
|
||
(begin
|
||
(set-port-position! port 10)
|
||
(= 10 (port-position port)))
|
||
(begin
|
||
(put-bytevector port overwrite)
|
||
(bytevector-copy! overwrite 0 source 10
|
||
(bytevector-length overwrite))
|
||
(= (port-position port)
|
||
(+ 10 (bytevector-length overwrite))))
|
||
(bytevector=? (get-content) source)
|
||
(bytevector=? (get-content) (make-bytevector 0))))))
|
||
|
||
(pass-if "make-custom-binary-output-port"
|
||
(let ((port (make-custom-binary-output-port "cbop"
|
||
(lambda (x y z) 0)
|
||
#f #f #f)))
|
||
(and (output-port? port)
|
||
(binary-port? port)
|
||
(not (port-has-port-position? port))
|
||
(not (port-has-set-port-position!? port)))))
|
||
|
||
(pass-if "make-custom-binary-output-port [partial writes]"
|
||
(let* ((source (uint-list->bytevector (iota 333)
|
||
(native-endianness) 2))
|
||
(sink (make-bytevector (bytevector-length source)))
|
||
(sink-pos 0)
|
||
(eof? #f)
|
||
(write! (lambda (bv start count)
|
||
(if (= 0 count)
|
||
(begin
|
||
(set! eof? #t)
|
||
0)
|
||
(let ((u8 (bytevector-u8-ref bv start)))
|
||
;; Get one byte at a time.
|
||
(bytevector-u8-set! sink sink-pos u8)
|
||
(set! sink-pos (+ 1 sink-pos))
|
||
1))))
|
||
(port (make-custom-binary-output-port "cbop" write!
|
||
#f #f #f)))
|
||
(put-bytevector port source)
|
||
(and (= sink-pos (bytevector-length source))
|
||
(not eof?)
|
||
(bytevector=? sink source))))
|
||
|
||
(pass-if "make-custom-binary-output-port [full writes]"
|
||
(let* ((source (uint-list->bytevector (iota 333)
|
||
(native-endianness) 2))
|
||
(sink (make-bytevector (bytevector-length source)))
|
||
(sink-pos 0)
|
||
(eof? #f)
|
||
(write! (lambda (bv start count)
|
||
(if (= 0 count)
|
||
(begin
|
||
(set! eof? #t)
|
||
0)
|
||
(begin
|
||
(bytevector-copy! bv start
|
||
sink sink-pos
|
||
count)
|
||
(set! sink-pos (+ sink-pos count))
|
||
count))))
|
||
(port (make-custom-binary-output-port "cbop" write!
|
||
#f #f #f)))
|
||
(put-bytevector port source)
|
||
(and (= sink-pos (bytevector-length source))
|
||
(not eof?)
|
||
(bytevector=? sink source))))
|
||
|
||
(pass-if "standard-output-port is binary"
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(binary-port? (standard-output-port))))
|
||
|
||
(pass-if "standard-error-port is binary"
|
||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||
(binary-port? (standard-error-port)))))
|
||
|
||
|
||
(with-test-prefix "8.2.6 Input and output ports"
|
||
|
||
(pass-if "transcoded-port [output]"
|
||
(let ((s "Hello\nÄÖÜ"))
|
||
(bytevector=?
|
||
(string->utf8 s)
|
||
(call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
|
||
(lambda (utf8-port)
|
||
(put-string utf8-port s))))))
|
||
|
||
(pass-if "transcoded-port [input]"
|
||
(let ((s "Hello\nÄÖÜ"))
|
||
(string=?
|
||
s
|
||
(get-string-all
|
||
(transcoded-port (open-bytevector-input-port (string->utf8 s))
|
||
(make-transcoder (utf-8-codec)))))))
|
||
|
||
(pass-if "transcoded-port [input line]"
|
||
(string=? "ÄÖÜ"
|
||
(get-line (transcoded-port
|
||
(open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
|
||
(make-transcoder (utf-8-codec))))))
|
||
|
||
(pass-if "transcoded-port [error handling mode = raise]"
|
||
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
|
||
(error-handling-mode raise)))
|
||
(b (open-bytevector-input-port #vu8(255 2 1)))
|
||
(tp (transcoded-port b t)))
|
||
(guard (c ((i/o-decoding-error? c)
|
||
(eq? (i/o-error-port c) tp)))
|
||
(get-line tp)
|
||
#f))) ; fail if we reach this point
|
||
|
||
(pass-if "transcoded-port [error handling mode = replace]"
|
||
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
|
||
(error-handling-mode replace)))
|
||
(b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
|
||
(tp (transcoded-port b t)))
|
||
(string-suffix? "gnu" (get-line tp))))
|
||
|
||
(pass-if "transcoded-port, output [error handling mode = raise]"
|
||
(let-values (((p get)
|
||
(open-bytevector-output-port)))
|
||
(let* ((t (make-transcoder (latin-1-codec) (native-eol-style)
|
||
(error-handling-mode raise)))
|
||
(tp (transcoded-port p t)))
|
||
(guard (c ((i/o-encoding-error? c)
|
||
(and (eq? (i/o-error-port c) tp)
|
||
(char=? (i/o-encoding-error-char c) #\λ)
|
||
(bytevector=? (get) (string->utf8 "The letter ")))))
|
||
(put-string tp "The letter λ cannot be represented in Latin-1.")
|
||
#f))))
|
||
|
||
(pass-if "port-transcoder [transcoded port]"
|
||
(let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
|
||
(make-transcoder (utf-8-codec))))
|
||
(t (port-transcoder p)))
|
||
(and t
|
||
(transcoder-codec t)
|
||
(eq? (native-eol-style)
|
||
(transcoder-eol-style t))
|
||
(eq? (error-handling-mode replace)
|
||
(transcoder-error-handling-mode t))))))
|
||
|
||
(with-test-prefix "8.2.9 Textual input"
|
||
|
||
(pass-if "get-string-n [short]"
|
||
(let ((port (open-input-string "GNU Guile")))
|
||
(string=? "GNU " (get-string-n port 4))))
|
||
(pass-if "get-string-n [long]"
|
||
(let ((port (open-input-string "GNU Guile")))
|
||
(string=? "GNU Guile" (get-string-n port 256))))
|
||
(pass-if "get-string-n [eof]"
|
||
(let ((port (open-input-string "")))
|
||
(eof-object? (get-string-n port 4))))
|
||
|
||
(pass-if "get-string-n! [short]"
|
||
(let ((port (open-input-string "GNU Guile"))
|
||
(s (string-copy "Isn't XXX great?")))
|
||
(and (= 3 (get-string-n! port s 6 3))
|
||
(string=? s "Isn't GNU great?"))))
|
||
|
||
(with-test-prefix "read error"
|
||
(pass-if-condition "get-char" i/o-read-error?
|
||
(get-char (make-failing-port)))
|
||
(pass-if-condition "lookahead-char" i/o-read-error?
|
||
(lookahead-char (make-failing-port)))
|
||
;; FIXME: these are not yet exception-correct
|
||
#|
|
||
(pass-if-condition "get-string-n" i/o-read-error?
|
||
(get-string-n (make-failing-port) 5))
|
||
(pass-if-condition "get-string-n!" i/o-read-error?
|
||
(get-string-n! (make-failing-port) (make-string 5) 0 5))
|
||
|#
|
||
(pass-if-condition "get-string-all" i/o-read-error?
|
||
(get-string-all (make-failing-port 100)))
|
||
(pass-if-condition "get-line" i/o-read-error?
|
||
(get-line (make-failing-port)))
|
||
(pass-if-condition "get-datum" i/o-read-error?
|
||
(get-datum (make-failing-port)))))
|
||
|
||
(define (encoding-error-predicate char)
|
||
(lambda (c)
|
||
(and (i/o-encoding-error? c)
|
||
(char=? char (i/o-encoding-error-char c)))))
|
||
|
||
(with-test-prefix "8.2.12 Textual Output"
|
||
|
||
(with-test-prefix "write error"
|
||
(pass-if-condition "put-char" i/o-write-error?
|
||
(put-char (make-failing-port) #\G))
|
||
(pass-if-condition "put-string" i/o-write-error?
|
||
(put-string (make-failing-port) "Hello World!"))
|
||
(pass-if-condition "put-datum" i/o-write-error?
|
||
(put-datum (make-failing-port) '(hello world!))))
|
||
(with-test-prefix "encoding error"
|
||
(pass-if-condition "put-char" (encoding-error-predicate #\λ)
|
||
(call-with-bytevector-output-port/transcoded
|
||
(make-transcoder (latin-1-codec)
|
||
(native-eol-style)
|
||
(error-handling-mode raise))
|
||
(lambda (port)
|
||
(put-char port #\λ))))
|
||
(pass-if-condition "put-string" (encoding-error-predicate #\λ)
|
||
(call-with-bytevector-output-port/transcoded
|
||
(make-transcoder (latin-1-codec)
|
||
(native-eol-style)
|
||
(error-handling-mode raise))
|
||
(lambda (port)
|
||
(put-string port "FooλBar"))))))
|
||
|
||
(with-test-prefix "8.3 Simple I/O"
|
||
(with-test-prefix "read error"
|
||
(pass-if-condition "read-char" i/o-read-error?
|
||
(read-char (make-failing-port)))
|
||
(pass-if-condition "peek-char" i/o-read-error?
|
||
(peek-char (make-failing-port)))
|
||
(pass-if-condition "read" i/o-read-error?
|
||
(read (make-failing-port))))
|
||
(with-test-prefix "write error"
|
||
(pass-if-condition "display" i/o-write-error?
|
||
(display "Hi there!" (make-failing-port)))
|
||
(pass-if-condition "write" i/o-write-error?
|
||
(write '(hi there!) (make-failing-port)))
|
||
(pass-if-condition "write-char" i/o-write-error?
|
||
(write-char #\G (make-failing-port)))
|
||
(pass-if-condition "newline" i/o-write-error?
|
||
(newline (make-failing-port))))
|
||
(let ((filename (test-file)))
|
||
;; ensure the test file exists
|
||
(call-with-output-file filename
|
||
(lambda (port) (write "foo" port)))
|
||
(pass-if "call-with-input-file [port is textual]"
|
||
(call-with-input-file filename textual-port?))
|
||
(pass-if-condition "call-with-input-file [exception: not-found]"
|
||
i/o-file-does-not-exist-error?
|
||
(call-with-input-file ",this-is-highly-unlikely-to-exist!"
|
||
values))
|
||
(pass-if-condition "call-with-output-file [exception: already-exists]"
|
||
i/o-file-already-exists-error?
|
||
(call-with-output-file filename
|
||
values))
|
||
(delete-file filename)))
|
||
|
||
(with-test-prefix "8.2.13 Input/output ports"
|
||
(with-test-prefix "open-file-input/output-port [output]"
|
||
(test-output-file-opener open-file-input/output-port (test-file)))
|
||
(with-test-prefix "open-file-input/output-port [input]"
|
||
(test-input-file-opener open-file-input/output-port (test-file))))
|
||
|
||
;;; Local Variables:
|
||
;;; mode: scheme
|
||
;;; eval: (put 'guard 'scheme-indent-function 1)
|
||
;;; End:
|