From 297dc06f1bfbb49f636018944f0a1c114d6778ea Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sat, 20 Aug 2016 16:20:53 -0500 Subject: [PATCH 2/2] Add tests for make-custom-binary-input/output-port * test-suite/tests/r6rs-ports.test ("8.2.13 Input/output ports"): Add tests for custom binary input/output ports, copied from existing binary input and binary output tests. --- test-suite/tests/r6rs-ports.test | 383 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 382 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 9aa605b..94d9fc0 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1059,11 +1059,392 @@ not `set-port-position!'" values)) (delete-file filename))) +;; Used for a lot of the make-custom-input/output tests to stub out +;; the read/write section for whatever part we're ignoring +(define dummy-write! (const 0)) +(define dummy-read! (const 0)) + (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)))) + (test-input-file-opener open-file-input/output-port (test-file))) + + ;; Custom binary input/output tests. Most of these are simple + ;; ports of the custom-binary-input-port tests or custom-binary-ouput-port + ;; tests, simply ported to use a custom-binary-input/output port. + ;; The copy-pasta is strong here; a diet lighter in spaghetti may wish + ;; to make the previous tests more reusable. + (pass-if "make-custom-binary-input/output-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)))) + (write! (lambda (x y z) 0)) + (port (make-custom-binary-input/output-port + "the port" read! write! + #f #f #f))) + (and (binary-port? port) + (input-port? port) + (output-port? port) + (bytevector=? (get-bytevector-all port) source) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if-equal "make-custom-binary-input/output-port uses ISO-8859-1 (Guile \ +extension) [input]" + "©©" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((source #vu8(194 169 194 169)) + (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/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port)))) + + (pass-if "custom binary input/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if-exception "custom binary input/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-bytevector-all port))) + + (pass-if-equal "custom binary input/output port supports `port-position', \ +not `set-port-position!'" + 42 + (let ((port (make-custom-binary-input/output-port + "the port" (const 0) dummy-write! + (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/output 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/output-port + "the port" read! dummy-write! + 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/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port))) + + (pass-if-equal "custom binary input/output 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/output-port + "the port" read! dummy-write! + get-pos #f #f))) + (setvbuf port 'none) + (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/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (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/output 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 . + (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/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (get-string-all port))) + + (pass-if-equal "custom binary input/output 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 . + (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/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (set-port-encoding! port "UTF-8") + (get-string-all port))) + + (pass-if-equal "custom binary input/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'block 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/output 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/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'block 18) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'none) + (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/output 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/output-port + "the port" read! dummy-write! + get-pos set-pos! close!))) + + (close-port port) + (gc) ; Test for marking a closed port. + closed?)) + + (pass-if "make-custom-binary-input/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-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-input/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-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)\ + [output]" + '(194 169 194 169) + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((sink '()) + (write! (lambda (bv start count) + (if (= 0 count) ; EOF + 0 + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (set! sink (cons u8 sink)) + 1)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-string port "©©") + (force-output port) + (reverse sink)))) + ) (define exception:encoding-error '(encoding-error . "")) -- 2.9.2