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 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-suite test-ports)
21 :use-module (test-suite lib)
22 :use-module (test-suite guile-test)
23 :use-module (ice-9 popen)
24 :use-module (ice-9 rdelim))
26 (define (display-line . args)
27 (for-each display args)
31 (data-file-name "ports-test.tmp"))
34 ;;;; Some general utilities for testing ports.
36 ;;; Make sure we are set up for 8-bit data
39 ;;; Read from PORT until EOF, and return the result as a string.
40 (define (read-all port)
41 (let loop ((chars '()))
42 (let ((char (read-char port)))
43 (if (eof-object? char)
44 (list->string (reverse! chars))
45 (loop (cons char chars))))))
47 (define (read-file filename)
48 (let* ((port (open-input-file filename))
49 (string (read-all port)))
54 ;;;; Normal file ports.
56 ;;; Write out an s-expression, and read it back.
57 (let ((string '("From fairest creatures we desire increase,"
58 "That thereby beauty's rose might never die,"))
59 (filename (test-file)))
60 (let ((port (open-output-file filename)))
63 (let ((port (open-input-file filename)))
64 (let ((in-string (read port)))
65 (pass-if "file: write and read back list of strings"
66 (equal? string in-string)))
68 (delete-file filename))
70 ;;; Write out a string, and read it back a character at a time.
71 (let ((string "This is a test string\nwith no newline at the end")
72 (filename (test-file)))
73 (let ((port (open-output-file filename)))
76 (let ((in-string (read-file filename)))
77 (pass-if "file: write and read back characters"
78 (equal? string in-string)))
79 (delete-file filename))
81 ;;; Buffered input/output port with seeking.
82 (let* ((filename (test-file))
83 (port (open-file filename "w+")))
84 (display "J'Accuse" port)
85 (seek port -1 SEEK_CUR)
86 (pass-if "file: r/w 1"
87 (char=? (read-char port) #\e))
88 (pass-if "file: r/w 2"
89 (eof-object? (read-char port)))
90 (seek port -1 SEEK_CUR)
92 (seek port 7 SEEK_SET)
93 (pass-if "file: r/w 3"
94 (char=? (read-char port) #\x))
95 (seek port -2 SEEK_END)
96 (pass-if "file: r/w 4"
97 (char=? (read-char port) #\s))
99 (delete-file filename))
101 ;;; Unbuffered input/output port with seeking.
102 (let* ((filename (test-file))
103 (port (open-file filename "w+0")))
104 (display "J'Accuse" port)
105 (seek port -1 SEEK_CUR)
106 (pass-if "file: ub r/w 1"
107 (char=? (read-char port) #\e))
108 (pass-if "file: ub r/w 2"
109 (eof-object? (read-char port)))
110 (seek port -1 SEEK_CUR)
111 (write-char #\x port)
112 (seek port 7 SEEK_SET)
113 (pass-if "file: ub r/w 3"
114 (char=? (read-char port) #\x))
115 (seek port -2 SEEK_END)
116 (pass-if "file: ub r/w 4"
117 (char=? (read-char port) #\s))
119 (delete-file filename))
121 ;;; Buffered output-only and input-only ports with seeking.
122 (let* ((filename (test-file))
123 (port (open-output-file filename)))
124 (display "J'Accuse" port)
125 (pass-if "file: out tell"
126 (= (seek port 0 SEEK_CUR) 8))
127 (seek port -1 SEEK_CUR)
128 (write-char #\x port)
130 (let ((iport (open-input-file filename)))
131 (pass-if "file: in tell 0"
132 (= (seek iport 0 SEEK_CUR) 0))
134 (pass-if "file: in tell 1"
135 (= (seek iport 0 SEEK_CUR) 1))
136 (unread-char #\z iport)
137 (pass-if "file: in tell 0 after unread"
138 (= (seek iport 0 SEEK_CUR) 0))
139 (pass-if "file: unread char still there"
140 (char=? (read-char iport) #\z))
141 (seek iport 7 SEEK_SET)
142 (pass-if "file: in last char"
143 (char=? (read-char iport) #\x))
145 (delete-file filename))
147 ;;; unusual characters.
148 (let* ((filename (test-file))
149 (port (open-output-file filename)))
150 (display (string #\nul (integer->char 255) (integer->char 128)
153 (let* ((port (open-input-file filename))
154 (line (read-line port)))
155 (pass-if "file: read back NUL 1"
156 (char=? (string-ref line 0) #\nul))
157 (pass-if "file: read back 255"
158 (char=? (string-ref line 1) (integer->char 255)))
159 (pass-if "file: read back 128"
160 (char=? (string-ref line 2) (integer->char 128)))
161 (pass-if "file: read back NUL 2"
162 (char=? (string-ref line 3) #\nul))
164 (eof-object? (read-char port)))
166 (delete-file filename))
168 ;;; line buffering mode.
169 (let* ((filename (test-file))
170 (port (open-file filename "wl"))
171 (test-string "one line more or less"))
172 (write-line test-string port)
173 (let* ((in-port (open-input-file filename))
174 (line (read-line in-port)))
177 (pass-if "file: line buffering"
178 (string=? line test-string)))
179 (delete-file filename))
181 ;;; ungetting characters and strings.
182 (with-input-from-string "walk on the moon\nmoon"
185 (unread-char #\a (current-input-port))
186 (pass-if "unread-char"
187 (char=? (read-char) #\a))
189 (let ((replacenoid "chicken enchilada"))
190 (unread-char #\newline (current-input-port))
191 (unread-string replacenoid (current-input-port))
192 (pass-if "unread-string"
193 (string=? (read-line) replacenoid)))
194 (pass-if "unread residue"
195 (string=? (read-line) "moon"))))
197 ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
198 ;;; the reading end. try to read a byte: should get EAGAIN or
199 ;;; EWOULDBLOCK error.
202 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
203 (pass-if "non-blocking-I/O"
205 (lambda () (read-char r) #f)
207 (and (eq? key 'system-error)
208 (let ((errno (car (list-ref args 3))))
210 (= errno EWOULDBLOCK))))))))
213 ;;;; Pipe (popen) ports.
215 ;;; Run a command, and read its output.
216 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
217 (in-string (read-all pipe)))
219 (pass-if "pipe: read"
220 (equal? in-string "Howdy there, partner!\n")))
222 ;;; Run a command, send some output to it, and see if it worked.
223 (let* ((filename (test-file))
224 (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
225 (display "Now Jimmy lives on a mushroom cloud\n" pipe)
226 (display "Mommy, why does everybody have a bomb?\n" pipe)
228 (let ((in-string (read-file filename)))
229 (pass-if "pipe: write"
230 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
231 (delete-file filename))
234 ;;;; Void ports. These are so trivial we don't test them.
239 (with-test-prefix "string ports"
241 ;; Write text to a string port.
242 (let* ((string "Howdy there, partner!")
243 (in-string (call-with-output-string
245 (display string port)
247 (pass-if "display text"
248 (equal? in-string (string-append string "\n"))))
250 ;; Write an s-expression to a string port.
251 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
253 (call-with-input-string (call-with-output-string
257 (pass-if "write/read sexpr"
258 (equal? in-sexpr sexpr)))
260 ;; seeking and unreading from an input string.
261 (let ((text "that text didn't look random to me"))
262 (call-with-input-string text
264 (pass-if "input tell 0"
265 (= (seek p 0 SEEK_CUR) 0))
267 (pass-if "input tell 1"
268 (= (seek p 0 SEEK_CUR) 1))
270 (pass-if "input tell back to 0"
271 (= (seek p 0 SEEK_CUR) 0))
272 (pass-if "input ungetted char"
273 (char=? (read-char p) #\x))
275 (pass-if "input seek to end"
276 (= (seek p 0 SEEK_CUR)
277 (string-length text)))
279 (pass-if "input seek to beginning"
280 (= (seek p 0 SEEK_SET) 0))
281 (pass-if "input reread first char"
282 (char=? (read-char p)
283 (string-ref text 0))))))
285 ;; seeking an output string.
286 (let* ((text (string-copy "123456789"))
287 (len (string-length text))
288 (result (call-with-output-string
290 (pass-if "output tell 0"
291 (= (seek p 0 SEEK_CUR) 0))
293 (pass-if "output tell end"
294 (= (seek p 0 SEEK_CUR) len))
295 (pass-if "output seek to beginning"
296 (= (seek p 0 SEEK_SET) 0))
299 (pass-if "output seek to last char"
300 (= (seek p 0 SEEK_CUR)
302 (write-char #\b p)))))
303 (string-set! text 0 #\a)
304 (string-set! text (- len 1) #\b)
305 (pass-if "output check"
306 (string=? text result))))
308 (with-test-prefix "call-with-output-string"
310 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
312 (pass-if-exception "proc closes port" exception:wrong-type-arg
313 (call-with-output-string close-port)))
317 ;;;; Soft ports. No tests implemented yet.
320 ;;;; Generic operations across all port types.
322 (let ((port-loop-temp (test-file)))
324 ;; Return a list of input ports that all return the same text.
325 ;; We map tests over this list.
326 (define (input-port-list text)
328 ;; Create a text file some of the ports will use.
329 (let ((out-port (open-output-file port-loop-temp)))
330 (display text out-port)
331 (close-port out-port))
333 (list (open-input-file port-loop-temp)
334 (open-input-pipe (string-append "cat " port-loop-temp))
335 (call-with-input-string text (lambda (x) x))
336 ;; We don't test soft ports at the moment.
339 (define port-list-names '("file" "pipe" "string"))
341 ;; Test the line counter.
342 (define (test-line-counter text second-line final-column)
343 (with-test-prefix "line counter"
344 (let ((ports (input-port-list text)))
346 (lambda (port port-name)
347 (with-test-prefix port-name
348 (pass-if "at beginning of input"
349 (= (port-line port) 0))
350 (pass-if "read first character"
351 (eqv? (read-char port) #\x))
352 (pass-if "after reading one character"
353 (= (port-line port) 0))
354 (pass-if "read first newline"
355 (eqv? (read-char port) #\newline))
356 (pass-if "after reading first newline char"
357 (= (port-line port) 1))
358 (pass-if "second line read correctly"
359 (equal? (read-line port) second-line))
360 (pass-if "read-line increments line number"
361 (= (port-line port) 2))
362 (pass-if "read-line returns EOF"
365 ((eof-object? (read-line port)) #t)
367 (else (loop (+ i 1))))))
368 (pass-if "line count is 5 at EOF"
369 (= (port-line port) 5))
370 (pass-if "column is correct at EOF"
371 (= (port-column port) final-column))))
372 ports port-list-names)
373 (for-each close-port ports)
374 (delete-file port-loop-temp))))
376 (with-test-prefix "newline"
379 "He who receives an idea from me, receives instruction\n"
380 "himself without lessening mine; as he who lights his\n"
381 "taper at mine, receives light without darkening me.\n"
382 " --- Thomas Jefferson\n")
383 "He who receives an idea from me, receives instruction"
386 (with-test-prefix "no newline"
389 "He who receives an idea from me, receives instruction\n"
390 "himself without lessening mine; as he who lights his\n"
391 "taper at mine, receives light without darkening me.\n"
392 " --- Thomas Jefferson\n"
394 "He who receives an idea from me, receives instruction"
397 ;; Test port-line and port-column for output ports
399 (define (test-output-line-counter text final-column)
400 (with-test-prefix "port-line and port-column for output ports"
401 (let ((port (open-output-string)))
402 (pass-if "at beginning of input"
403 (and (= (port-line port) 0)
404 (= (port-column port) 0)))
405 (write-char #\x port)
406 (pass-if "after writing one character"
407 (and (= (port-line port) 0)
408 (= (port-column port) 1)))
409 (write-char #\newline port)
410 (pass-if "after writing first newline char"
411 (and (= (port-line port) 1)
412 (= (port-column port) 0)))
414 (pass-if "line count is 5 at end"
415 (= (port-line port) 5))
416 (pass-if "column is correct at end"
417 (= (port-column port) final-column)))))
419 (test-output-line-counter
420 (string-append "He who receives an idea from me, receives instruction\n"
421 "himself without lessening mine; as he who lights his\n"
422 "taper at mine, receives light without darkening me.\n"
423 " --- Thomas Jefferson\n"
427 (with-test-prefix "port-column"
429 (with-test-prefix "output"
432 (let ((port (open-output-string)))
434 (= 1 (port-column port))))
437 (let ((port (open-output-string)))
439 (= 0 (port-column port))))
442 (let ((port (open-output-string)))
444 (= 1 (port-column port))))
446 (pass-if "\\x08 backspace"
447 (let ((port (open-output-string)))
448 (display "\x08" port)
449 (= 0 (port-column port))))
451 (pass-if "x\\x08 backspace"
452 (let ((port (open-output-string)))
453 (display "x\x08" port)
454 (= 0 (port-column port))))
457 (let ((port (open-output-string)))
459 (= 0 (port-column port))))
462 (let ((port (open-output-string)))
464 (= 0 (port-column port))))
467 (let ((port (open-output-string)))
469 (= 0 (port-column port))))
472 (let ((port (open-output-string)))
474 (= 0 (port-column port))))
477 (let ((port (open-output-string)))
479 (= 8 (port-column port))))
482 (let ((port (open-output-string)))
484 (= 8 (port-column port)))))
486 (with-test-prefix "input"
489 (let ((port (open-input-string "x")))
490 (while (not (eof-object? (read-char port))))
491 (= 1 (port-column port))))
494 (let ((port (open-input-string "\a")))
495 (while (not (eof-object? (read-char port))))
496 (= 0 (port-column port))))
499 (let ((port (open-input-string "x\a")))
500 (while (not (eof-object? (read-char port))))
501 (= 1 (port-column port))))
503 (pass-if "\\x08 backspace"
504 (let ((port (open-input-string "\x08")))
505 (while (not (eof-object? (read-char port))))
506 (= 0 (port-column port))))
508 (pass-if "x\\x08 backspace"
509 (let ((port (open-input-string "x\x08")))
510 (while (not (eof-object? (read-char port))))
511 (= 0 (port-column port))))
514 (let ((port (open-input-string "\n")))
515 (while (not (eof-object? (read-char port))))
516 (= 0 (port-column port))))
519 (let ((port (open-input-string "x\n")))
520 (while (not (eof-object? (read-char port))))
521 (= 0 (port-column port))))
524 (let ((port (open-input-string "\r")))
525 (while (not (eof-object? (read-char port))))
526 (= 0 (port-column port))))
529 (let ((port (open-input-string "x\r")))
530 (while (not (eof-object? (read-char port))))
531 (= 0 (port-column port))))
534 (let ((port (open-input-string "\t")))
535 (while (not (eof-object? (read-char port))))
536 (= 8 (port-column port))))
539 (let ((port (open-input-string "x\t")))
540 (while (not (eof-object? (read-char port))))
541 (= 8 (port-column port))))))
543 (with-test-prefix "port-line"
545 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
546 ;; scm_t_port actually holds a long; this restricted the range on 64-bit
548 (pass-if "set most-positive-fixnum/2"
549 (let ((n (quotient most-positive-fixnum 2))
550 (port (open-output-string)))
551 (set-port-line! port n)
552 (eqv? n (port-line port)))))
558 (with-test-prefix "port-for-each"
560 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
561 ;; its iterator func if a port was inaccessible in the last gc mark but
562 ;; the lazy sweeping has not yet reached it to remove it from the port
563 ;; table (scm_i_port_table). Provoking those gc conditions is a little
564 ;; tricky, but the following code made it happen in 1.8.2.
565 (pass-if "passing freed cell"
567 ;; clear out the heap
569 ;; allocate cells so the opened ports aren't at the start of the heap
571 (open-input-file "/dev/null")
573 (open-input-file "/dev/null")
574 ;; this gc leaves the above ports unmarked, ie. inaccessible
576 ;; but they're still in the port table, so this sees them
577 (port-for-each (lambda (port)
578 (set! lst (cons port lst))))
579 ;; this forces completion of the sweeping
581 ;; and (if the bug is present) the cells accumulated in LST are now
582 ;; freed cells, which give #f from `port?'
583 (not (memq #f (map port? lst))))))
587 (pass-if "fdes->ports finds port"
588 (let ((port (open-file (test-file) "w")))
590 (not (not (memq port (fdes->ports (port->fdes port))))))))
596 (with-test-prefix "seek"
598 (with-test-prefix "file port"
601 (call-with-output-file (test-file)
603 (display "abcde" port)))
604 (let ((port (open-file (test-file) "r")))
606 (seek port 2 SEEK_CUR)
607 (eqv? #\d (read-char port))))
610 (call-with-output-file (test-file)
612 (display "abcde" port)))
613 (let ((port (open-file (test-file) "r")))
615 (seek port 3 SEEK_SET)
616 (eqv? #\d (read-char port))))
619 (call-with-output-file (test-file)
621 (display "abcde" port)))
622 (let ((port (open-file (test-file) "r")))
624 (seek port -2 SEEK_END)
625 (eqv? #\d (read-char port))))))
631 (with-test-prefix "truncate-file"
633 (pass-if-exception "flonum file" exception:wrong-type-arg
634 (truncate-file 1.0 123))
636 (pass-if-exception "frac file" exception:wrong-type-arg
637 (truncate-file 7/3 123))
639 (with-test-prefix "filename"
641 (pass-if-exception "flonum length" exception:wrong-type-arg
642 (call-with-output-file (test-file)
644 (display "hello" port)))
645 (truncate-file (test-file) 1.0))
648 (call-with-output-file (test-file)
650 (display "hello" port)))
651 (truncate-file (test-file) 1)
652 (eqv? 1 (stat:size (stat (test-file)))))
654 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
655 (call-with-output-file (test-file)
657 (display "hello" port)))
658 (truncate-file (test-file))))
660 (with-test-prefix "file descriptor"
663 (call-with-output-file (test-file)
665 (display "hello" port)))
666 (let ((fd (open-fdes (test-file) O_RDWR)))
669 (eqv? 1 (stat:size (stat (test-file)))))
671 (pass-if "shorten to current pos"
672 (call-with-output-file (test-file)
674 (display "hello" port)))
675 (let ((fd (open-fdes (test-file) O_RDWR)))
679 (eqv? 1 (stat:size (stat (test-file))))))
681 (with-test-prefix "file port"
684 (call-with-output-file (test-file)
686 (display "hello" port)))
687 (let ((port (open-file (test-file) "r+")))
688 (truncate-file port 1))
689 (eqv? 1 (stat:size (stat (test-file)))))
691 (pass-if "shorten to current pos"
692 (call-with-output-file (test-file)
694 (display "hello" port)))
695 (let ((port (open-file (test-file) "r+")))
697 (truncate-file port))
698 (eqv? 1 (stat:size (stat (test-file)))))))
701 ;;;; testing read-delimited and friends
703 (with-test-prefix "read-delimited!"
704 (let ((c (make-string 20 #\!)))
705 (call-with-input-string
709 (read-delimited! "\n" c port 'concat)
710 (pass-if "read-delimited! reads a first line"
711 (string=? c "defdef\n!!!!!!!!!!!!!"))
713 (read-delimited! "\n" c port 'concat 3)
714 (pass-if "read-delimited! reads a first line"
715 (string=? c "defghighi\n!!!!!!!!!!"))))))
720 (call-with-input-string
723 (pass-if "char-ready? returns true on string port"
724 (char-ready? port))))
726 ;;; This segfaults on some versions of Guile. We really should run
727 ;;; the tests in a subprocess...
729 (call-with-input-string
732 (with-input-from-port
735 (pass-if "char-ready? returns true on string port as default port"
739 ;;;; Close current-input-port, and make sure everyone can handle it.
741 (with-test-prefix "closing current-input-port"
742 (for-each (lambda (procedure name)
743 (with-input-from-port
744 (call-with-input-string "foo" (lambda (p) p))
746 (close-port (current-input-port))
747 (pass-if-exception name
748 exception:wrong-type-arg
750 (list read read-char read-line)
751 '("read" "read-char" "read-line")))
753 (delete-file (test-file))