1 ;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
2 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
4 ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
5 ;;;; 2011, 2012 Free Software Foundation, Inc.
7 ;;;; This library is free software; you can redistribute it and/or
8 ;;;; modify it under the terms of the GNU Lesser General Public
9 ;;;; License as published by the Free Software Foundation; either
10 ;;;; version 3 of the License, or (at your option) any later version.
12 ;;;; This library is distributed in the hope that it will be useful,
13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;;; Lesser General Public License for more details.
17 ;;;; You should have received a copy of the GNU Lesser General Public
18 ;;;; License along with this library; if not, write to the Free Software
19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, 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)
26 #:use-module (rnrs bytevectors)
27 #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)))
29 (define (display-line . args)
30 (for-each display args)
34 (data-file-name "ports-test.tmp"))
37 ;;;; Some general utilities for testing ports.
39 ;; Make sure we are set up for 8-bit Latin-1 data.
40 (fluid-set! %default-port-encoding "ISO-8859-1")
42 (set-port-encoding! p (fluid-ref %default-port-encoding)))
43 (list (current-input-port) (current-output-port)
44 (current-error-port)))
46 ;;; Read from PORT until EOF, and return the result as a string.
47 (define (read-all port)
48 (let loop ((chars '()))
49 (let ((char (read-char port)))
50 (if (eof-object? char)
51 (list->string (reverse! chars))
52 (loop (cons char chars))))))
54 (define (read-file filename)
55 (let* ((port (open-input-file filename))
56 (string (read-all port)))
61 ;;;; Normal file ports.
63 ;;; Write out an s-expression, and read it back.
64 (let ((string '("From fairest creatures we desire increase,"
65 "That thereby beauty's rose might never die,"))
66 (filename (test-file)))
67 (let ((port (open-output-file filename)))
70 (let ((port (open-input-file filename)))
71 (let ((in-string (read port)))
72 (pass-if "file: write and read back list of strings"
73 (equal? string in-string)))
75 (delete-file filename))
77 ;;; Write out a string, and read it back a character at a time.
78 (let ((string "This is a test string\nwith no newline at the end")
79 (filename (test-file)))
80 (let ((port (open-output-file filename)))
83 (let ((in-string (read-file filename)))
84 (pass-if "file: write and read back characters"
85 (equal? string in-string)))
86 (delete-file filename))
88 ;;; Buffered input/output port with seeking.
89 (let* ((filename (test-file))
90 (port (open-file filename "w+")))
91 (display "J'Accuse" port)
92 (seek port -1 SEEK_CUR)
93 (pass-if "file: r/w 1"
94 (char=? (read-char port) #\e))
95 (pass-if "file: r/w 2"
96 (eof-object? (read-char port)))
97 (seek port -1 SEEK_CUR)
99 (seek port 7 SEEK_SET)
100 (pass-if "file: r/w 3"
101 (char=? (read-char port) #\x))
102 (seek port -2 SEEK_END)
103 (pass-if "file: r/w 4"
104 (char=? (read-char port) #\s))
106 (delete-file filename))
108 ;;; Unbuffered input/output port with seeking.
109 (let* ((filename (test-file))
110 (port (open-file filename "w+0")))
111 (display "J'Accuse" port)
112 (seek port -1 SEEK_CUR)
113 (pass-if "file: ub r/w 1"
114 (char=? (read-char port) #\e))
115 (pass-if "file: ub r/w 2"
116 (eof-object? (read-char port)))
117 (seek port -1 SEEK_CUR)
118 (write-char #\x port)
119 (seek port 7 SEEK_SET)
120 (pass-if "file: ub r/w 3"
121 (char=? (read-char port) #\x))
122 (seek port -2 SEEK_END)
123 (pass-if "file: ub r/w 4"
124 (char=? (read-char port) #\s))
126 (delete-file filename))
128 ;;; Buffered output-only and input-only ports with seeking.
129 (let* ((filename (test-file))
130 (port (open-output-file filename)))
131 (display "J'Accuse" port)
132 (pass-if "file: out tell"
133 (= (seek port 0 SEEK_CUR) 8))
134 (seek port -1 SEEK_CUR)
135 (write-char #\x port)
137 (let ((iport (open-input-file filename)))
138 (pass-if "file: in tell 0"
139 (= (seek iport 0 SEEK_CUR) 0))
141 (pass-if "file: in tell 1"
142 (= (seek iport 0 SEEK_CUR) 1))
143 (unread-char #\z iport)
144 (pass-if "file: in tell 0 after unread"
145 (= (seek iport 0 SEEK_CUR) 0))
146 (pass-if "file: unread char still there"
147 (char=? (read-char iport) #\z))
148 (seek iport 7 SEEK_SET)
149 (pass-if "file: in last char"
150 (char=? (read-char iport) #\x))
152 (delete-file filename))
154 ;;; unusual characters.
155 (let* ((filename (test-file))
156 (port (open-output-file filename)))
157 (display (string #\nul (integer->char 255) (integer->char 128)
160 (let* ((port (open-input-file filename))
161 (line (read-line port)))
162 (pass-if "file: read back NUL 1"
163 (char=? (string-ref line 0) #\nul))
164 (pass-if "file: read back 255"
165 (char=? (string-ref line 1) (integer->char 255)))
166 (pass-if "file: read back 128"
167 (char=? (string-ref line 2) (integer->char 128)))
168 (pass-if "file: read back NUL 2"
169 (char=? (string-ref line 3) #\nul))
171 (eof-object? (read-char port)))
173 (delete-file filename))
175 ;;; line buffering mode.
176 (let* ((filename (test-file))
177 (port (open-file filename "wl"))
178 (test-string "one line more or less"))
179 (write-line test-string port)
180 (let* ((in-port (open-input-file filename))
181 (line (read-line in-port)))
184 (pass-if "file: line buffering"
185 (string=? line test-string)))
186 (delete-file filename))
188 ;;; read-line should use the port encoding (not the locale encoding).
189 (let ((str "ĉu bone?"))
191 (let* ((filename (test-file))
192 (port (open-file filename "wl")))
193 (set-port-encoding! port "UTF-8")
194 (write-line str port)
195 (let ((in-port (open-input-file filename)))
196 (set-port-encoding! in-port "UTF-8")
197 (let ((line (read-line in-port)))
200 (pass-if "file: read-line honors port encoding"
201 (string=? line str))))
202 (delete-file filename))))
204 ;;; binary mode ignores port encoding
205 (pass-if "file: binary mode ignores port encoding"
206 (with-fluids ((%default-port-encoding "UTF-8"))
207 (let* ((filename (test-file))
208 (port (open-file filename "w"))
213 (uniform-vector->list
214 (string->utf8 test-string))))))
215 (write-line test-string port)
217 (let* ((in-port (open-file filename "rb"))
218 (line (read-line in-port)))
220 (delete-file filename)
221 (string=? line binary-test-string)))))
223 ;;; binary mode ignores file coding declaration
224 (pass-if "file: binary mode ignores file coding declaration"
225 (with-fluids ((%default-port-encoding "UTF-8"))
226 (let* ((filename (test-file))
227 (port (open-file filename "w"))
232 (uniform-vector->list
233 (string->utf8 test-string))))))
234 (write-line ";; coding: utf-8" port)
235 (write-line test-string port)
237 (let* ((in-port (open-file filename "rb"))
238 (line1 (read-line in-port))
239 (line2 (read-line in-port)))
241 (delete-file filename)
242 (string=? line2 binary-test-string)))))
244 ;; open-file honors file coding declarations
245 (pass-if "file: open-file honors coding declarations"
246 (with-fluids ((%default-port-encoding "UTF-8"))
247 (let* ((filename (test-file))
248 (port (open-output-file filename))
249 (test-string "€100"))
250 (set-port-encoding! port "ISO-8859-15")
251 (write-line ";; coding: iso-8859-15" port)
252 (write-line test-string port)
254 (let* ((in-port (open-input-file filename))
255 (line1 (read-line in-port))
256 (line2 (read-line in-port)))
258 (delete-file filename)
259 (string=? line2 test-string)))))
261 ;;; ungetting characters and strings.
262 (with-input-from-string "walk on the moon\nmoon"
265 (unread-char #\a (current-input-port))
266 (pass-if "unread-char"
267 (char=? (read-char) #\a))
269 (let ((replacenoid "chicken enchilada"))
270 (unread-char #\newline (current-input-port))
271 (unread-string replacenoid (current-input-port))
272 (pass-if "unread-string"
273 (string=? (read-line) replacenoid)))
274 (pass-if "unread residue"
275 (string=? (read-line) "moon"))))
277 ;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
278 ;;; the reading end. try to read a byte: should get EAGAIN or
279 ;;; EWOULDBLOCK error.
282 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
283 (pass-if "non-blocking-I/O"
285 (lambda () (read-char r) #f)
287 (and (eq? key 'system-error)
288 (let ((errno (car (list-ref args 3))))
290 (= errno EWOULDBLOCK))))))))
293 ;;;; Pipe (popen) ports.
295 ;;; Run a command, and read its output.
296 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
297 (in-string (read-all pipe)))
299 (pass-if "pipe: read"
300 (equal? in-string "Howdy there, partner!\n")))
302 ;;; Run a command, send some output to it, and see if it worked.
303 (let* ((filename (test-file))
304 (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
305 (display "Now Jimmy lives on a mushroom cloud\n" pipe)
306 (display "Mommy, why does everybody have a bomb?\n" pipe)
308 (let ((in-string (read-file filename)))
309 (pass-if "pipe: write"
310 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
311 (delete-file filename))
314 ;;;; Void ports. These are so trivial we don't test them.
319 (with-test-prefix "string ports"
321 ;; Write text to a string port.
322 (let* ((string "Howdy there, partner!")
323 (in-string (call-with-output-string
325 (display string port)
327 (pass-if "display text"
328 (equal? in-string (string-append string "\n"))))
330 ;; Write an s-expression to a string port.
331 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
333 (call-with-input-string (call-with-output-string
337 (pass-if "write/read sexpr"
338 (equal? in-sexpr sexpr)))
340 ;; seeking and unreading from an input string.
341 (let ((text "that text didn't look random to me"))
342 (call-with-input-string text
344 (pass-if "input tell 0"
345 (= (seek p 0 SEEK_CUR) 0))
347 (pass-if "input tell 1"
348 (= (seek p 0 SEEK_CUR) 1))
350 (pass-if "input tell back to 0"
351 (= (seek p 0 SEEK_CUR) 0))
352 (pass-if "input ungetted char"
353 (char=? (read-char p) #\x))
355 (pass-if "input seek to end"
356 (= (seek p 0 SEEK_CUR)
357 (string-length text)))
359 (pass-if "input seek to beginning"
360 (= (seek p 0 SEEK_SET) 0))
361 (pass-if "input reread first char"
362 (char=? (read-char p)
363 (string-ref text 0))))))
365 ;; seeking an output string.
366 (let* ((text (string-copy "123456789"))
367 (len (string-length text))
368 (result (call-with-output-string
370 (pass-if "output tell 0"
371 (= (seek p 0 SEEK_CUR) 0))
373 (pass-if "output tell end"
374 (= (seek p 0 SEEK_CUR) len))
375 (pass-if "output seek to beginning"
376 (= (seek p 0 SEEK_SET) 0))
379 (pass-if "output seek to last char"
380 (= (seek p 0 SEEK_CUR)
382 (write-char #\b p)))))
383 (string-set! text 0 #\a)
384 (string-set! text (- len 1) #\b)
385 (pass-if "output check"
386 (string=? text result)))
388 (pass-if "%default-port-encoding is honored"
389 (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
390 (equal? (map (lambda (e)
391 (with-fluids ((%default-port-encoding e))
392 (call-with-output-string
394 (and (string=? e (port-encoding p))
395 (display (port-encoding p) p))))))
399 (pass-if "suitable encoding [latin-1]"
400 (let ((str "hello, world"))
401 (with-fluids ((%default-port-encoding "ISO-8859-1"))
403 (with-output-to-string
407 (pass-if "suitable encoding [latin-3]"
408 (let ((str "ĉu bone?"))
409 (with-fluids ((%default-port-encoding "ISO-8859-3"))
411 (with-output-to-string
415 (pass-if "wrong encoding"
416 (let ((str "ĉu bone?"))
417 (catch 'encoding-error
419 ;; Latin-1 cannot represent ‘ĉ’.
420 (with-fluids ((%default-port-encoding "ISO-8859-1"))
421 (with-output-to-string
424 (lambda (key subr message errno port chr)
426 (string? (strerror errno)))))))
428 (pass-if "wrong encoding, substitute"
429 (let ((str "ĉu bone?"))
430 (with-fluids ((%default-port-encoding "ISO-8859-1"))
431 (string=? (with-output-to-string
433 (set-port-conversion-strategy! (current-output-port)
438 (pass-if "wrong encoding, escape"
439 (let ((str "ĉu bone?"))
440 (with-fluids ((%default-port-encoding "ISO-8859-1"))
441 (string=? (with-output-to-string
443 (set-port-conversion-strategy! (current-output-port)
448 (pass-if "peek-char [latin-1]"
449 (let ((p (with-fluids ((%default-port-encoding #f))
450 (open-input-string "hello, world"))))
451 (and (char=? (peek-char p) #\h)
452 (char=? (peek-char p) #\h)
453 (char=? (peek-char p) #\h)
455 (= (port-column p) 0))))
457 (pass-if "peek-char [utf-8]"
458 (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
459 (open-input-string "안녕하세요"))))
460 (and (char=? (peek-char p) #\안)
461 (char=? (peek-char p) #\안)
462 (char=? (peek-char p) #\안)
464 (= (port-column p) 0))))
466 (pass-if "peek-char [utf-16]"
467 (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
468 (open-input-string "안녕하세요"))))
469 (and (char=? (peek-char p) #\안)
470 (char=? (peek-char p) #\안)
471 (char=? (peek-char p) #\안)
473 (= (port-column p) 0))))
475 ;; Mini DSL to test decoding error handling.
476 (letrec-syntax ((decoding-error?
479 (catch 'decoding-error
483 (lambda (key subr message errno p)
485 (not (= 0 errno))))))))
487 (syntax-rules (-> error eof)
488 ((_ port (proc -> error))
490 (port-conversion-strategy port))
491 (eq? (proc port) #\?)
492 (decoding-error? port (proc port))))
493 ((_ port (proc -> eof))
494 (eof-object? (proc port)))
495 ((_ port (proc -> char))
496 (eq? (proc port) char))))
500 (and (make-check port check) ...))))
501 (make-peek+read-checks
503 ((_ port (result ...) e1 expected ...)
504 (make-peek+read-checks port
509 ((_ port (result ...))
510 (make-checks port result ...))
511 ((_ port #f e1 expected ...)
512 (make-peek+read-checks port
517 (test-decoding-error*
519 ((_ sequence encoding strategy (expected ...))
521 (pass-if (format #f "test-decoding-error: ~s ~s ~s"
522 'sequence encoding strategy)
523 (let ((p (open-bytevector-input-port
524 (u8-list->bytevector 'sequence))))
525 (set-port-encoding! p encoding)
526 (set-port-conversion-strategy! p strategy)
528 (read-char -> expected) ...)))
530 ;; Generate the same test, but with one
531 ;; `peek-char' call before each `read-char'.
532 ;; Both should yield the same result.
533 (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
534 'sequence encoding strategy)
535 (let ((p (open-bytevector-input-port
536 (u8-list->bytevector 'sequence))))
537 (set-port-encoding! p encoding)
538 (set-port-conversion-strategy! p strategy)
539 (make-peek+read-checks p #f expected
543 ((_ sequence encoding (expected ...))
545 (test-decoding-error* sequence encoding 'error
548 ;; `escape' should behave exactly like `error'.
549 (test-decoding-error* sequence encoding 'escape
552 (test-decoding-error* sequence encoding 'substitute
555 (test-decoding-error (255 65 66 67) "UTF-8"
556 (error #\A #\B #\C eof))
558 (test-decoding-error (255 206 187 206 188) "UTF-8"
561 (test-decoding-error (206 187 206) "UTF-8"
562 ;; Unterminated sequence.
565 ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
566 ;; of the "Conformance" chapter of Unicode 6.0.0.)
568 (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
569 (error ;; C0: should be in the C2..DF range
574 (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
575 ;; Section 3.9 of Unicode 6.0.0 reads:
576 ;; "If the converter encounters an ill-formed UTF-8 code unit
577 ;; sequence which starts with a valid first byte, but which does
578 ;; not continue with valid successor bytes (see Table 3-7), it
579 ;; must not consume the successor bytes".
580 ;; Glibc/libiconv do not conform to it and instead swallow the
581 ;; #x41. This example appears literally in Section 3.9.
582 (error ;; 41: invalid successor
583 #\A ;; 41: valid starting byte
587 (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
588 ;; According to Unicode 6.0.0, Section 3.9, "the only formal
589 ;; requirement mandated by Unicode conformance for a converter is
590 ;; that the <41> be processed and correctly interpreted as
592 (error ;; 2nd byte should be in the A0..BF range
593 error ;; 80: not a valid starting byte
594 error ;; 80: not a valid starting byte
598 (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
599 (error ;; 3rd byte should be in the 80..BF range
604 (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
605 (error ;; 2nd byte should be in the 90..BF range
606 error ;; 88: not a valid starting byte
607 error ;; 88: not a valid starting byte
608 error ;; 88: not a valid starting byte
611 (with-test-prefix "call-with-output-string"
613 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
615 (pass-if-exception "proc closes port" exception:wrong-type-arg
616 (call-with-output-string close-port)))
620 ;;;; Soft ports. No tests implemented yet.
623 ;;;; Generic operations across all port types.
625 (let ((port-loop-temp (test-file)))
627 ;; Return a list of input ports that all return the same text.
628 ;; We map tests over this list.
629 (define (input-port-list text)
631 ;; Create a text file some of the ports will use.
632 (let ((out-port (open-output-file port-loop-temp)))
633 (display text out-port)
634 (close-port out-port))
636 (list (open-input-file port-loop-temp)
637 (open-input-pipe (string-append "cat " port-loop-temp))
638 (call-with-input-string text (lambda (x) x))
639 ;; We don't test soft ports at the moment.
642 (define port-list-names '("file" "pipe" "string"))
644 ;; Test the line counter.
645 (define (test-line-counter text second-line final-column)
646 (with-test-prefix "line counter"
647 (let ((ports (input-port-list text)))
649 (lambda (port port-name)
650 (with-test-prefix port-name
651 (pass-if "at beginning of input"
652 (= (port-line port) 0))
653 (pass-if "read first character"
654 (eqv? (read-char port) #\x))
655 (pass-if "after reading one character"
656 (= (port-line port) 0))
657 (pass-if "read first newline"
658 (eqv? (read-char port) #\newline))
659 (pass-if "after reading first newline char"
660 (= (port-line port) 1))
661 (pass-if "second line read correctly"
662 (equal? (read-line port) second-line))
663 (pass-if "read-line increments line number"
664 (= (port-line port) 2))
665 (pass-if "read-line returns EOF"
668 ((eof-object? (read-line port)) #t)
670 (else (loop (+ i 1))))))
671 (pass-if "line count is 5 at EOF"
672 (= (port-line port) 5))
673 (pass-if "column is correct at EOF"
674 (= (port-column port) final-column))))
675 ports port-list-names)
676 (for-each close-port ports)
677 (delete-file port-loop-temp))))
679 (with-test-prefix "newline"
682 "He who receives an idea from me, receives instruction\n"
683 "himself without lessening mine; as he who lights his\n"
684 "taper at mine, receives light without darkening me.\n"
685 " --- Thomas Jefferson\n")
686 "He who receives an idea from me, receives instruction"
689 (with-test-prefix "no newline"
692 "He who receives an idea from me, receives instruction\n"
693 "himself without lessening mine; as he who lights his\n"
694 "taper at mine, receives light without darkening me.\n"
695 " --- Thomas Jefferson\n"
697 "He who receives an idea from me, receives instruction"
700 ;; Test port-line and port-column for output ports
702 (define (test-output-line-counter text final-column)
703 (with-test-prefix "port-line and port-column for output ports"
704 (let ((port (open-output-string)))
705 (pass-if "at beginning of input"
706 (and (= (port-line port) 0)
707 (= (port-column port) 0)))
708 (write-char #\x port)
709 (pass-if "after writing one character"
710 (and (= (port-line port) 0)
711 (= (port-column port) 1)))
712 (write-char #\newline port)
713 (pass-if "after writing first newline char"
714 (and (= (port-line port) 1)
715 (= (port-column port) 0)))
717 (pass-if "line count is 5 at end"
718 (= (port-line port) 5))
719 (pass-if "column is correct at end"
720 (= (port-column port) final-column)))))
722 (test-output-line-counter
723 (string-append "He who receives an idea from me, receives instruction\n"
724 "himself without lessening mine; as he who lights his\n"
725 "taper at mine, receives light without darkening me.\n"
726 " --- Thomas Jefferson\n"
730 (with-test-prefix "port-column"
732 (with-test-prefix "output"
735 (let ((port (open-output-string)))
737 (= 1 (port-column port))))
740 (let ((port (open-output-string)))
742 (= 0 (port-column port))))
745 (let ((port (open-output-string)))
747 (= 1 (port-column port))))
749 (pass-if "\\x08 backspace"
750 (let ((port (open-output-string)))
751 (display "\x08" port)
752 (= 0 (port-column port))))
754 (pass-if "x\\x08 backspace"
755 (let ((port (open-output-string)))
756 (display "x\x08" port)
757 (= 0 (port-column port))))
760 (let ((port (open-output-string)))
762 (= 0 (port-column port))))
765 (let ((port (open-output-string)))
767 (= 0 (port-column port))))
770 (let ((port (open-output-string)))
772 (= 0 (port-column port))))
775 (let ((port (open-output-string)))
777 (= 0 (port-column port))))
780 (let ((port (open-output-string)))
782 (= 8 (port-column port))))
785 (let ((port (open-output-string)))
787 (= 8 (port-column port)))))
789 (with-test-prefix "input"
792 (let ((port (open-input-string "x")))
793 (while (not (eof-object? (read-char port))))
794 (= 1 (port-column port))))
797 (let ((port (open-input-string "\a")))
798 (while (not (eof-object? (read-char port))))
799 (= 0 (port-column port))))
802 (let ((port (open-input-string "x\a")))
803 (while (not (eof-object? (read-char port))))
804 (= 1 (port-column port))))
806 (pass-if "\\x08 backspace"
807 (let ((port (open-input-string "\x08")))
808 (while (not (eof-object? (read-char port))))
809 (= 0 (port-column port))))
811 (pass-if "x\\x08 backspace"
812 (let ((port (open-input-string "x\x08")))
813 (while (not (eof-object? (read-char port))))
814 (= 0 (port-column port))))
817 (let ((port (open-input-string "\n")))
818 (while (not (eof-object? (read-char port))))
819 (= 0 (port-column port))))
822 (let ((port (open-input-string "x\n")))
823 (while (not (eof-object? (read-char port))))
824 (= 0 (port-column port))))
827 (let ((port (open-input-string "\r")))
828 (while (not (eof-object? (read-char port))))
829 (= 0 (port-column port))))
832 (let ((port (open-input-string "x\r")))
833 (while (not (eof-object? (read-char port))))
834 (= 0 (port-column port))))
837 (let ((port (open-input-string "\t")))
838 (while (not (eof-object? (read-char port))))
839 (= 8 (port-column port))))
842 (let ((port (open-input-string "x\t")))
843 (while (not (eof-object? (read-char port))))
844 (= 8 (port-column port))))))
846 (with-test-prefix "port-line"
848 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
849 ;; scm_t_port actually holds a long; this restricted the range on 64-bit
851 (pass-if "set most-positive-fixnum/2"
852 (let ((n (quotient most-positive-fixnum 2))
853 (port (open-output-string)))
854 (set-port-line! port n)
855 (eqv? n (port-line port)))))
857 (with-test-prefix "port-encoding"
859 (pass-if-exception "set-port-encoding!, wrong encoding"
860 exception:miscellaneous-error
861 (set-port-encoding! (open-input-string "") "does-not-exist"))
863 (pass-if-exception "%default-port-encoding, wrong encoding"
864 exception:miscellaneous-error
865 (read (with-fluids ((%default-port-encoding "does-not-exist"))
866 (open-input-string "")))))
872 (with-test-prefix "port-for-each"
874 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
875 ;; its iterator func if a port was inaccessible in the last gc mark but
876 ;; the lazy sweeping has not yet reached it to remove it from the port
877 ;; table (scm_i_port_table). Provoking those gc conditions is a little
878 ;; tricky, but the following code made it happen in 1.8.2.
879 (pass-if "passing freed cell"
881 ;; clear out the heap
883 ;; allocate cells so the opened ports aren't at the start of the heap
885 (open-input-file "/dev/null")
887 (open-input-file "/dev/null")
888 ;; this gc leaves the above ports unmarked, ie. inaccessible
890 ;; but they're still in the port table, so this sees them
891 (port-for-each (lambda (port)
892 (set! lst (cons port lst))))
893 ;; this forces completion of the sweeping
895 ;; and (if the bug is present) the cells accumulated in LST are now
896 ;; freed cells, which give #f from `port?'
897 (not (memq #f (map port? lst))))))
901 (pass-if "fdes->ports finds port"
902 (let ((port (open-file (test-file) "w")))
904 (not (not (memq port (fdes->ports (port->fdes port))))))))
910 (with-test-prefix "seek"
912 (with-test-prefix "file port"
915 (call-with-output-file (test-file)
917 (display "abcde" port)))
918 (let ((port (open-file (test-file) "r")))
920 (seek port 2 SEEK_CUR)
921 (eqv? #\d (read-char port))))
924 (call-with-output-file (test-file)
926 (display "abcde" port)))
927 (let ((port (open-file (test-file) "r")))
929 (seek port 3 SEEK_SET)
930 (eqv? #\d (read-char port))))
933 (call-with-output-file (test-file)
935 (display "abcde" port)))
936 (let ((port (open-file (test-file) "r")))
938 (seek port -2 SEEK_END)
939 (eqv? #\d (read-char port))))))
945 (with-test-prefix "truncate-file"
947 (pass-if-exception "flonum file" exception:wrong-type-arg
948 (truncate-file 1.0 123))
950 (pass-if-exception "frac file" exception:wrong-type-arg
951 (truncate-file 7/3 123))
953 (with-test-prefix "filename"
955 (pass-if-exception "flonum length" exception:wrong-type-arg
956 (call-with-output-file (test-file)
958 (display "hello" port)))
959 (truncate-file (test-file) 1.0))
962 (call-with-output-file (test-file)
964 (display "hello" port)))
965 (truncate-file (test-file) 1)
966 (eqv? 1 (stat:size (stat (test-file)))))
968 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
969 (call-with-output-file (test-file)
971 (display "hello" port)))
972 (truncate-file (test-file))))
974 (with-test-prefix "file descriptor"
977 (call-with-output-file (test-file)
979 (display "hello" port)))
980 (let ((fd (open-fdes (test-file) O_RDWR)))
983 (eqv? 1 (stat:size (stat (test-file)))))
985 (pass-if "shorten to current pos"
986 (call-with-output-file (test-file)
988 (display "hello" port)))
989 (let ((fd (open-fdes (test-file) O_RDWR)))
993 (eqv? 1 (stat:size (stat (test-file))))))
995 (with-test-prefix "file port"
998 (call-with-output-file (test-file)
1000 (display "hello" port)))
1001 (let ((port (open-file (test-file) "r+")))
1002 (truncate-file port 1))
1003 (eqv? 1 (stat:size (stat (test-file)))))
1005 (pass-if "shorten to current pos"
1006 (call-with-output-file (test-file)
1008 (display "hello" port)))
1009 (let ((port (open-file (test-file) "r+")))
1011 (truncate-file port))
1012 (eqv? 1 (stat:size (stat (test-file)))))))
1015 ;;;; testing read-delimited and friends
1017 (with-test-prefix "read-delimited!"
1018 (let ((c (make-string 20 #\!)))
1019 (call-with-input-string
1023 (read-delimited! "\n" c port 'concat)
1024 (pass-if "read-delimited! reads a first line"
1025 (string=? c "defdef\n!!!!!!!!!!!!!"))
1027 (read-delimited! "\n" c port 'concat 3)
1028 (pass-if "read-delimited! reads a first line"
1029 (string=? c "defghighi\n!!!!!!!!!!"))))))
1034 (call-with-input-string
1037 (pass-if "char-ready? returns true on string port"
1038 (char-ready? port))))
1040 ;;; This segfaults on some versions of Guile. We really should run
1041 ;;; the tests in a subprocess...
1043 (call-with-input-string
1046 (with-input-from-port
1049 (pass-if "char-ready? returns true on string port as default port"
1053 ;;;; Close current-input-port, and make sure everyone can handle it.
1055 (with-test-prefix "closing current-input-port"
1056 (for-each (lambda (procedure name)
1057 (with-input-from-port
1058 (call-with-input-string "foo" (lambda (p) p))
1060 (close-port (current-input-port))
1061 (pass-if-exception name
1062 exception:wrong-type-arg
1064 (list read read-char read-line)
1065 '("read" "read-char" "read-line")))
1069 (with-test-prefix "setvbuf"
1071 (pass-if "line/column number preserved"
1072 ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1073 ;; line and/or column number.
1074 (call-with-output-file (test-file)
1076 (display "This is GNU Guile.\nWelcome." p)))
1077 (call-with-input-file (test-file)
1079 (and (eq? #\T (read-char p))
1080 (let ((line (port-line p))
1081 (col (port-column p)))
1082 (and (= line 0) (= col 1)
1084 (setvbuf p _IOFBF 777)
1085 (let ((line* (port-line p))
1086 (col* (port-column p)))
1088 (= col col*)))))))))))
1090 (delete-file (test-file))
1092 ;;; Local Variables:
1093 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)