1 ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
3 ;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-io-ports)
21 #:use-module (test-suite lib)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-11)
24 #:use-module (rnrs io ports)
25 #:use-module (rnrs exceptions)
26 #:use-module (rnrs bytevectors))
28 ;;; All these tests assume Guile 1.8's port system, where characters are
29 ;;; treated as octets.
31 ;; Set the default encoding of future ports to be Latin-1.
32 (fluid-set! %default-port-encoding #f)
35 (with-test-prefix "7.2.5 End-of-File Object"
38 (and (eqv? (eof-object) (eof-object))
39 (eq? (eof-object) (eof-object))))
42 (port-eof? (open-input-string ""))))
45 (with-test-prefix "7.2.8 Binary Input"
48 (let ((port (open-input-string "A")))
49 (and (= (char->integer #\A) (get-u8 port))
50 (eof-object? (get-u8 port)))))
52 (pass-if "lookahead-u8"
53 (let ((port (open-input-string "A")))
54 (and (= (char->integer #\A) (lookahead-u8 port))
55 (= (char->integer #\A) (lookahead-u8 port))
56 (= (char->integer #\A) (get-u8 port))
57 (eof-object? (get-u8 port)))))
59 (pass-if "lookahead-u8 non-ASCII"
60 (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
61 (open-input-string "λ"))))
62 (and (= 206 (lookahead-u8 port))
63 (= 206 (lookahead-u8 port))
65 (= 187 (lookahead-u8 port))
66 (= 187 (lookahead-u8 port))
68 (eof-object? (lookahead-u8 port))
69 (eof-object? (get-u8 port)))))
71 (pass-if "lookahead-u8: result is unsigned"
73 (let ((port (open-bytevector-input-port #vu8(255))))
74 (= (lookahead-u8 port) 255)))
76 (pass-if "get-bytevector-n [short]"
77 (let* ((port (open-input-string "GNU Guile"))
78 (bv (get-bytevector-n port 4)))
80 (equal? (bytevector->u8-list bv)
81 (map char->integer (string->list "GNU "))))))
83 (pass-if "get-bytevector-n [long]"
84 (let* ((port (open-input-string "GNU Guile"))
85 (bv (get-bytevector-n port 256)))
87 (equal? (bytevector->u8-list bv)
88 (map char->integer (string->list "GNU Guile"))))))
90 (pass-if-exception "get-bytevector-n with closed port"
91 exception:wrong-type-arg
93 (let ((port (%make-void-port "r")))
96 (get-bytevector-n port 3)))
98 (pass-if "get-bytevector-n! [short]"
99 (let* ((port (open-input-string "GNU Guile"))
100 (bv (make-bytevector 4))
101 (read (get-bytevector-n! port bv 0 4)))
103 (equal? (bytevector->u8-list bv)
104 (map char->integer (string->list "GNU "))))))
106 (pass-if "get-bytevector-n! [long]"
107 (let* ((str "GNU Guile")
108 (port (open-input-string str))
109 (bv (make-bytevector 256))
110 (read (get-bytevector-n! port bv 0 256)))
111 (and (equal? read (string-length str))
112 (equal? (map (lambda (i)
113 (bytevector-u8-ref bv i))
115 (map char->integer (string->list str))))))
117 (pass-if "get-bytevector-some [simple]"
118 (let* ((str "GNU Guile")
119 (port (open-input-string str))
120 (bv (get-bytevector-some port)))
121 (and (bytevector? bv)
122 (equal? (bytevector->u8-list bv)
123 (map char->integer (string->list str))))))
125 (pass-if "get-bytevector-some [only-some]"
126 (let* ((str "GNU Guile")
128 (port (make-soft-port
131 (if (>= index (string-length str))
133 (let ((c (string-ref str index)))
134 (set! index (+ index 1))
138 ;; Number of readily available octets: falls to
139 ;; zero after 4 octets have been read.
140 (- 4 (modulo index 5))))
142 (bv (get-bytevector-some port)))
143 (and (bytevector? bv)
145 (= (bytevector-length bv) index)
146 (equal? (bytevector->u8-list bv)
147 (map char->integer (string->list "GNU "))))))
149 (pass-if "get-bytevector-all"
150 (let* ((str "GNU Guile")
152 (port (make-soft-port
155 (if (>= index (string-length str))
157 (let ((c (string-ref str index)))
158 (set! index (+ index 1))
163 ;; Number of readily available octets: falls to
164 ;; zero after 4 octets have been read and then
167 (- (string-length str) index)
168 (- 4 (modulo index 5)))))
169 (if (= 0 a) (set! cont? #t))
172 (bv (get-bytevector-all port)))
173 (and (bytevector? bv)
174 (= index (string-length str))
175 (= (bytevector-length bv) (string-length str))
176 (equal? (bytevector->u8-list bv)
177 (map char->integer (string->list str)))))))
180 (define (make-soft-output-port)
181 (let* ((bv (make-bytevector 1024))
184 (write-char (lambda (chr)
185 (bytevector-u8-set! bv write-index
187 (set! write-index (+ 1 write-index)))))
190 (lambda (str) ;; write-string
191 (for-each write-char (string->list str)))
192 (lambda () #t) ;; flush-output
193 (lambda () ;; read-char
194 (if (>= read-index (bytevector-length bv))
196 (let ((c (bytevector-u8-ref bv read-index)))
197 (set! read-index (+ read-index 1))
199 (lambda () #t)) ;; close-port
202 (with-test-prefix "7.2.11 Binary Output"
205 (let ((port (make-soft-output-port)))
207 (equal? (get-u8 port) 77)))
209 ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
210 ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
211 ;; the bytes through, unmodified. This is hacky, but we can't use
212 ;; "custom binary output ports" here because they're only tested
215 (pass-if "put-bytevector [2 args]"
217 (let ((port (make-soft-output-port))
218 (bv (make-bytevector 256)))
219 (put-bytevector port bv)
220 (equal? (bytevector->u8-list bv)
222 (get-bytevector-n port (bytevector-length bv)))))))
224 (pass-if "put-bytevector [3 args]"
226 (let ((port (make-soft-output-port))
227 (bv (make-bytevector 256))
229 (put-bytevector port bv start)
230 (equal? (drop (bytevector->u8-list bv) start)
232 (get-bytevector-n port (- (bytevector-length bv) start)))))))
234 (pass-if "put-bytevector [4 args]"
236 (let ((port (make-soft-output-port))
237 (bv (make-bytevector 256))
240 (put-bytevector port bv start count)
241 (equal? (take (drop (bytevector->u8-list bv) start) count)
243 (get-bytevector-n port count))))))
245 (pass-if-exception "put-bytevector with closed port"
246 exception:wrong-type-arg
248 (let* ((bv (make-bytevector 4))
249 (port (%make-void-port "w")))
252 (put-bytevector port bv)))
254 (pass-if "put-bytevector with UTF-16 string port"
255 (let* ((str "hello, world")
256 (bv (string->utf16 str)))
258 (with-fluids ((%default-port-encoding "UTF-16BE"))
259 (call-with-output-string
261 (put-bytevector port bv)))))))
263 (pass-if "put-bytevector with wrong-encoding string port"
264 (let* ((str "hello, world")
265 (bv (string->utf16 str)))
266 (catch 'decoding-error
268 (with-fluids ((%default-port-encoding "UTF-32"))
269 (call-with-output-string
271 (put-bytevector port bv)))))
272 (lambda (key subr message errno port)
273 (string? (strerror errno)))))))
276 (with-test-prefix "7.2.7 Input Ports"
278 ;; This section appears here so that it can use the binary input
281 (pass-if "open-bytevector-input-port [1 arg]"
282 (let* ((str "Hello Port!")
283 (bv (u8-list->bytevector (map char->integer
284 (string->list str))))
285 (port (open-bytevector-input-port bv))
288 (let loop ((chr (read-char port))
290 (if (eof-object? chr)
291 (apply string (reverse! result))
292 (loop (read-char port)
293 (cons chr result)))))))
295 (equal? (read-to-string port) str)))
297 (pass-if-exception "bytevector-input-port is read-only"
298 exception:wrong-type-arg
300 (let* ((str "Hello Port!")
301 (bv (u8-list->bytevector (map char->integer
302 (string->list str))))
303 (port (open-bytevector-input-port bv #f)))
305 (write "hello" port)))
307 (pass-if "bytevector input port supports seeking"
308 (let* ((str "Hello Port!")
309 (bv (u8-list->bytevector (map char->integer
310 (string->list str))))
311 (port (open-bytevector-input-port bv #f)))
313 (and (port-has-port-position? port)
314 (= 0 (port-position port))
315 (port-has-set-port-position!? port)
317 (set-port-position! port 6)
318 (= 6 (port-position port)))
319 (bytevector=? (get-bytevector-all port)
321 (map char->integer (string->list "Port!")))))))
323 (pass-if "bytevector input port can seek to very end"
324 (let ((empty (open-bytevector-input-port '#vu8()))
325 (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
326 (and (begin (set-port-position! empty (port-position empty))
327 (= 0 (port-position empty)))
328 (begin (get-bytevector-n not-empty 3)
329 (set-port-position! not-empty (port-position not-empty))
330 (= 3 (port-position not-empty))))))
332 (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
333 exception:wrong-num-args
335 ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
337 (make-custom-binary-input-port "port" (lambda args #t)))
339 (pass-if "make-custom-binary-input-port"
340 (let* ((source (make-bytevector 7777))
342 (len (bytevector-length source)))
343 (lambda (bv start count)
344 (let ((amount (min count (- len pos))))
346 (bytevector-copy! source pos
348 (set! pos (+ pos amount))
350 (port (make-custom-binary-input-port "the port" read!
353 (bytevector=? (get-bytevector-all port) source)))
355 (pass-if "custom binary input port does not support `port-position'"
356 (let* ((str "Hello Port!")
357 (source (open-bytevector-input-port
359 (map char->integer (string->list str)))))
360 (read! (lambda (bv start count)
361 (let ((r (get-bytevector-n! source bv start count)))
365 (port (make-custom-binary-input-port "the port" read!
367 (not (or (port-has-port-position? port)
368 (port-has-set-port-position!? port)))))
370 (pass-if "custom binary input port supports `port-position'"
371 (let* ((str "Hello Port!")
372 (source (open-bytevector-input-port
374 (map char->integer (string->list str)))))
375 (read! (lambda (bv start count)
376 (let ((r (get-bytevector-n! source bv start count)))
381 (port-position source)))
382 (set-pos! (lambda (pos)
383 (set-port-position! source pos)))
384 (port (make-custom-binary-input-port "the port" read!
385 get-pos set-pos! #f)))
387 (and (port-has-port-position? port)
388 (= 0 (port-position port))
389 (port-has-set-port-position!? port)
391 (set-port-position! port 6)
392 (= 6 (port-position port)))
393 (bytevector=? (get-bytevector-all port)
395 (map char->integer (string->list "Port!")))))))
397 (pass-if "custom binary input port `close-proc' is called"
399 (read! (lambda (bv start count) 0))
400 (get-pos (lambda () 0))
401 (set-pos! (lambda (pos) #f))
402 (close! (lambda () (set! closed? #t)))
403 (port (make-custom-binary-input-port "the port" read!
408 (gc) ; Test for marking a closed port.
411 (pass-if "standard-input-port is binary"
412 (with-fluids ((%default-port-encoding "UTF-8"))
413 (binary-port? (standard-input-port)))))
416 (with-test-prefix "8.2.10 Output ports"
418 (pass-if "open-bytevector-output-port"
419 (let-values (((port get-content)
420 (open-bytevector-output-port #f)))
421 (let ((source (make-bytevector 7777)))
422 (put-bytevector port source)
423 (and (bytevector=? (get-content) source)
424 (bytevector=? (get-content) (make-bytevector 0))))))
426 (pass-if "open-bytevector-output-port [extract after close]"
427 (let-values (((port get-content)
428 (open-bytevector-output-port)))
429 (let ((source (make-bytevector 12345 #xFE)))
430 (put-bytevector port source)
432 (bytevector=? (get-content) source))))
434 (pass-if "open-bytevector-output-port [put-u8]"
435 (let-values (((port get-content)
436 (open-bytevector-output-port)))
438 (and (bytevector=? (get-content) (make-bytevector 1 77))
439 (bytevector=? (get-content) (make-bytevector 0)))))
441 (pass-if "open-bytevector-output-port [display]"
442 (let-values (((port get-content)
443 (open-bytevector-output-port)))
444 (display "hello" port)
445 (and (bytevector=? (get-content) (string->utf8 "hello"))
446 (bytevector=? (get-content) (make-bytevector 0)))))
448 (pass-if "bytevector output port supports `port-position'"
449 (let-values (((port get-content)
450 (open-bytevector-output-port)))
451 (let ((source (make-bytevector 7777))
452 (overwrite (make-bytevector 33)))
453 (and (port-has-port-position? port)
454 (port-has-set-port-position!? port)
456 (put-bytevector port source)
457 (= (bytevector-length source)
458 (port-position port)))
460 (set-port-position! port 10)
461 (= 10 (port-position port)))
463 (put-bytevector port overwrite)
464 (bytevector-copy! overwrite 0 source 10
465 (bytevector-length overwrite))
466 (= (port-position port)
467 (+ 10 (bytevector-length overwrite))))
468 (bytevector=? (get-content) source)
469 (bytevector=? (get-content) (make-bytevector 0))))))
471 (pass-if "make-custom-binary-output"
472 (let ((port (make-custom-binary-output-port "cbop"
475 (and (output-port? port)
477 (not (port-has-port-position? port))
478 (not (port-has-set-port-position!? port)))))
480 (pass-if "make-custom-binary-output-port [partial writes]"
481 (let* ((source (uint-list->bytevector (iota 333)
482 (native-endianness) 2))
483 (sink (make-bytevector (bytevector-length source)))
486 (write! (lambda (bv start count)
491 (let ((u8 (bytevector-u8-ref bv start)))
492 ;; Get one byte at a time.
493 (bytevector-u8-set! sink sink-pos u8)
494 (set! sink-pos (+ 1 sink-pos))
496 (port (make-custom-binary-output-port "cbop" write!
498 (put-bytevector port source)
499 (and (= sink-pos (bytevector-length source))
501 (bytevector=? sink source))))
503 (pass-if "make-custom-binary-output-port [full writes]"
504 (let* ((source (uint-list->bytevector (iota 333)
505 (native-endianness) 2))
506 (sink (make-bytevector (bytevector-length source)))
509 (write! (lambda (bv start count)
515 (bytevector-copy! bv start
518 (set! sink-pos (+ sink-pos count))
520 (port (make-custom-binary-output-port "cbop" write!
522 (put-bytevector port source)
523 (and (= sink-pos (bytevector-length source))
525 (bytevector=? sink source))))
527 (pass-if "standard-output-port is binary"
528 (with-fluids ((%default-port-encoding "UTF-8"))
529 (binary-port? (standard-output-port))))
531 (pass-if "standard-error-port is binary"
532 (with-fluids ((%default-port-encoding "UTF-8"))
533 (binary-port? (standard-error-port)))))
536 (with-test-prefix "8.2.6 Input and output ports"
538 (pass-if "transcoded-port [output]"
539 (let ((s "Hello\nÄÖÜ"))
542 (call-with-bytevector-output-port
544 (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
546 (put-string utf8-port s))))))))
548 (pass-if "transcoded-port [input]"
549 (let ((s "Hello\nÄÖÜ"))
553 (transcoded-port (open-bytevector-input-port (string->utf8 s))
554 (make-transcoder (utf-8-codec)))))))
556 (pass-if "transcoded-port [input line]"
558 (get-line (transcoded-port
559 (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
560 (make-transcoder (utf-8-codec))))))
562 (pass-if "transcoded-port [error handling mode = raise]"
563 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
564 (error-handling-mode raise)))
565 (b (open-bytevector-input-port #vu8(255 2 1)))
566 (tp (transcoded-port b t)))
567 (guard (c ((i/o-decoding-error? c)
568 (eq? (i/o-error-port c) tp)))
571 (pass-if "transcoded-port [error handling mode = replace]"
572 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
573 (error-handling-mode replace)))
574 (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
575 (tp (transcoded-port b t)))
576 (string-suffix? "gnu" (get-line tp))))
578 (pass-if "transcoded-port, output [error handling mode = raise]"
579 (let-values (((p get)
580 (open-bytevector-output-port)))
581 (let* ((t (make-transcoder (latin-1-codec) (native-eol-style)
582 (error-handling-mode raise)))
583 (tp (transcoded-port p t)))
584 (guard (c ((i/o-encoding-error? c)
585 (and (eq? (i/o-error-port c) tp)
586 (char=? (i/o-encoding-error-char c) #\λ)
587 (bytevector=? (get) (string->utf8 "The letter ")))))
588 (put-string tp "The letter λ cannot be represented in Latin-1.")
591 (pass-if "port-transcoder [binary port]"
592 (not (port-transcoder (open-bytevector-input-port #vu8()))))
594 (pass-if "port-transcoder [transcoded port]"
595 (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
596 (make-transcoder (utf-8-codec))))
597 (t (port-transcoder p)))
600 (eq? (native-eol-style)
601 (transcoder-eol-style t))
602 (eq? (error-handling-mode replace)
603 (transcoder-error-handling-mode t))))))
605 (with-test-prefix "8.2.9 Textual input"
607 (pass-if "get-string-n [short]"
608 (let ((port (open-input-string "GNU Guile")))
609 (string=? "GNU " (get-string-n port 4))))
610 (pass-if "get-string-n [long]"
611 (let ((port (open-input-string "GNU Guile")))
612 (string=? "GNU Guile" (get-string-n port 256))))
613 (pass-if "get-string-n [eof]"
614 (let ((port (open-input-string "")))
615 (eof-object? (get-string-n port 4))))
617 (pass-if "get-string-n! [short]"
618 (let ((port (open-input-string "GNU Guile"))
619 (s (string-copy "Isn't XXX great?")))
620 (and (= 3 (get-string-n! port s 6 3))
621 (string=? s "Isn't GNU great?")))))
625 ;;; eval: (put 'guard 'scheme-indent-function 1)