;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2012, 2013-2015 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
#: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)
(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))
(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 "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 & 'get-string-all'"
+ (make-string 1000 #\a)
+ ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
+ ;; by an assertion failure. See <http://bugs.gnu.org/19621>.
+ (let* ((input (with-fluids ((%default-port-encoding #f))
+ (open-input-string (make-string 1000 #\a))))
+ (read! (lambda (bv index count)
+ (let ((n (get-bytevector-n! input bv index
+ count)))
+ (if (eof-object? n) 0 n))))
+ (port (make-custom-binary-input-port "foo" read!
+ #f #f #f)))
+ (setvbuf port _IONBF)
+ (get-string-all port)))
+
+ (pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'"
+ (make-string 1000 #\λ)
+ ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
+ ;; by an assertion failure. See <http://bugs.gnu.org/19621>.
+ (let* ((input (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string (make-string 1000 #\λ))))
+ (read! (lambda (bv index count)
+ (let ((n (get-bytevector-n! input bv index
+ count)))
+ (if (eof-object? n) 0 n))))
+ (port (make-custom-binary-input-port "foo" read!
+ #f #f #f)))
+ (setvbuf port _IONBF)
+ (set-port-encoding! port "UTF-8")
+ (get-string-all port)))
+
+ (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))
HCoop / bpt / guile.git / blobdiff