1 ;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
2 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
4 ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2, or (at your option)
9 ;;;; any later version.
11 ;;;; This program 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
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this software; see the file COPYING. If not, write to
18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19 ;;;; Boston, MA 02110-1301 USA
21 (define-module (test-suite test-ports)
22 :use-module (test-suite lib)
23 :use-module (test-suite guile-test)
24 :use-module (ice-9 popen)
25 :use-module (ice-9 rdelim))
27 (define (display-line . args)
28 (for-each display args)
32 (data-file-name "ports-test.tmp"))
35 ;;;; Some general utilities for testing ports.
37 ;;; Read from PORT until EOF, and return the result as a string.
38 (define (read-all port)
39 (let loop ((chars '()))
40 (let ((char (read-char port)))
41 (if (eof-object? char)
42 (list->string (reverse! chars))
43 (loop (cons char chars))))))
45 (define (read-file filename)
46 (let* ((port (open-input-file filename))
47 (string (read-all port)))
52 ;;;; Normal file ports.
54 ;;; Write out an s-expression, and read it back.
55 (let ((string '("From fairest creatures we desire increase,"
56 "That thereby beauty's rose might never die,"))
57 (filename (test-file)))
58 (let ((port (open-output-file filename)))
61 (let ((port (open-input-file filename)))
62 (let ((in-string (read port)))
63 (pass-if "file: write and read back list of strings"
64 (equal? string in-string)))
66 (delete-file filename))
68 ;;; Write out a string, and read it back a character at a time.
69 (let ((string "This is a test string\nwith no newline at the end")
70 (filename (test-file)))
71 (let ((port (open-output-file filename)))
74 (let ((in-string (read-file filename)))
75 (pass-if "file: write and read back characters"
76 (equal? string in-string)))
77 (delete-file filename))
79 ;;; Buffered input/output port with seeking.
80 (let* ((filename (test-file))
81 (port (open-file filename "w+")))
82 (display "J'Accuse" port)
83 (seek port -1 SEEK_CUR)
84 (pass-if "file: r/w 1"
85 (char=? (read-char port) #\e))
86 (pass-if "file: r/w 2"
87 (eof-object? (read-char port)))
88 (seek port -1 SEEK_CUR)
90 (seek port 7 SEEK_SET)
91 (pass-if "file: r/w 3"
92 (char=? (read-char port) #\x))
93 (seek port -2 SEEK_END)
94 (pass-if "file: r/w 4"
95 (char=? (read-char port) #\s))
97 (delete-file filename))
99 ;;; Unbuffered input/output port with seeking.
100 (let* ((filename (test-file))
101 (port (open-file filename "w+0")))
102 (display "J'Accuse" port)
103 (seek port -1 SEEK_CUR)
104 (pass-if "file: ub r/w 1"
105 (char=? (read-char port) #\e))
106 (pass-if "file: ub r/w 2"
107 (eof-object? (read-char port)))
108 (seek port -1 SEEK_CUR)
109 (write-char #\x port)
110 (seek port 7 SEEK_SET)
111 (pass-if "file: ub r/w 3"
112 (char=? (read-char port) #\x))
113 (seek port -2 SEEK_END)
114 (pass-if "file: ub r/w 4"
115 (char=? (read-char port) #\s))
117 (delete-file filename))
119 ;;; Buffered output-only and input-only ports with seeking.
120 (let* ((filename (test-file))
121 (port (open-output-file filename)))
122 (display "J'Accuse" port)
123 (pass-if "file: out tell"
124 (= (seek port 0 SEEK_CUR) 8))
125 (seek port -1 SEEK_CUR)
126 (write-char #\x port)
128 (let ((iport (open-input-file filename)))
129 (pass-if "file: in tell 0"
130 (= (seek iport 0 SEEK_CUR) 0))
132 (pass-if "file: in tell 1"
133 (= (seek iport 0 SEEK_CUR) 1))
134 (unread-char #\z iport)
135 (pass-if "file: in tell 0 after unread"
136 (= (seek iport 0 SEEK_CUR) 0))
137 (pass-if "file: unread char still there"
138 (char=? (read-char iport) #\z))
139 (seek iport 7 SEEK_SET)
140 (pass-if "file: in last char"
141 (char=? (read-char iport) #\x))
143 (delete-file filename))
145 ;;; unusual characters.
146 (let* ((filename (test-file))
147 (port (open-output-file filename)))
148 (display (string #\nul (integer->char 255) (integer->char 128)
151 (let* ((port (open-input-file filename))
152 (line (read-line port)))
153 (pass-if "file: read back NUL 1"
154 (char=? (string-ref line 0) #\nul))
155 (pass-if "file: read back 255"
156 (char=? (string-ref line 1) (integer->char 255)))
157 (pass-if "file: read back 128"
158 (char=? (string-ref line 2) (integer->char 128)))
159 (pass-if "file: read back NUL 2"
160 (char=? (string-ref line 3) #\nul))
162 (eof-object? (read-char port)))
164 (delete-file filename))
166 ;;; line buffering mode.
167 (let* ((filename (test-file))
168 (port (open-file filename "wl"))
169 (test-string "one line more or less"))
170 (write-line test-string port)
171 (let* ((in-port (open-input-file filename))
172 (line (read-line in-port)))
175 (pass-if "file: line buffering"
176 (string=? line test-string)))
177 (delete-file filename))
179 ;;; ungetting characters and strings.
180 (with-input-from-string "walk on the moon\nmoon"
183 (unread-char #\a (current-input-port))
184 (pass-if "unread-char"
185 (char=? (read-char) #\a))
187 (let ((replacenoid "chicken enchilada"))
188 (unread-char #\newline (current-input-port))
189 (unread-string replacenoid (current-input-port))
190 (pass-if "unread-string"
191 (string=? (read-line) replacenoid)))
192 (pass-if "unread residue"
193 (string=? (read-line) "moon"))))
195 ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
196 ;;; the reading end. try to read a byte: should get EAGAIN or
197 ;;; EWOULDBLOCK error.
200 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
201 (pass-if "non-blocking-I/O"
203 (lambda () (read-char r) #f)
205 (and (eq? key 'system-error)
206 (let ((errno (car (list-ref args 3))))
208 (= errno EWOULDBLOCK))))))))
211 ;;;; Pipe (popen) ports.
213 ;;; Run a command, and read its output.
214 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
215 (in-string (read-all pipe)))
217 (pass-if "pipe: read"
218 (equal? in-string "Howdy there, partner!\n")))
220 ;;; Run a command, send some output to it, and see if it worked.
221 (let* ((filename (test-file))
222 (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
223 (display "Now Jimmy lives on a mushroom cloud\n" pipe)
224 (display "Mommy, why does everybody have a bomb?\n" pipe)
226 (let ((in-string (read-file filename)))
227 (pass-if "pipe: write"
228 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
229 (delete-file filename))
232 ;;;; Void ports. These are so trivial we don't test them.
237 (with-test-prefix "string ports"
239 ;; Write text to a string port.
240 (let* ((string "Howdy there, partner!")
241 (in-string (call-with-output-string
243 (display string port)
245 (pass-if "display text"
246 (equal? in-string (string-append string "\n"))))
248 ;; Write an s-expression to a string port.
249 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
251 (call-with-input-string (call-with-output-string
255 (pass-if "write/read sexpr"
256 (equal? in-sexpr sexpr)))
258 ;; seeking and unreading from an input string.
259 (let ((text "that text didn't look random to me"))
260 (call-with-input-string text
262 (pass-if "input tell 0"
263 (= (seek p 0 SEEK_CUR) 0))
265 (pass-if "input tell 1"
266 (= (seek p 0 SEEK_CUR) 1))
268 (pass-if "input tell back to 0"
269 (= (seek p 0 SEEK_CUR) 0))
270 (pass-if "input ungetted char"
271 (char=? (read-char p) #\x))
273 (pass-if "input seek to end"
274 (= (seek p 0 SEEK_CUR)
275 (string-length text)))
277 (pass-if "input seek to beginning"
278 (= (seek p 0 SEEK_SET) 0))
279 (pass-if "input reread first char"
280 (char=? (read-char p)
281 (string-ref text 0))))))
283 ;; seeking an output string.
284 (let* ((text (string-copy "123456789"))
285 (len (string-length text))
286 (result (call-with-output-string
288 (pass-if "output tell 0"
289 (= (seek p 0 SEEK_CUR) 0))
291 (pass-if "output tell end"
292 (= (seek p 0 SEEK_CUR) len))
293 (pass-if "output seek to beginning"
294 (= (seek p 0 SEEK_SET) 0))
297 (pass-if "output seek to last char"
298 (= (seek p 0 SEEK_CUR)
300 (write-char #\b p)))))
301 (string-set! text 0 #\a)
302 (string-set! text (- len 1) #\b)
303 (pass-if "output check"
304 (string=? text result))))
306 (with-test-prefix "call-with-output-string"
308 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
310 (pass-if-exception "proc closes port" exception:wrong-type-arg
311 (call-with-output-string close-port)))
315 ;;;; Soft ports. No tests implemented yet.
318 ;;;; Generic operations across all port types.
320 (let ((port-loop-temp (test-file)))
322 ;; Return a list of input ports that all return the same text.
323 ;; We map tests over this list.
324 (define (input-port-list text)
326 ;; Create a text file some of the ports will use.
327 (let ((out-port (open-output-file port-loop-temp)))
328 (display text out-port)
329 (close-port out-port))
331 (list (open-input-file port-loop-temp)
332 (open-input-pipe (string-append "cat " port-loop-temp))
333 (call-with-input-string text (lambda (x) x))
334 ;; We don't test soft ports at the moment.
337 (define port-list-names '("file" "pipe" "string"))
339 ;; Test the line counter.
340 (define (test-line-counter text second-line final-column)
341 (with-test-prefix "line counter"
342 (let ((ports (input-port-list text)))
344 (lambda (port port-name)
345 (with-test-prefix port-name
346 (pass-if "at beginning of input"
347 (= (port-line port) 0))
348 (pass-if "read first character"
349 (eqv? (read-char port) #\x))
350 (pass-if "after reading one character"
351 (= (port-line port) 0))
352 (pass-if "read first newline"
353 (eqv? (read-char port) #\newline))
354 (pass-if "after reading first newline char"
355 (= (port-line port) 1))
356 (pass-if "second line read correctly"
357 (equal? (read-line port) second-line))
358 (pass-if "read-line increments line number"
359 (= (port-line port) 2))
360 (pass-if "read-line returns EOF"
363 ((eof-object? (read-line port)) #t)
365 (else (loop (+ i 1))))))
366 (pass-if "line count is 5 at EOF"
367 (= (port-line port) 5))
368 (pass-if "column is correct at EOF"
369 (= (port-column port) final-column))))
370 ports port-list-names)
371 (for-each close-port ports)
372 (delete-file port-loop-temp))))
374 (with-test-prefix "newline"
377 "He who receives an idea from me, receives instruction\n"
378 "himself without lessening mine; as he who lights his\n"
379 "taper at mine, receives light without darkening me.\n"
380 " --- Thomas Jefferson\n")
381 "He who receives an idea from me, receives instruction"
384 (with-test-prefix "no newline"
387 "He who receives an idea from me, receives instruction\n"
388 "himself without lessening mine; as he who lights his\n"
389 "taper at mine, receives light without darkening me.\n"
390 " --- Thomas Jefferson\n"
392 "He who receives an idea from me, receives instruction"
395 ;; Test port-line and port-column for output ports
397 (define (test-output-line-counter text final-column)
398 (with-test-prefix "port-line and port-column for output ports"
399 (let ((port (open-output-string)))
400 (pass-if "at beginning of input"
401 (and (= (port-line port) 0)
402 (= (port-column port) 0)))
403 (write-char #\x port)
404 (pass-if "after writing one character"
405 (and (= (port-line port) 0)
406 (= (port-column port) 1)))
407 (write-char #\newline port)
408 (pass-if "after writing first newline char"
409 (and (= (port-line port) 1)
410 (= (port-column port) 0)))
412 (pass-if "line count is 5 at end"
413 (= (port-line port) 5))
414 (pass-if "column is correct at end"
415 (= (port-column port) final-column)))))
417 (test-output-line-counter
418 (string-append "He who receives an idea from me, receives instruction\n"
419 "himself without lessening mine; as he who lights his\n"
420 "taper at mine, receives light without darkening me.\n"
421 " --- Thomas Jefferson\n"
425 (with-test-prefix "port-column"
427 (with-test-prefix "output"
430 (let ((port (open-output-string)))
432 (= 1 (port-column port))))
435 (let ((port (open-output-string)))
437 (= 0 (port-column port))))
440 (let ((port (open-output-string)))
442 (= 1 (port-column port))))
444 (pass-if "\\x08 backspace"
445 (let ((port (open-output-string)))
446 (display "\x08" port)
447 (= 0 (port-column port))))
449 (pass-if "x\\x08 backspace"
450 (let ((port (open-output-string)))
451 (display "x\x08" port)
452 (= 0 (port-column port))))
455 (let ((port (open-output-string)))
457 (= 0 (port-column port))))
460 (let ((port (open-output-string)))
462 (= 0 (port-column port))))
465 (let ((port (open-output-string)))
467 (= 0 (port-column port))))
470 (let ((port (open-output-string)))
472 (= 0 (port-column port))))
475 (let ((port (open-output-string)))
477 (= 8 (port-column port))))
480 (let ((port (open-output-string)))
482 (= 8 (port-column port)))))
484 (with-test-prefix "input"
487 (let ((port (open-input-string "x")))
488 (while (not (eof-object? (read-char port))))
489 (= 1 (port-column port))))
492 (let ((port (open-input-string "\a")))
493 (while (not (eof-object? (read-char port))))
494 (= 0 (port-column port))))
497 (let ((port (open-input-string "x\a")))
498 (while (not (eof-object? (read-char port))))
499 (= 1 (port-column port))))
501 (pass-if "\\x08 backspace"
502 (let ((port (open-input-string "\x08")))
503 (while (not (eof-object? (read-char port))))
504 (= 0 (port-column port))))
506 (pass-if "x\\x08 backspace"
507 (let ((port (open-input-string "x\x08")))
508 (while (not (eof-object? (read-char port))))
509 (= 0 (port-column port))))
512 (let ((port (open-input-string "\n")))
513 (while (not (eof-object? (read-char port))))
514 (= 0 (port-column port))))
517 (let ((port (open-input-string "x\n")))
518 (while (not (eof-object? (read-char port))))
519 (= 0 (port-column port))))
522 (let ((port (open-input-string "\r")))
523 (while (not (eof-object? (read-char port))))
524 (= 0 (port-column port))))
527 (let ((port (open-input-string "x\r")))
528 (while (not (eof-object? (read-char port))))
529 (= 0 (port-column port))))
532 (let ((port (open-input-string "\t")))
533 (while (not (eof-object? (read-char port))))
534 (= 8 (port-column port))))
537 (let ((port (open-input-string "x\t")))
538 (while (not (eof-object? (read-char port))))
539 (= 8 (port-column port))))))
541 (with-test-prefix "port-line"
543 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
544 ;; scm_t_port actually holds a long; this restricted the range on 64-bit
546 (pass-if "set most-positive-fixnum/2"
547 (let ((n (quotient most-positive-fixnum 2))
548 (port (open-output-string)))
549 (set-port-line! port n)
550 (eqv? n (port-line port)))))
556 (with-test-prefix "port-for-each"
558 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
559 ;; its iterator func if a port was inaccessible in the last gc mark but
560 ;; the lazy sweeping has not yet reached it to remove it from the port
561 ;; table (scm_i_port_table). Provoking those gc conditions is a little
562 ;; tricky, but the following code made it happen in 1.8.2.
563 (pass-if "passing freed cell"
566 ;; clear out the heap
568 ;; allocate cells so the opened ports aren't at the start of the heap
570 (open-input-file "/dev/null")
572 (open-input-file "/dev/null")
573 ;; this gc leaves the above ports unmarked, ie. inaccessible
575 ;; but they're still in the port table, so this sees them
576 (port-for-each (lambda (port)
577 (set! lst (cons port lst))))
578 ;; this forces completion of the sweeping
580 ;; and (if the bug is present) the cells accumulated in LST are now
581 ;; freed cells, which give #f from `port?'
582 (not (memq #f (map port? lst))))))
588 (with-test-prefix "seek"
590 (with-test-prefix "file port"
593 (call-with-output-file (test-file)
595 (display "abcde" port)))
596 (let ((port (open-file (test-file) "r")))
598 (seek port 2 SEEK_CUR)
599 (eqv? #\d (read-char port))))
602 (call-with-output-file (test-file)
604 (display "abcde" port)))
605 (let ((port (open-file (test-file) "r")))
607 (seek port 3 SEEK_SET)
608 (eqv? #\d (read-char port))))
611 (call-with-output-file (test-file)
613 (display "abcde" port)))
614 (let ((port (open-file (test-file) "r")))
616 (seek port -2 SEEK_END)
617 (eqv? #\d (read-char port))))))
623 (with-test-prefix "truncate-file"
625 (pass-if-exception "flonum file" exception:wrong-type-arg
626 (truncate-file 1.0 123))
628 (pass-if-exception "frac file" exception:wrong-type-arg
629 (truncate-file 7/3 123))
631 (with-test-prefix "filename"
633 (pass-if-exception "flonum length" exception:wrong-type-arg
634 (call-with-output-file (test-file)
636 (display "hello" port)))
637 (truncate-file (test-file) 1.0))
640 (call-with-output-file (test-file)
642 (display "hello" port)))
643 (truncate-file (test-file) 1)
644 (eqv? 1 (stat:size (stat (test-file)))))
646 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
647 (call-with-output-file (test-file)
649 (display "hello" port)))
650 (truncate-file (test-file))))
652 (with-test-prefix "file descriptor"
655 (call-with-output-file (test-file)
657 (display "hello" port)))
658 (let ((fd (open-fdes (test-file) O_RDWR)))
661 (eqv? 1 (stat:size (stat (test-file)))))
663 (pass-if "shorten to current pos"
664 (call-with-output-file (test-file)
666 (display "hello" port)))
667 (let ((fd (open-fdes (test-file) O_RDWR)))
671 (eqv? 1 (stat:size (stat (test-file))))))
673 (with-test-prefix "file port"
676 (call-with-output-file (test-file)
678 (display "hello" port)))
679 (let ((port (open-file (test-file) "r+")))
680 (truncate-file port 1))
681 (eqv? 1 (stat:size (stat (test-file)))))
683 (pass-if "shorten to current pos"
684 (call-with-output-file (test-file)
686 (display "hello" port)))
687 (let ((port (open-file (test-file) "r+")))
689 (truncate-file port))
690 (eqv? 1 (stat:size (stat (test-file)))))))
693 ;;;; testing read-delimited and friends
695 (with-test-prefix "read-delimited!"
696 (let ((c (make-string 20 #\!)))
697 (call-with-input-string
701 (read-delimited! "\n" c port 'concat)
702 (pass-if "read-delimited! reads a first line"
703 (string=? c "defdef\n!!!!!!!!!!!!!"))
705 (read-delimited! "\n" c port 'concat 3)
706 (pass-if "read-delimited! reads a first line"
707 (string=? c "defghighi\n!!!!!!!!!!"))))))
712 (call-with-input-string
715 (pass-if "char-ready? returns true on string port"
716 (char-ready? port))))
718 ;;; This segfaults on some versions of Guile. We really should run
719 ;;; the tests in a subprocess...
721 (call-with-input-string
724 (with-input-from-port
727 (pass-if "char-ready? returns true on string port as default port"
731 ;;;; Close current-input-port, and make sure everyone can handle it.
733 (with-test-prefix "closing current-input-port"
734 (for-each (lambda (procedure name)
735 (with-input-from-port
736 (call-with-input-string "foo" (lambda (p) p))
738 (close-port (current-input-port))
739 (pass-if-exception name
740 exception:wrong-type-arg
742 (list read read-char read-line)
743 '("read" "read-char" "read-line")))
745 (delete-file (test-file))