1 ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: iso-8859-1; -*-
3 ;;;; Copyright (C) 2009, 2010 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 bytevectors))
27 ;;; All these tests assume Guile 1.8's port system, where characters are
28 ;;; treated as octets.
30 ;; Set the default encoding of future ports to be Latin-1.
31 (fluid-set! %default-port-encoding #f)
34 (with-test-prefix "7.2.5 End-of-File Object"
37 (and (eqv? (eof-object) (eof-object))
38 (eq? (eof-object) (eof-object)))))
41 (with-test-prefix "7.2.8 Binary Input"
44 (let ((port (open-input-string "A")))
45 (and (= (char->integer #\A) (get-u8 port))
46 (eof-object? (get-u8 port)))))
48 (pass-if "lookahead-u8"
49 (let ((port (open-input-string "A")))
50 (and (= (char->integer #\A) (lookahead-u8 port))
51 (not (eof-object? port))
52 (= (char->integer #\A) (get-u8 port))
53 (eof-object? (get-u8 port)))))
55 (pass-if "lookahead-u8: result is unsigned"
57 (let ((port (open-bytevector-input-port #vu8(255))))
58 (= (lookahead-u8 port) 255)))
60 (pass-if "get-bytevector-n [short]"
61 (let* ((port (open-input-string "GNU Guile"))
62 (bv (get-bytevector-n port 4)))
64 (equal? (bytevector->u8-list bv)
65 (map char->integer (string->list "GNU "))))))
67 (pass-if "get-bytevector-n [long]"
68 (let* ((port (open-input-string "GNU Guile"))
69 (bv (get-bytevector-n port 256)))
71 (equal? (bytevector->u8-list bv)
72 (map char->integer (string->list "GNU Guile"))))))
74 (pass-if-exception "get-bytevector-n with closed port"
75 exception:wrong-type-arg
77 (let ((port (%make-void-port "r")))
80 (get-bytevector-n port 3)))
82 (pass-if "get-bytevector-n! [short]"
83 (let* ((port (open-input-string "GNU Guile"))
84 (bv (make-bytevector 4))
85 (read (get-bytevector-n! port bv 0 4)))
87 (equal? (bytevector->u8-list bv)
88 (map char->integer (string->list "GNU "))))))
90 (pass-if "get-bytevector-n! [long]"
91 (let* ((str "GNU Guile")
92 (port (open-input-string str))
93 (bv (make-bytevector 256))
94 (read (get-bytevector-n! port bv 0 256)))
95 (and (equal? read (string-length str))
96 (equal? (map (lambda (i)
97 (bytevector-u8-ref bv i))
99 (map char->integer (string->list str))))))
101 (pass-if "get-bytevector-some [simple]"
102 (let* ((str "GNU Guile")
103 (port (open-input-string str))
104 (bv (get-bytevector-some port)))
105 (and (bytevector? bv)
106 (equal? (bytevector->u8-list bv)
107 (map char->integer (string->list str))))))
109 (pass-if "get-bytevector-some [only-some]"
110 (let* ((str "GNU Guile")
112 (port (make-soft-port
115 (if (>= index (string-length str))
117 (let ((c (string-ref str index)))
118 (set! index (+ index 1))
122 ;; Number of readily available octets: falls to
123 ;; zero after 4 octets have been read.
124 (- 4 (modulo index 5))))
126 (bv (get-bytevector-some port)))
127 (and (bytevector? bv)
129 (= (bytevector-length bv) index)
130 (equal? (bytevector->u8-list bv)
131 (map char->integer (string->list "GNU "))))))
133 (pass-if "get-bytevector-all"
134 (let* ((str "GNU Guile")
136 (port (make-soft-port
139 (if (>= index (string-length str))
141 (let ((c (string-ref str index)))
142 (set! index (+ index 1))
147 ;; Number of readily available octets: falls to
148 ;; zero after 4 octets have been read and then
151 (- (string-length str) index)
152 (- 4 (modulo index 5)))))
153 (if (= 0 a) (set! cont? #t))
156 (bv (get-bytevector-all port)))
157 (and (bytevector? bv)
158 (= index (string-length str))
159 (= (bytevector-length bv) (string-length str))
160 (equal? (bytevector->u8-list bv)
161 (map char->integer (string->list str)))))))
164 (define (make-soft-output-port)
165 (let* ((bv (make-bytevector 1024))
168 (write-char (lambda (chr)
169 (bytevector-u8-set! bv write-index
171 (set! write-index (+ 1 write-index)))))
174 (lambda (str) ;; write-string
175 (for-each write-char (string->list str)))
176 (lambda () #t) ;; flush-output
177 (lambda () ;; read-char
178 (if (>= read-index (bytevector-length bv))
180 (let ((c (bytevector-u8-ref bv read-index)))
181 (set! read-index (+ read-index 1))
183 (lambda () #t)) ;; close-port
186 (with-test-prefix "7.2.11 Binary Output"
189 (let ((port (make-soft-output-port)))
191 (equal? (get-u8 port) 77)))
193 ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
194 ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
195 ;; the bytes through, unmodified. This is hacky, but we can't use
196 ;; "custom binary output ports" here because they're only tested
199 (pass-if "put-bytevector [2 args]"
201 (let ((port (make-soft-output-port))
202 (bv (make-bytevector 256)))
203 (put-bytevector port bv)
204 (equal? (bytevector->u8-list bv)
206 (get-bytevector-n port (bytevector-length bv)))))))
208 (pass-if "put-bytevector [3 args]"
210 (let ((port (make-soft-output-port))
211 (bv (make-bytevector 256))
213 (put-bytevector port bv start)
214 (equal? (drop (bytevector->u8-list bv) start)
216 (get-bytevector-n port (- (bytevector-length bv) start)))))))
218 (pass-if "put-bytevector [4 args]"
220 (let ((port (make-soft-output-port))
221 (bv (make-bytevector 256))
224 (put-bytevector port bv start count)
225 (equal? (take (drop (bytevector->u8-list bv) start) count)
227 (get-bytevector-n port count))))))
229 (pass-if-exception "put-bytevector with closed port"
230 exception:wrong-type-arg
232 (let* ((bv (make-bytevector 4))
233 (port (%make-void-port "w")))
236 (put-bytevector port bv)))
238 (pass-if "put-bytevector with UTF-16 string port"
239 (let* ((str "hello, world")
240 (bv (string->utf16 str)))
242 (with-fluids ((%default-port-encoding "UTF-16BE"))
243 (call-with-output-string
245 (put-bytevector port bv)))))))
247 (pass-if "put-bytevector with wrong-encoding string port"
248 (let* ((str "hello, world")
249 (bv (string->utf16 str)))
250 (catch 'encoding-error
252 (with-fluids ((%default-port-encoding "UTF-32"))
253 (call-with-output-string
255 (put-bytevector port bv)))))
256 (lambda (key subr message errno from to faulty-bv)
257 (and (bytevector=? faulty-bv bv)
258 (string=? to "UTF-32")
259 (string? (strerror errno))))))))
262 (with-test-prefix "7.2.7 Input Ports"
264 ;; This section appears here so that it can use the binary input
267 (pass-if "open-bytevector-input-port [1 arg]"
268 (let* ((str "Hello Port!")
269 (bv (u8-list->bytevector (map char->integer
270 (string->list str))))
271 (port (open-bytevector-input-port bv))
274 (let loop ((chr (read-char port))
276 (if (eof-object? chr)
277 (apply string (reverse! result))
278 (loop (read-char port)
279 (cons chr result)))))))
281 (equal? (read-to-string port) str)))
283 (pass-if-exception "bytevector-input-port is read-only"
284 exception:wrong-type-arg
286 (let* ((str "Hello Port!")
287 (bv (u8-list->bytevector (map char->integer
288 (string->list str))))
289 (port (open-bytevector-input-port bv #f)))
291 (write "hello" port)))
293 (pass-if "bytevector input port supports seeking"
294 (let* ((str "Hello Port!")
295 (bv (u8-list->bytevector (map char->integer
296 (string->list str))))
297 (port (open-bytevector-input-port bv #f)))
299 (and (port-has-port-position? port)
300 (= 0 (port-position port))
301 (port-has-set-port-position!? port)
303 (set-port-position! port 6)
304 (= 6 (port-position port)))
305 (bytevector=? (get-bytevector-all port)
307 (map char->integer (string->list "Port!")))))))
309 (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
310 exception:wrong-num-args
312 ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
314 (make-custom-binary-input-port "port" (lambda args #t)))
316 (pass-if "make-custom-binary-input-port"
317 (let* ((source (make-bytevector 7777))
319 (len (bytevector-length source)))
320 (lambda (bv start count)
321 (let ((amount (min count (- len pos))))
323 (bytevector-copy! source pos
325 (set! pos (+ pos amount))
327 (port (make-custom-binary-input-port "the port" read!
330 (bytevector=? (get-bytevector-all port) source)))
332 (pass-if "custom binary input port does not support `port-position'"
333 (let* ((str "Hello Port!")
334 (source (open-bytevector-input-port
336 (map char->integer (string->list str)))))
337 (read! (lambda (bv start count)
338 (let ((r (get-bytevector-n! source bv start count)))
342 (port (make-custom-binary-input-port "the port" read!
344 (not (or (port-has-port-position? port)
345 (port-has-set-port-position!? port)))))
347 (pass-if "custom binary input port supports `port-position'"
348 (let* ((str "Hello Port!")
349 (source (open-bytevector-input-port
351 (map char->integer (string->list str)))))
352 (read! (lambda (bv start count)
353 (let ((r (get-bytevector-n! source bv start count)))
358 (port-position source)))
359 (set-pos! (lambda (pos)
360 (set-port-position! source pos)))
361 (port (make-custom-binary-input-port "the port" read!
362 get-pos set-pos! #f)))
364 (and (port-has-port-position? port)
365 (= 0 (port-position port))
366 (port-has-set-port-position!? port)
368 (set-port-position! port 6)
369 (= 6 (port-position port)))
370 (bytevector=? (get-bytevector-all port)
372 (map char->integer (string->list "Port!")))))))
374 (pass-if "custom binary input port `close-proc' is called"
376 (read! (lambda (bv start count) 0))
377 (get-pos (lambda () 0))
378 (set-pos! (lambda (pos) #f))
379 (close! (lambda () (set! closed? #t)))
380 (port (make-custom-binary-input-port "the port" read!
385 (gc) ; Test for marking a closed port.
389 (with-test-prefix "8.2.10 Output ports"
391 (pass-if "open-bytevector-output-port"
392 (let-values (((port get-content)
393 (open-bytevector-output-port #f)))
394 (let ((source (make-bytevector 7777)))
395 (put-bytevector port source)
396 (and (bytevector=? (get-content) source)
397 (bytevector=? (get-content) (make-bytevector 0))))))
399 (pass-if "open-bytevector-output-port [extract after close]"
400 (let-values (((port get-content)
401 (open-bytevector-output-port)))
402 (let ((source (make-bytevector 12345 #xFE)))
403 (put-bytevector port source)
405 (bytevector=? (get-content) source))))
407 (pass-if "open-bytevector-output-port [put-u8]"
408 (let-values (((port get-content)
409 (open-bytevector-output-port)))
411 (and (bytevector=? (get-content) (make-bytevector 1 77))
412 (bytevector=? (get-content) (make-bytevector 0)))))
414 (pass-if "open-bytevector-output-port [display]"
415 (let-values (((port get-content)
416 (open-bytevector-output-port)))
417 (display "hello" port)
418 (and (bytevector=? (get-content) (string->utf8 "hello"))
419 (bytevector=? (get-content) (make-bytevector 0)))))
421 (pass-if "bytevector output port supports `port-position'"
422 (let-values (((port get-content)
423 (open-bytevector-output-port)))
424 (let ((source (make-bytevector 7777))
425 (overwrite (make-bytevector 33)))
426 (and (port-has-port-position? port)
427 (port-has-set-port-position!? port)
429 (put-bytevector port source)
430 (= (bytevector-length source)
431 (port-position port)))
433 (set-port-position! port 10)
434 (= 10 (port-position port)))
436 (put-bytevector port overwrite)
437 (bytevector-copy! overwrite 0 source 10
438 (bytevector-length overwrite))
439 (= (port-position port)
440 (+ 10 (bytevector-length overwrite))))
441 (bytevector=? (get-content) source)
442 (bytevector=? (get-content) (make-bytevector 0))))))
444 (pass-if "make-custom-binary-output"
445 (let ((port (make-custom-binary-output-port "cbop"
448 (and (output-port? port)
450 (not (port-has-port-position? port))
451 (not (port-has-set-port-position!? port)))))
453 (pass-if "make-custom-binary-output-port [partial writes]"
454 (let* ((source (uint-list->bytevector (iota 333)
455 (native-endianness) 2))
456 (sink (make-bytevector (bytevector-length source)))
459 (write! (lambda (bv start count)
464 (let ((u8 (bytevector-u8-ref bv start)))
465 ;; Get one byte at a time.
466 (bytevector-u8-set! sink sink-pos u8)
467 (set! sink-pos (+ 1 sink-pos))
469 (port (make-custom-binary-output-port "cbop" write!
471 (put-bytevector port source)
472 (and (= sink-pos (bytevector-length source))
474 (bytevector=? sink source))))
476 (pass-if "make-custom-binary-output-port [full writes]"
477 (let* ((source (uint-list->bytevector (iota 333)
478 (native-endianness) 2))
479 (sink (make-bytevector (bytevector-length source)))
482 (write! (lambda (bv start count)
488 (bytevector-copy! bv start
491 (set! sink-pos (+ sink-pos count))
493 (port (make-custom-binary-output-port "cbop" write!
495 (put-bytevector port source)
496 (and (= sink-pos (bytevector-length source))
498 (bytevector=? sink source)))))
501 (with-test-prefix "8.2.6 Input and output ports"
503 (pass-if "transcoded-port [output]"
504 (let ((s "Hello\nÄÖÜ"))
507 (call-with-bytevector-output-port
509 (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
511 (put-string utf8-port s))))))))
513 (pass-if "transcoded-port [input]"
514 (let ((s "Hello\nÄÖÜ"))
518 (transcoded-port (open-bytevector-input-port (string->utf8 s))
519 (make-transcoder (utf-8-codec)))))))
521 (pass-if "transcoded-port [input line]"
523 (get-line (transcoded-port
524 (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
525 (make-transcoder (utf-8-codec))))))
527 (pass-if "transcoded-port [error handling mode = raise]"
528 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
529 (error-handling-mode raise)))
530 (b (open-bytevector-input-port #vu8(255 2 1)))
531 (tp (transcoded-port b t)))
532 ;; FIXME: Should be (guard (c ((i/o-decoding-error? c) #t)) ...).
533 (catch 'encoding-error
540 (pass-if "transcoded-port [error handling mode = replace]"
541 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
542 (error-handling-mode replace)))
543 (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
544 (tp (transcoded-port b t)))
545 (string-suffix? "gnu" (get-line tp)))))