1 ;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
3 ;;;; Copyright (C) 2009 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 bytevector))
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 binary
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 "get-bytevector-n [short]"
56 (let* ((port (open-input-string "GNU Guile"))
57 (bv (get-bytevector-n port 4)))
59 (equal? (bytevector->u8-list bv)
60 (map char->integer (string->list "GNU "))))))
62 (pass-if "get-bytevector-n [long]"
63 (let* ((port (open-input-string "GNU Guile"))
64 (bv (get-bytevector-n port 256)))
66 (equal? (bytevector->u8-list bv)
67 (map char->integer (string->list "GNU Guile"))))))
69 (pass-if-exception "get-bytevector-n with closed port"
70 exception:wrong-type-arg
72 (let ((port (%make-void-port "r")))
75 (get-bytevector-n port 3)))
77 (pass-if "get-bytevector-n! [short]"
78 (let* ((port (open-input-string "GNU Guile"))
79 (bv (make-bytevector 4))
80 (read (get-bytevector-n! port bv 0 4)))
82 (equal? (bytevector->u8-list bv)
83 (map char->integer (string->list "GNU "))))))
85 (pass-if "get-bytevector-n! [long]"
86 (let* ((str "GNU Guile")
87 (port (open-input-string str))
88 (bv (make-bytevector 256))
89 (read (get-bytevector-n! port bv 0 256)))
90 (and (equal? read (string-length str))
91 (equal? (map (lambda (i)
92 (bytevector-u8-ref bv i))
94 (map char->integer (string->list str))))))
96 (pass-if "get-bytevector-some [simple]"
97 (let* ((str "GNU Guile")
98 (port (open-input-string str))
99 (bv (get-bytevector-some port)))
100 (and (bytevector? bv)
101 (equal? (bytevector->u8-list bv)
102 (map char->integer (string->list str))))))
104 (pass-if "get-bytevector-some [only-some]"
105 (let* ((str "GNU Guile")
107 (port (make-soft-port
110 (if (>= index (string-length str))
112 (let ((c (string-ref str index)))
113 (set! index (+ index 1))
117 ;; Number of readily available octets: falls to
118 ;; zero after 4 octets have been read.
119 (- 4 (modulo index 5))))
121 (bv (get-bytevector-some port)))
122 (and (bytevector? bv)
124 (= (bytevector-length bv) index)
125 (equal? (bytevector->u8-list bv)
126 (map char->integer (string->list "GNU "))))))
128 (pass-if "get-bytevector-all"
129 (let* ((str "GNU Guile")
131 (port (make-soft-port
134 (if (>= index (string-length str))
136 (let ((c (string-ref str index)))
137 (set! index (+ index 1))
142 ;; Number of readily available octets: falls to
143 ;; zero after 4 octets have been read and then
146 (- (string-length str) index)
147 (- 4 (modulo index 5)))))
148 (if (= 0 a) (set! cont? #t))
151 (bv (get-bytevector-all port)))
152 (and (bytevector? bv)
153 (= index (string-length str))
154 (= (bytevector-length bv) (string-length str))
155 (equal? (bytevector->u8-list bv)
156 (map char->integer (string->list str)))))))
159 (define (make-soft-output-port)
160 (let* ((bv (make-bytevector 1024))
163 (write-char (lambda (chr)
164 (bytevector-u8-set! bv write-index
166 (set! write-index (+ 1 write-index)))))
169 (lambda (str) ;; write-string
170 (for-each write-char (string->list str)))
171 (lambda () #t) ;; flush-output
172 (lambda () ;; read-char
173 (if (>= read-index (bytevector-length bv))
175 (let ((c (bytevector-u8-ref bv read-index)))
176 (set! read-index (+ read-index 1))
178 (lambda () #t)) ;; close-port
181 (with-test-prefix "7.2.11 Binary Output"
184 (let ((port (make-soft-output-port)))
186 (equal? (get-u8 port) 77)))
188 (pass-if "put-bytevector [2 args]"
189 (let ((port (make-soft-output-port))
190 (bv (make-bytevector 256)))
191 (put-bytevector port bv)
192 (equal? (bytevector->u8-list bv)
194 (get-bytevector-n port (bytevector-length bv))))))
196 (pass-if "put-bytevector [3 args]"
197 (let ((port (make-soft-output-port))
198 (bv (make-bytevector 256))
200 (put-bytevector port bv start)
201 (equal? (drop (bytevector->u8-list bv) start)
203 (get-bytevector-n port (- (bytevector-length bv) start))))))
205 (pass-if "put-bytevector [4 args]"
206 (let ((port (make-soft-output-port))
207 (bv (make-bytevector 256))
210 (put-bytevector port bv start count)
211 (equal? (take (drop (bytevector->u8-list bv) start) count)
213 (get-bytevector-n port count)))))
215 (pass-if-exception "put-bytevector with closed port"
216 exception:wrong-type-arg
218 (let* ((bv (make-bytevector 4))
219 (port (%make-void-port "w")))
222 (put-bytevector port bv))))
225 (with-test-prefix "7.2.7 Input Ports"
227 ;; This section appears here so that it can use the binary input
230 (pass-if "open-bytevector-input-port [1 arg]"
231 (let* ((str "Hello Port!")
232 (bv (u8-list->bytevector (map char->integer
233 (string->list str))))
234 (port (open-bytevector-input-port bv))
237 (let loop ((chr (read-char port))
239 (if (eof-object? chr)
240 (apply string (reverse! result))
241 (loop (read-char port)
242 (cons chr result)))))))
244 (equal? (read-to-string port) str)))
246 (pass-if-exception "bytevector-input-port is read-only"
247 exception:wrong-type-arg
249 (let* ((str "Hello Port!")
250 (bv (u8-list->bytevector (map char->integer
251 (string->list str))))
252 (port (open-bytevector-input-port bv #f)))
254 (write "hello" port)))
256 (pass-if "bytevector input port supports seeking"
257 (let* ((str "Hello Port!")
258 (bv (u8-list->bytevector (map char->integer
259 (string->list str))))
260 (port (open-bytevector-input-port bv #f)))
262 (and (port-has-port-position? port)
263 (= 0 (port-position port))
264 (port-has-set-port-position!? port)
266 (set-port-position! port 6)
267 (= 6 (port-position port)))
268 (bytevector=? (get-bytevector-all port)
270 (map char->integer (string->list "Port!")))))))
272 (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
273 exception:wrong-num-args
275 ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
277 (make-custom-binary-input-port "port" (lambda args #t)))
279 (pass-if "make-custom-binary-input-port"
280 (let* ((source (make-bytevector 7777))
282 (len (bytevector-length source)))
283 (lambda (bv start count)
284 (let ((amount (min count (- len pos))))
286 (bytevector-copy! source pos
288 (set! pos (+ pos amount))
290 (port (make-custom-binary-input-port "the port" read!
293 (bytevector=? (get-bytevector-all port) source)))
295 (pass-if "custom binary input port does not support `port-position'"
296 (let* ((str "Hello Port!")
297 (source (open-bytevector-input-port
299 (map char->integer (string->list str)))))
300 (read! (lambda (bv start count)
301 (let ((r (get-bytevector-n! source bv start count)))
305 (port (make-custom-binary-input-port "the port" read!
307 (not (or (port-has-port-position? port)
308 (port-has-set-port-position!? port)))))
310 (pass-if "custom binary input port supports `port-position'"
311 (let* ((str "Hello Port!")
312 (source (open-bytevector-input-port
314 (map char->integer (string->list str)))))
315 (read! (lambda (bv start count)
316 (let ((r (get-bytevector-n! source bv start count)))
321 (port-position source)))
322 (set-pos! (lambda (pos)
323 (set-port-position! source pos)))
324 (port (make-custom-binary-input-port "the port" read!
325 get-pos set-pos! #f)))
327 (and (port-has-port-position? port)
328 (= 0 (port-position port))
329 (port-has-set-port-position!? port)
331 (set-port-position! port 6)
332 (= 6 (port-position port)))
333 (bytevector=? (get-bytevector-all port)
335 (map char->integer (string->list "Port!")))))))
337 (pass-if "custom binary input port `close-proc' is called"
339 (read! (lambda (bv start count) 0))
340 (get-pos (lambda () 0))
341 (set-pos! (lambda (pos) #f))
342 (close! (lambda () (set! closed? #t)))
343 (port (make-custom-binary-input-port "the port" read!
348 (gc) ; Test for marking a closed port.
352 (with-test-prefix "8.2.10 Output ports"
354 (pass-if "open-bytevector-output-port"
355 (let-values (((port get-content)
356 (open-bytevector-output-port #f)))
357 (let ((source (make-bytevector 7777)))
358 (put-bytevector port source)
359 (and (bytevector=? (get-content) source)
360 (bytevector=? (get-content) (make-bytevector 0))))))
362 (pass-if "open-bytevector-output-port [put-u8]"
363 (let-values (((port get-content)
364 (open-bytevector-output-port)))
366 (and (bytevector=? (get-content) (make-bytevector 1 77))
367 (bytevector=? (get-content) (make-bytevector 0)))))
369 (pass-if "open-bytevector-output-port [display]"
370 (let-values (((port get-content)
371 (open-bytevector-output-port)))
372 (display "hello" port)
373 (and (bytevector=? (get-content) (string->utf8 "hello"))
374 (bytevector=? (get-content) (make-bytevector 0)))))
376 (pass-if "bytevector output port supports `port-position'"
377 (let-values (((port get-content)
378 (open-bytevector-output-port)))
379 (let ((source (make-bytevector 7777))
380 (overwrite (make-bytevector 33)))
381 (and (port-has-port-position? port)
382 (port-has-set-port-position!? port)
384 (put-bytevector port source)
385 (= (bytevector-length source)
386 (port-position port)))
388 (set-port-position! port 10)
389 (= 10 (port-position port)))
391 (put-bytevector port overwrite)
392 (bytevector-copy! overwrite 0 source 10
393 (bytevector-length overwrite))
394 (= (port-position port)
395 (+ 10 (bytevector-length overwrite))))
396 (bytevector=? (get-content) source)
397 (bytevector=? (get-content) (make-bytevector 0))))))
399 (pass-if "make-custom-binary-output"
400 (let ((port (make-custom-binary-output-port "cbop"
403 (and (output-port? port)
405 (not (port-has-port-position? port))
406 (not (port-has-set-port-position!? port)))))
408 (pass-if "make-custom-binary-output-port [partial writes]"
409 (let* ((source (uint-list->bytevector (iota 333)
410 (native-endianness) 2))
411 (sink (make-bytevector (bytevector-length source)))
414 (write! (lambda (bv start count)
419 (let ((u8 (bytevector-u8-ref bv start)))
420 ;; Get one byte at a time.
421 (bytevector-u8-set! sink sink-pos u8)
422 (set! sink-pos (+ 1 sink-pos))
424 (port (make-custom-binary-output-port "cbop" write!
426 (put-bytevector port source)
427 (and (= sink-pos (bytevector-length source))
429 (bytevector=? sink source))))
431 (pass-if "make-custom-binary-output-port [full writes]"
432 (let* ((source (uint-list->bytevector (iota 333)
433 (native-endianness) 2))
434 (sink (make-bytevector (bytevector-length source)))
437 (write! (lambda (bv start count)
443 (bytevector-copy! bv start
446 (set! sink-pos (+ sink-pos count))
448 (port (make-custom-binary-output-port "cbop" write!
450 (put-bytevector port source)
451 (and (= sink-pos (bytevector-length source))
453 (bytevector=? sink source)))))