HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge commit 'f6ddf827f8f192af7a8cd255bd8374a0d38bbb74'
[bpt/guile.git] / test-suite / tests / ports.test
CommitLineData
7b041912 1;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
7ef450bf 2;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
000ee07f 3;;;;
2e59af21 4;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
122f24cc 5;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
2e59af21 6;;;;
53befeb7
NJ		 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.
000ee07f 11;;;;
53befeb7 12;;;; This library is distributed in the hope that it will be useful,
000ee07f 13;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
53befeb7
NJ		 14;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15;;;; Lesser General Public License for more details.
000ee07f 16;;;;
53befeb7
NJ		 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
000ee07f 20
8aa28a91 21(define-module (test-suite test-ports)
2e59af21
LC		 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)
cc540d0b 26 #:use-module (rnrs bytevectors)
7f6c3f8f
MW		 27 #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
28 open-bytevector-output-port
29 put-bytevector
30 get-bytevector-n
31 get-bytevector-all
32 unget-bytevector)))
000ee07f
JB		 33
34(define (display-line . args)
35 (for-each display args)
36 (newline))
37
38(define (test-file)
c685b42f 39 (data-file-name "ports-test.tmp"))
000ee07f
JB		 40
41\f
42;;;; Some general utilities for testing ports.
43
d6a6989e
LC		 44;; Make sure we are set up for 8-bit Latin-1 data.
45(fluid-set! %default-port-encoding "ISO-8859-1")
46(for-each (lambda (p)
47 (set-port-encoding! p (fluid-ref %default-port-encoding)))
48 (list (current-input-port) (current-output-port)
49 (current-error-port)))
889975e5 50
000ee07f
JB		 51;;; Read from PORT until EOF, and return the result as a string.
52(define (read-all port)
53 (let loop ((chars '()))
54 (let ((char (read-char port)))
55 (if (eof-object? char)
56 (list->string (reverse! chars))
57 (loop (cons char chars))))))
58
59(define (read-file filename)
60 (let* ((port (open-input-file filename))
61 (string (read-all port)))
62 (close-port port)
63 string))
64
65\f
b22e94db
LC		 66
67(with-test-prefix "%default-port-conversion-strategy"
68
69 (pass-if "initial value"
70 (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
71
72 (pass-if "file port"
73 (let ((strategies '(error substitute escape)))
74 (equal? (map (lambda (s)
75 (with-fluids ((%default-port-conversion-strategy s))
76 (call-with-output-file "/dev/null"
77 (lambda (p)
78 (port-conversion-strategy p)))))
79 strategies)
80 strategies)))
81
82 (pass-if "(set-port-conversion-strategy! #f sym)"
83 (begin
84 (set-port-conversion-strategy! #f 'error)
85 (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
86 (begin
87 (set-port-conversion-strategy! #f 'substitute)
88 (eq? (fluid-ref %default-port-conversion-strategy)
89 'substitute)))))
90
91)
92
93\f
000ee07f
JB		 94;;;; Normal file ports.
95
96;;; Write out an s-expression, and read it back.
57e7f270
DH		 97(let ((string '("From fairest creatures we desire increase,"
98 "That thereby beauty's rose might never die,"))
99 (filename (test-file)))
100 (let ((port (open-output-file filename)))
101 (write string port)
102 (close-port port))
103 (let ((port (open-input-file filename)))
104 (let ((in-string (read port)))
105 (pass-if "file: write and read back list of strings"
106 (equal? string in-string)))
107 (close-port port))
108 (delete-file filename))
000ee07f
JB		 109
110;;; Write out a string, and read it back a character at a time.
57e7f270
DH		 111(let ((string "This is a test string\nwith no newline at the end")
112 (filename (test-file)))
113 (let ((port (open-output-file filename)))
114 (display string port)
115 (close-port port))
116 (let ((in-string (read-file filename)))
117 (pass-if "file: write and read back characters"
118 (equal? string in-string)))
119 (delete-file filename))
000ee07f 120
7c035009 121;;; Buffered input/output port with seeking.
57e7f270
DH		 122(let* ((filename (test-file))
123 (port (open-file filename "w+")))
124 (display "J'Accuse" port)
125 (seek port -1 SEEK_CUR)
126 (pass-if "file: r/w 1"
127 (char=? (read-char port) #\e))
128 (pass-if "file: r/w 2"
129 (eof-object? (read-char port)))
130 (seek port -1 SEEK_CUR)
131 (write-char #\x port)
132 (seek port 7 SEEK_SET)
133 (pass-if "file: r/w 3"
134 (char=? (read-char port) #\x))
135 (seek port -2 SEEK_END)
136 (pass-if "file: r/w 4"
137 (char=? (read-char port) #\s))
8f99e3f3 138 (close-port port)
57e7f270 139 (delete-file filename))
7c035009
GH		 140
141;;; Unbuffered input/output port with seeking.
57e7f270
DH		 142(let* ((filename (test-file))
143 (port (open-file filename "w+0")))
144 (display "J'Accuse" port)
145 (seek port -1 SEEK_CUR)
146 (pass-if "file: ub r/w 1"
147 (char=? (read-char port) #\e))
148 (pass-if "file: ub r/w 2"
149 (eof-object? (read-char port)))
150 (seek port -1 SEEK_CUR)
151 (write-char #\x port)
152 (seek port 7 SEEK_SET)
153 (pass-if "file: ub r/w 3"
154 (char=? (read-char port) #\x))
155 (seek port -2 SEEK_END)
156 (pass-if "file: ub r/w 4"
157 (char=? (read-char port) #\s))
8f99e3f3 158 (close-port port)
57e7f270 159 (delete-file filename))
7c035009 160
4fcd6551 161;;; Buffered output-only and input-only ports with seeking.
57e7f270
DH		 162(let* ((filename (test-file))
163 (port (open-output-file filename)))
164 (display "J'Accuse" port)
165 (pass-if "file: out tell"
166 (= (seek port 0 SEEK_CUR) 8))
167 (seek port -1 SEEK_CUR)
168 (write-char #\x port)
169 (close-port port)
170 (let ((iport (open-input-file filename)))
171 (pass-if "file: in tell 0"
172 (= (seek iport 0 SEEK_CUR) 0))
173 (read-char iport)
174 (pass-if "file: in tell 1"
175 (= (seek iport 0 SEEK_CUR) 1))
176 (unread-char #\z iport)
177 (pass-if "file: in tell 0 after unread"
178 (= (seek iport 0 SEEK_CUR) 0))
179 (pass-if "file: unread char still there"
180 (char=? (read-char iport) #\z))
181 (seek iport 7 SEEK_SET)
182 (pass-if "file: in last char"
183 (char=? (read-char iport) #\x))
184 (close-port iport))
185 (delete-file filename))
4fcd6551 186
7f214e60 187;;; unusual characters.
57e7f270
DH		 188(let* ((filename (test-file))
189 (port (open-output-file filename)))
190 (display (string #\nul (integer->char 255) (integer->char 128)
191 #\nul) port)
192 (close-port port)
193 (let* ((port (open-input-file filename))
194 (line (read-line port)))
195 (pass-if "file: read back NUL 1"
196 (char=? (string-ref line 0) #\nul))
197 (pass-if "file: read back 255"
198 (char=? (string-ref line 1) (integer->char 255)))
199 (pass-if "file: read back 128"
200 (char=? (string-ref line 2) (integer->char 128)))
201 (pass-if "file: read back NUL 2"
202 (char=? (string-ref line 3) #\nul))
203 (pass-if "file: EOF"
8f99e3f3
SJ		 204 (eof-object? (read-char port)))
205 (close-port port))
57e7f270 206 (delete-file filename))
7f214e60 207
0eb2e8cd 208;;; line buffering mode.
57e7f270
DH		 209(let* ((filename (test-file))
210 (port (open-file filename "wl"))
211 (test-string "one line more or less"))
212 (write-line test-string port)
213 (let* ((in-port (open-input-file filename))
214 (line (read-line in-port)))
215 (close-port in-port)
216 (close-port port)
217 (pass-if "file: line buffering"
218 (string=? line test-string)))
219 (delete-file filename))
0eb2e8cd 220
e50d921b
MG		 221;;; read-line should use the port encoding (not the locale encoding).
222(let ((str "ĉu bone?"))
211683cc
MG		 223 (with-locale "C"
224 (let* ((filename (test-file))
225 (port (open-file filename "wl")))
226 (set-port-encoding! port "UTF-8")
227 (write-line str port)
228 (let ((in-port (open-input-file filename)))
229 (set-port-encoding! in-port "UTF-8")
230 (let ((line (read-line in-port)))
231 (close-port in-port)
232 (close-port port)
233 (pass-if "file: read-line honors port encoding"
234 (string=? line str))))
235 (delete-file filename))))
236
237;;; binary mode ignores port encoding
238(pass-if "file: binary mode ignores port encoding"
239 (with-fluids ((%default-port-encoding "UTF-8"))
240 (let* ((filename (test-file))
241 (port (open-file filename "w"))
242 (test-string "一二三")
243 (binary-test-string
244 (apply string
245 (map integer->char
246 (uniform-vector->list
247 (string->utf8 test-string))))))
248 (write-line test-string port)
249 (close-port port)
250 (let* ((in-port (open-file filename "rb"))
251 (line (read-line in-port)))
252 (close-port in-port)
253 (delete-file filename)
254 (string=? line binary-test-string)))))
255
256;;; binary mode ignores file coding declaration
257(pass-if "file: binary mode ignores file coding declaration"
258 (with-fluids ((%default-port-encoding "UTF-8"))
259 (let* ((filename (test-file))
260 (port (open-file filename "w"))
261 (test-string "一二三")
262 (binary-test-string
263 (apply string
264 (map integer->char
265 (uniform-vector->list
266 (string->utf8 test-string))))))
267 (write-line ";; coding: utf-8" port)
268 (write-line test-string port)
269 (close-port port)
270 (let* ((in-port (open-file filename "rb"))
271 (line1 (read-line in-port))
272 (line2 (read-line in-port)))
273 (close-port in-port)
274 (delete-file filename)
275 (string=? line2 binary-test-string)))))
276
3ace9a8e
MW		 277;; open-file ignores file coding declaration by default
278(pass-if "file: open-file ignores coding declaration by default"
211683cc
MG		 279 (with-fluids ((%default-port-encoding "UTF-8"))
280 (let* ((filename (test-file))
281 (port (open-output-file filename))
282 (test-string "€100"))
211683cc
MG		 283 (write-line ";; coding: iso-8859-15" port)
284 (write-line test-string port)
285 (close-port port)
286 (let* ((in-port (open-input-file filename))
287 (line1 (read-line in-port))
288 (line2 (read-line in-port)))
289 (close-port in-port)
290 (delete-file filename)
291 (string=? line2 test-string)))))
e50d921b 292
3ace9a8e
MW		 293;; open-input-file with guess-encoding honors coding declaration
294(pass-if "file: open-input-file with guess-encoding honors coding declaration"
295 (with-fluids ((%default-port-encoding "UTF-8"))
296 (let* ((filename (test-file))
297 (port (open-output-file filename))
298 (test-string "€100"))
299 (set-port-encoding! port "iso-8859-15")
300 (write-line ";; coding: iso-8859-15" port)
301 (write-line test-string port)
302 (close-port port)
303 (let* ((in-port (open-input-file filename
304 #:guess-encoding #t))
305 (line1 (read-line in-port))
306 (line2 (read-line in-port)))
307 (close-port in-port)
308 (delete-file filename)
309 (string=? line2 test-string)))))
310
311(with-test-prefix "keyword arguments for file openers"
312 (with-fluids ((%default-port-encoding "UTF-8"))
313 (let ((filename (test-file)))
314
315 (with-test-prefix "write #:encoding"
316
317 (pass-if-equal "open-file"
318 #vu8(116 0 101 0 115 0 116 0)
319 (let ((port (open-file filename "w"
320 #:encoding "UTF-16LE")))
321 (display "test" port)
322 (close-port port))
323 (let* ((port (open-file filename "rb"))
324 (bv (get-bytevector-all port)))
325 (close-port port)
326 bv))
327
328 (pass-if-equal "open-output-file"
329 #vu8(116 0 101 0 115 0 116 0)
330 (let ((port (open-output-file filename
331 #:encoding "UTF-16LE")))
332 (display "test" port)
333 (close-port port))
334 (let* ((port (open-file filename "rb"))
335 (bv (get-bytevector-all port)))
336 (close-port port)
337 bv))
338
339 (pass-if-equal "call-with-output-file"
340 #vu8(116 0 101 0 115 0 116 0)
341 (call-with-output-file filename
342 (lambda (port)
343 (display "test" port))
344 #:encoding "UTF-16LE")
345 (let* ((port (open-file filename "rb"))
346 (bv (get-bytevector-all port)))
347 (close-port port)
348 bv))
349
350 (pass-if-equal "with-output-to-file"
351 #vu8(116 0 101 0 115 0 116 0)
352 (with-output-to-file filename
353 (lambda ()
354 (display "test"))
355 #:encoding "UTF-16LE")
356 (let* ((port (open-file filename "rb"))
357 (bv (get-bytevector-all port)))
358 (close-port port)
359 bv))
360
361 (pass-if-equal "with-error-to-file"
362 #vu8(116 0 101 0 115 0 116 0)
363 (with-error-to-file
364 filename
365 (lambda ()
366 (display "test" (current-error-port)))
367 #:encoding "UTF-16LE")
368 (let* ((port (open-file filename "rb"))
369 (bv (get-bytevector-all port)))
370 (close-port port)
371 bv)))
372
373 (with-test-prefix "write #:binary"
374
375 (pass-if-equal "open-output-file"
376 "ISO-8859-1"
377 (let* ((port (open-output-file filename #:binary #t))
378 (enc (port-encoding port)))
379 (close-port port)
380 enc))
381
382 (pass-if-equal "call-with-output-file"
383 "ISO-8859-1"
384 (call-with-output-file filename port-encoding #:binary #t))
385
386 (pass-if-equal "with-output-to-file"
387 "ISO-8859-1"
388 (with-output-to-file filename
389 (lambda () (port-encoding (current-output-port)))
390 #:binary #t))
391
392 (pass-if-equal "with-error-to-file"
393 "ISO-8859-1"
394 (with-error-to-file
395 filename
396 (lambda () (port-encoding (current-error-port)))
397 #:binary #t)))
398
399 (with-test-prefix "read #:encoding"
400
401 (pass-if-equal "open-file read #:encoding"
402 "test"
403 (call-with-output-file filename
404 (lambda (port)
405 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
406 (let* ((port (open-file filename "r" #:encoding "UTF-16LE"))
407 (str (read-string port)))
408 (close-port port)
409 str))
410
411 (pass-if-equal "open-input-file #:encoding"
412 "test"
413 (call-with-output-file filename
414 (lambda (port)
415 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
416 (let* ((port (open-input-file filename #:encoding "UTF-16LE"))
417 (str (read-string port)))
418 (close-port port)
419 str))
420
421 (pass-if-equal "call-with-input-file #:encoding"
422 "test"
423 (call-with-output-file filename
424 (lambda (port)
425 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
426 (call-with-input-file filename
427 read-string
428 #:encoding "UTF-16LE"))
429
430 (pass-if-equal "with-input-from-file #:encoding"
431 "test"
432 (call-with-output-file filename
433 (lambda (port)
434 (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
435 (with-input-from-file filename
436 read-string
437 #:encoding "UTF-16LE")))
438
439 (with-test-prefix "read #:binary"
440
441 (pass-if-equal "open-input-file"
442 "ISO-8859-1"
443 (let* ((port (open-input-file filename #:binary #t))
444 (enc (port-encoding port)))
445 (close-port port)
446 enc))
447
448 (pass-if-equal "call-with-input-file"
449 "ISO-8859-1"
450 (call-with-input-file filename port-encoding #:binary #t))
451
452 (pass-if-equal "with-input-from-file"
453 "ISO-8859-1"
454 (with-input-from-file filename
455 (lambda () (port-encoding (current-input-port)))
456 #:binary #t)))
457
458 (with-test-prefix "#:guess-encoding with coding declaration"
459
460 (pass-if-equal "open-file"
461 "€100"
462 (with-output-to-file filename
463 (lambda ()
464 (write-line "test")
465 (write-line "; coding: ISO-8859-15")
466 (write-line "€100"))
467 #:encoding "ISO-8859-15")
468 (let* ((port (open-file filename "r"
469 #:guess-encoding #t
470 #:encoding "UTF-16LE"))
471 (str (begin (read-line port)
472 (read-line port)
473 (read-line port))))
474 (close-port port)
475 str))
476
477 (pass-if-equal "open-input-file"
478 "€100"
479 (with-output-to-file filename
480 (lambda ()
481 (write-line "test")
482 (write-line "; coding: ISO-8859-15")
483 (write-line "€100"))
484 #:encoding "ISO-8859-15")
485 (let* ((port (open-input-file filename
486 #:guess-encoding #t
487 #:encoding "UTF-16LE"))
488 (str (begin (read-line port)
489 (read-line port)
490 (read-line port))))
491 (close-port port)
492 str))
493
494 (pass-if-equal "call-with-input-file"
495 "€100"
496 (with-output-to-file filename
497 (lambda ()
498 (write-line "test")
499 (write-line "; coding: ISO-8859-15")
500 (write-line "€100"))
501 #:encoding "ISO-8859-15")
502 (call-with-input-file filename
503 (lambda (port)
504 (read-line port)
505 (read-line port)
506 (read-line port))
507 #:guess-encoding #t
508 #:encoding "UTF-16LE"))
509
510 (pass-if-equal "with-input-from-file"
511 "€100"
512 (with-output-to-file filename
513 (lambda ()
514 (write-line "test")
515 (write-line "; coding: ISO-8859-15")
516 (write-line "€100"))
517 #:encoding "ISO-8859-15")
518 (with-input-from-file filename
519 (lambda ()
520 (read-line)
521 (read-line)
522 (read-line))
523 #:guess-encoding #t
524 #:encoding "UTF-16LE")))
525
526 (with-test-prefix "#:guess-encoding without coding declaration"
527
528 (pass-if-equal "open-file"
529 "€100"
530 (with-output-to-file filename
531 (lambda () (write-line "€100"))
532 #:encoding "ISO-8859-15")
533 (let* ((port (open-file filename "r"
534 #:guess-encoding #t
535 #:encoding "ISO-8859-15"))
536 (str (read-line port)))
537 (close-port port)
538 str))
539
540 (pass-if-equal "open-input-file"
541 "€100"
542 (with-output-to-file filename
543 (lambda () (write-line "€100"))
544 #:encoding "ISO-8859-15")
545 (let* ((port (open-input-file filename
546 #:guess-encoding #t
547 #:encoding "ISO-8859-15"))
548 (str (read-line port)))
549 (close-port port)
550 str))
551
552 (pass-if-equal "call-with-input-file"
553 "€100"
554 (with-output-to-file filename
555 (lambda () (write-line "€100"))
556 #:encoding "ISO-8859-15")
557 (call-with-input-file filename
558 read-line
559 #:guess-encoding #t
560 #:encoding "ISO-8859-15"))
561
562 (pass-if-equal "with-input-from-file"
563 "€100"
564 (with-output-to-file filename
565 (lambda () (write-line "€100"))
566 #:encoding "ISO-8859-15")
567 (with-input-from-file filename
568 read-line
569 #:guess-encoding #t
570 #:encoding "ISO-8859-15")))
571
572 (delete-file filename))))
573
d1b143e9 574;;; ungetting characters and strings.
57e7f270
DH		 575(with-input-from-string "walk on the moon\nmoon"
576 (lambda ()
577 (read-char)
578 (unread-char #\a (current-input-port))
579 (pass-if "unread-char"
580 (char=? (read-char) #\a))
581 (read-line)
582 (let ((replacenoid "chicken enchilada"))
583 (unread-char #\newline (current-input-port))
584 (unread-string replacenoid (current-input-port))
585 (pass-if "unread-string"
586 (string=? (read-line) replacenoid)))
587 (pass-if "unread residue"
588 (string=? (read-line) "moon"))))
d1b143e9 589
6e822cce 590;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
8cc58ec1
GH		 591;;; the reading end. try to read a byte: should get EAGAIN or
592;;; EWOULDBLOCK error.
57e7f270
DH		 593(let* ((p (pipe))
594 (r (car p)))
595 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
596 (pass-if "non-blocking-I/O"
597 (catch 'system-error
598 (lambda () (read-char r) #f)
599 (lambda (key . args)
600 (and (eq? key 'system-error)
601 (let ((errno (car (list-ref args 3))))
602 (or (= errno EAGAIN)
603 (= errno EWOULDBLOCK))))))))
22d35615 604
000ee07f 605\f
6e822cce 606;;;; Pipe (popen) ports.
000ee07f
JB		 607
608;;; Run a command, and read its output.
57e7f270
DH		 609(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
610 (in-string (read-all pipe)))
611 (close-pipe pipe)
612 (pass-if "pipe: read"
613 (equal? in-string "Howdy there, partner!\n")))
000ee07f
JB		 614
615;;; Run a command, send some output to it, and see if it worked.
57e7f270
DH		 616(let* ((filename (test-file))
617 (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
618 (display "Now Jimmy lives on a mushroom cloud\n" pipe)
619 (display "Mommy, why does everybody have a bomb?\n" pipe)
620 (close-pipe pipe)
621 (let ((in-string (read-file filename)))
622 (pass-if "pipe: write"
623 (equal? in-string "Mommy, why does everybody have a bomb?\n")))
624 (delete-file filename))
000ee07f
JB		 625
626\f
627;;;; Void ports. These are so trivial we don't test them.
628
629\f
630;;;; String ports.
631
73cb0a97
JB		 632(with-test-prefix "string ports"
633
634 ;; Write text to a string port.
57e7f270
DH		 635 (let* ((string "Howdy there, partner!")
636 (in-string (call-with-output-string
637 (lambda (port)
638 (display string port)
639 (newline port)))))
640 (pass-if "display text"
641 (equal? in-string (string-append string "\n"))))
000ee07f 642
73cb0a97 643 ;; Write an s-expression to a string port.
57e7f270
DH		 644 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
645 (in-sexpr
646 (call-with-input-string (call-with-output-string
647 (lambda (port)
648 (write sexpr port)))
649 read)))
650 (pass-if "write/read sexpr"
651 (equal? in-sexpr sexpr)))
2d9e5bca
GH		 652
653 ;; seeking and unreading from an input string.
57e7f270
DH		 654 (let ((text "that text didn't look random to me"))
655 (call-with-input-string text
656 (lambda (p)
657 (pass-if "input tell 0"
658 (= (seek p 0 SEEK_CUR) 0))
659 (read-char p)
660 (pass-if "input tell 1"
661 (= (seek p 0 SEEK_CUR) 1))
662 (unread-char #\x p)
663 (pass-if "input tell back to 0"
664 (= (seek p 0 SEEK_CUR) 0))
665 (pass-if "input ungetted char"
666 (char=? (read-char p) #\x))
667 (seek p 0 SEEK_END)
668 (pass-if "input seek to end"
669 (= (seek p 0 SEEK_CUR)
670 (string-length text)))
671 (unread-char #\x p)
672 (pass-if "input seek to beginning"
673 (= (seek p 0 SEEK_SET) 0))
674 (pass-if "input reread first char"
675 (char=? (read-char p)
676 (string-ref text 0))))))
677
2d9e5bca 678 ;; seeking an output string.
e4cbd1d8 679 (let* ((text (string-copy "123456789"))
57e7f270
DH		 680 (len (string-length text))
681 (result (call-with-output-string
682 (lambda (p)
683 (pass-if "output tell 0"
684 (= (seek p 0 SEEK_CUR) 0))
685 (display text p)
686 (pass-if "output tell end"
687 (= (seek p 0 SEEK_CUR) len))
688 (pass-if "output seek to beginning"
689 (= (seek p 0 SEEK_SET) 0))
690 (write-char #\a p)
691 (seek p -1 SEEK_END)
692 (pass-if "output seek to last char"
693 (= (seek p 0 SEEK_CUR)
694 (- len 1)))
695 (write-char #\b p)))))
696 (string-set! text 0 #\a)
697 (string-set! text (- len 1) #\b)
698 (pass-if "output check"
7b041912
LC		 699 (string=? text result)))
700
6dce942c
MW		 701 (pass-if "%default-port-encoding is ignored"
702 (let ((str "ĉu bone?"))
703 ;; Latin-1 cannot represent ‘ĉ’.
704 (with-fluids ((%default-port-encoding "ISO-8859-1"))
705 (string=? (call-with-output-string
706 (lambda (p)
707 (set-port-conversion-strategy! p 'substitute)
708 (display str p)))
709 "ĉu bone?"))))
7b041912 710
9f6e3f5a
LC		 711 (pass-if "%default-port-conversion-strategy is honored"
712 (let ((strategies '(error substitute escape)))
713 (equal? (map (lambda (s)
714 (with-fluids ((%default-port-conversion-strategy s))
715 (call-with-output-string
716 (lambda (p)
717 (and (eq? s (port-conversion-strategy p))
718 (begin
719 (set-port-conversion-strategy! p s)
720 (display (port-conversion-strategy p)
721 p)))))))
722 strategies)
723 (map symbol->string strategies))))
724
7b041912 725 (pass-if "suitable encoding [latin-1]"
6dce942c
MW		 726 (let ((str "hello, world")
727 (encoding "ISO-8859-1"))
728 (equal? str
729 (call-with-output-string
730 (lambda (p)
731 (set-port-encoding! p encoding)
732 (display str p))))))
7b041912
LC		 733
734 (pass-if "suitable encoding [latin-3]"
6dce942c
MW		 735 (let ((str "ĉu bone?")
736 (encoding "ISO-8859-3"))
737 (equal? str
738 (call-with-output-string
739 (lambda (p)
740 (set-port-encoding! p encoding)
741 (display str p))))))
7b041912 742
9f6e3f5a 743 (pass-if "wrong encoding, error"
7b041912 744 (let ((str "ĉu bone?"))
ef7e4ba3
LC		 745 (catch 'encoding-error
746 (lambda ()
6dce942c
MW		 747 (with-fluids ((%default-port-conversion-strategy 'error))
748 (call-with-output-string
749 (lambda (p)
750 ;; Latin-1 cannot represent ‘ĉ’.
751 (set-port-encoding! p "ISO-8859-1")
752 (display str p))))
753 #f) ; so the test really fails here
6851d3be 754 (lambda (key subr message errno port chr)
764246cf 755 (and (eqv? chr #\ĉ)
fd5eec2b
LC		 756 (string? (strerror errno)))))))
757
2e59af21
LC		 758 (pass-if "wrong encoding, substitute"
759 (let ((str "ĉu bone?"))
6dce942c
MW		 760 (string=? (call-with-output-string
761 (lambda (p)
762 (set-port-encoding! p "ISO-8859-1")
763 (set-port-conversion-strategy! p 'substitute)
764 (display str p)))
765 "?u bone?")))
2e59af21
LC		 766
767 (pass-if "wrong encoding, escape"
768 (let ((str "ĉu bone?"))
6dce942c
MW		 769 (string=? (call-with-output-string
770 (lambda (p)
771 (set-port-encoding! p "ISO-8859-1")
772 (set-port-conversion-strategy! p 'escape)
773 (display str p)))
774 "\\u0109u bone?")))
775
776 (pass-if "peek-char"
777 (let ((p (open-input-string "안녕하세요")))
d84783a8
LC		 778 (and (char=? (peek-char p) #\안)
779 (char=? (peek-char p) #\안)
780 (char=? (peek-char p) #\안)
781 (= (port-line p) 0)
782 (= (port-column p) 0))))
783
9a201881
LC		 784 ;; Mini DSL to test decoding error handling.
785 (letrec-syntax ((decoding-error?
786 (syntax-rules ()
787 ((_ port exp)
788 (catch 'decoding-error
789 (lambda ()
790 (pk 'exp exp)
791 #f)
792 (lambda (key subr message errno p)
793 (and (eq? p port)
794 (not (= 0 errno))))))))
795 (make-check
796 (syntax-rules (-> error eof)
797 ((_ port (proc -> error))
3009b93e
LC		 798 (if (eq? 'substitute
799 (port-conversion-strategy port))
764246cf 800 (eqv? (proc port) #\?)
3009b93e 801 (decoding-error? port (proc port))))
9a201881
LC		 802 ((_ port (proc -> eof))
803 (eof-object? (proc port)))
804 ((_ port (proc -> char))
764246cf 805 (eqv? (proc port) char))))
9a201881
LC		 806 (make-checks
807 (syntax-rules ()
808 ((_ port check ...)
809 (and (make-check port check) ...))))
e6e286bb
LC		 810 (make-peek+read-checks
811 (syntax-rules ()
812 ((_ port (result ...) e1 expected ...)
813 (make-peek+read-checks port
814 (result ...
815 (peek-char -> e1)
816 (read-char -> e1))
817 expected ...))
818 ((_ port (result ...))
819 (make-checks port result ...))
820 ((_ port #f e1 expected ...)
821 (make-peek+read-checks port
822 ((peek-char -> e1)
823 (read-char -> e1))
824 expected ...))))
3009b93e
LC		 825
826 (test-decoding-error*
e6e286bb
LC		 827 (syntax-rules ()
828 ((_ sequence encoding strategy (expected ...))
829 (begin
830 (pass-if (format #f "test-decoding-error: ~s ~s ~s"
831 'sequence encoding strategy)
832 (let ((p (open-bytevector-input-port
833 (u8-list->bytevector 'sequence))))
834 (set-port-encoding! p encoding)
835 (set-port-conversion-strategy! p strategy)
836 (make-checks p
837 (read-char -> expected) ...)))
838
839 ;; Generate the same test, but with one
840 ;; `peek-char' call before each `read-char'.
841 ;; Both should yield the same result.
842 (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
843 'sequence encoding strategy)
844 (let ((p (open-bytevector-input-port
845 (u8-list->bytevector 'sequence))))
846 (set-port-encoding! p encoding)
847 (set-port-conversion-strategy! p strategy)
3009b93e
LC		 848 (make-peek+read-checks p #f expected
849 ...)))))))
850 (test-decoding-error
851 (syntax-rules ()
852 ((_ sequence encoding (expected ...))
853 (begin
854 (test-decoding-error* sequence encoding 'error
855 (expected ...))
9a201881 856
3009b93e
LC		 857 ;; `escape' should behave exactly like `error'.
858 (test-decoding-error* sequence encoding 'escape
859 (expected ...))
9a201881 860
3009b93e
LC		 861 (test-decoding-error* sequence encoding 'substitute
862 (expected ...)))))))
863
864 (test-decoding-error (255 65 66 67) "UTF-8"
e6e286bb 865 (error #\A #\B #\C eof))
9a201881 866
3009b93e
LC		 867 (test-decoding-error (255 206 187 206 188) "UTF-8"
868 (error #\λ #\μ eof))
9a201881 869
3009b93e 870 (test-decoding-error (206 187 206) "UTF-8"
a42d7971 871 ;; Unterminated sequence.
e6e286bb 872 (#\λ error eof))
a42d7971 873
4cadf64f
LC		 874 ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
875 ;; of the "Conformance" chapter of Unicode 6.0.0.)
876
3009b93e 877 (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
e6e286bb
LC		 878 (error ;; C0: should be in the C2..DF range
879 error ;; 80: invalid
880 #\A
881 eof))
882
3009b93e 883 (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
7be1705d
LC		 884 ;; Section 3.9 of Unicode 6.0.0 reads:
885 ;; "If the converter encounters an ill-formed UTF-8 code unit
886 ;; sequence which starts with a valid first byte, but which does
887 ;; not continue with valid successor bytes (see Table 3-7), it
888 ;; must not consume the successor bytes".
889 ;; Glibc/libiconv do not conform to it and instead swallow the
890 ;; #x41. This example appears literally in Section 3.9.
891 (error ;; 41: invalid successor
892 #\A ;; 41: valid starting byte
e6e286bb
LC		 893 #\B
894 eof))
4cadf64f 895
7be1705d
LC		 896 (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
897 ;; According to Unicode 6.0.0, Section 3.9, "the only formal
898 ;; requirement mandated by Unicode conformance for a converter is
899 ;; that the <41> be processed and correctly interpreted as
900 ;; <U+0041>".
e6e286bb 901 (error ;; 2nd byte should be in the A0..BF range
7be1705d
LC		 902 error ;; 80: not a valid starting byte
903 error ;; 80: not a valid starting byte
904 #\A
e6e286bb
LC		 905 eof))
906
3009b93e 907 (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
e6e286bb 908 (error ;; 3rd byte should be in the 80..BF range
7be1705d 909 #\A
e6e286bb
LC		 910 #\B
911 eof))
4cadf64f 912
3009b93e 913 (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
e6e286bb 914 (error ;; 2nd byte should be in the 90..BF range
7be1705d
LC		 915 error ;; 88: not a valid starting byte
916 error ;; 88: not a valid starting byte
917 error ;; 88: not a valid starting byte
e6e286bb 918 eof))))
2d9e5bca 919
ee6eedcd
KR		 920(with-test-prefix "call-with-output-string"
921
922 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
923 ;; occur.
924 (pass-if-exception "proc closes port" exception:wrong-type-arg
925 (call-with-output-string close-port)))
926
000ee07f
JB		 927
928\f
929;;;; Soft ports. No tests implemented yet.
930
931\f
932;;;; Generic operations across all port types.
933
934(let ((port-loop-temp (test-file)))
935
936 ;; Return a list of input ports that all return the same text.
937 ;; We map tests over this list.
938 (define (input-port-list text)
939
940 ;; Create a text file some of the ports will use.
941 (let ((out-port (open-output-file port-loop-temp)))
942 (display text out-port)
943 (close-port out-port))
944
945 (list (open-input-file port-loop-temp)
946 (open-input-pipe (string-append "cat " port-loop-temp))
947 (call-with-input-string text (lambda (x) x))
948 ;; We don't test soft ports at the moment.
949 ))
950
951 (define port-list-names '("file" "pipe" "string"))
952
953 ;; Test the line counter.
73cb0a97 954 (define (test-line-counter text second-line final-column)
000ee07f
JB		 955 (with-test-prefix "line counter"
956 (let ((ports (input-port-list text)))
957 (for-each
958 (lambda (port port-name)
959 (with-test-prefix port-name
960 (pass-if "at beginning of input"
961 (= (port-line port) 0))
962 (pass-if "read first character"
963 (eqv? (read-char port) #\x))
964 (pass-if "after reading one character"
965 (= (port-line port) 0))
966 (pass-if "read first newline"
967 (eqv? (read-char port) #\newline))
968 (pass-if "after reading first newline char"
969 (= (port-line port) 1))
970 (pass-if "second line read correctly"
971 (equal? (read-line port) second-line))
972 (pass-if "read-line increments line number"
973 (= (port-line port) 2))
0b8faa0e
JB		 974 (pass-if "read-line returns EOF"
975 (let loop ((i 0))
976 (cond
977 ((eof-object? (read-line port)) #t)
978 ((> i 20) #f)
979 (else (loop (+ i 1))))))
000ee07f 980 (pass-if "line count is 5 at EOF"
73cb0a97
JB		 981 (= (port-line port) 5))
982 (pass-if "column is correct at EOF"
983 (= (port-column port) final-column))))
000ee07f
JB		 984 ports port-list-names)
985 (for-each close-port ports)
986 (delete-file port-loop-temp))))
987
57e7f270
DH		 988 (with-test-prefix "newline"
989 (test-line-counter
990 (string-append "x\n"
991 "He who receives an idea from me, receives instruction\n"
992 "himself without lessening mine; as he who lights his\n"
993 "taper at mine, receives light without darkening me.\n"
994 " --- Thomas Jefferson\n")
995 "He who receives an idea from me, receives instruction"
996 0))
997
998 (with-test-prefix "no newline"
999 (test-line-counter
1000 (string-append "x\n"
1001 "He who receives an idea from me, receives instruction\n"
1002 "himself without lessening mine; as he who lights his\n"
1003 "taper at mine, receives light without darkening me.\n"
1004 " --- Thomas Jefferson\n"
1005 "no newline here")
1006 "He who receives an idea from me, receives instruction"
1007 15)))
5bc1201f 1008
9a8be5a7
MV		 1009;; Test port-line and port-column for output ports
1010
1011(define (test-output-line-counter text final-column)
1012 (with-test-prefix "port-line and port-column for output ports"
1013 (let ((port (open-output-string)))
1014 (pass-if "at beginning of input"
1015 (and (= (port-line port) 0)
1016 (= (port-column port) 0)))
1017 (write-char #\x port)
1018 (pass-if "after writing one character"
1019 (and (= (port-line port) 0)
1020 (= (port-column port) 1)))
1021 (write-char #\newline port)
1022 (pass-if "after writing first newline char"
1023 (and (= (port-line port) 1)
1024 (= (port-column port) 0)))
1025 (display text port)
1026 (pass-if "line count is 5 at end"
1027 (= (port-line port) 5))
1028 (pass-if "column is correct at end"
1029 (= (port-column port) final-column)))))
1030
1031(test-output-line-counter
1032 (string-append "He who receives an idea from me, receives instruction\n"
1033 "himself without lessening mine; as he who lights his\n"
1034 "taper at mine, receives light without darkening me.\n"
1035 " --- Thomas Jefferson\n"
1036 "no newline here")
1037 15)
1038
7424deab
KR		 1039(with-test-prefix "port-column"
1040
1041 (with-test-prefix "output"
1042
1043 (pass-if "x"
1044 (let ((port (open-output-string)))
1045 (display "x" port)
1046 (= 1 (port-column port))))
1047
1048 (pass-if "\\a"
1049 (let ((port (open-output-string)))
1050 (display "\a" port)
1051 (= 0 (port-column port))))
1052
1053 (pass-if "x\\a"
1054 (let ((port (open-output-string)))
1055 (display "x\a" port)
1056 (= 1 (port-column port))))
1057
1058 (pass-if "\\x08 backspace"
1059 (let ((port (open-output-string)))
1060 (display "\x08" port)
1061 (= 0 (port-column port))))
1062
1063 (pass-if "x\\x08 backspace"
1064 (let ((port (open-output-string)))
1065 (display "x\x08" port)
1066 (= 0 (port-column port))))
1067
1068 (pass-if "\\n"
1069 (let ((port (open-output-string)))
1070 (display "\n" port)
1071 (= 0 (port-column port))))
1072
1073 (pass-if "x\\n"
1074 (let ((port (open-output-string)))
1075 (display "x\n" port)
1076 (= 0 (port-column port))))
1077
1078 (pass-if "\\r"
1079 (let ((port (open-output-string)))
1080 (display "\r" port)
1081 (= 0 (port-column port))))
1082
1083 (pass-if "x\\r"
1084 (let ((port (open-output-string)))
1085 (display "x\r" port)
1086 (= 0 (port-column port))))
1087
1088 (pass-if "\\t"
1089 (let ((port (open-output-string)))
1090 (display "\t" port)
1091 (= 8 (port-column port))))
1092
1093 (pass-if "x\\t"
1094 (let ((port (open-output-string)))
1095 (display "x\t" port)
1096 (= 8 (port-column port)))))
1097
1098 (with-test-prefix "input"
1099
1100 (pass-if "x"
1101 (let ((port (open-input-string "x")))
1102 (while (not (eof-object? (read-char port))))
1103 (= 1 (port-column port))))
1104
1105 (pass-if "\\a"
1106 (let ((port (open-input-string "\a")))
1107 (while (not (eof-object? (read-char port))))
1108 (= 0 (port-column port))))
1109
1110 (pass-if "x\\a"
1111 (let ((port (open-input-string "x\a")))
1112 (while (not (eof-object? (read-char port))))
1113 (= 1 (port-column port))))
1114
1115 (pass-if "\\x08 backspace"
1116 (let ((port (open-input-string "\x08")))
1117 (while (not (eof-object? (read-char port))))
1118 (= 0 (port-column port))))
1119
1120 (pass-if "x\\x08 backspace"
1121 (let ((port (open-input-string "x\x08")))
1122 (while (not (eof-object? (read-char port))))
1123 (= 0 (port-column port))))
1124
1125 (pass-if "\\n"
1126 (let ((port (open-input-string "\n")))
1127 (while (not (eof-object? (read-char port))))
1128 (= 0 (port-column port))))
1129
1130 (pass-if "x\\n"
1131 (let ((port (open-input-string "x\n")))
1132 (while (not (eof-object? (read-char port))))
1133 (= 0 (port-column port))))
1134
1135 (pass-if "\\r"
1136 (let ((port (open-input-string "\r")))
1137 (while (not (eof-object? (read-char port))))
1138 (= 0 (port-column port))))
1139
1140 (pass-if "x\\r"
1141 (let ((port (open-input-string "x\r")))
1142 (while (not (eof-object? (read-char port))))
1143 (= 0 (port-column port))))
1144
1145 (pass-if "\\t"
1146 (let ((port (open-input-string "\t")))
1147 (while (not (eof-object? (read-char port))))
1148 (= 8 (port-column port))))
1149
1150 (pass-if "x\\t"
1151 (let ((port (open-input-string "x\t")))
1152 (while (not (eof-object? (read-char port))))
1153 (= 8 (port-column port))))))
1154
004be623
KR		 1155(with-test-prefix "port-line"
1156
1157 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
1158 ;; scm_t_port actually holds a long; this restricted the range on 64-bit
1159 ;; systems
1160 (pass-if "set most-positive-fixnum/2"
1161 (let ((n (quotient most-positive-fixnum 2))
1162 (port (open-output-string)))
1163 (set-port-line! port n)
1164 (eqv? n (port-line port)))))
1165
064c27c4
LC		 1166(with-test-prefix "port-encoding"
1167
1168 (pass-if-exception "set-port-encoding!, wrong encoding"
1169 exception:miscellaneous-error
cdd3d6c9
MW		 1170 (let ((p (open-input-string "")))
1171 (set-port-encoding! p "does-not-exist")
1172 (read p)))
064c27c4 1173
6dce942c
MW		 1174 (let ((filename (test-file)))
1175 (with-output-to-file filename (lambda () (write 'test)))
1176
1177 (pass-if-exception "%default-port-encoding, wrong encoding"
1178 exception:miscellaneous-error
1179 (read (with-fluids ((%default-port-encoding "does-not-exist"))
1180 (open-input-file filename))))
1181
1182 (delete-file filename)))
064c27c4 1183
256f34e7
KR		 1184;;;
1185;;; port-for-each
1186;;;
1187
1188(with-test-prefix "port-for-each"
1189
1190 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
1191 ;; its iterator func if a port was inaccessible in the last gc mark but
1192 ;; the lazy sweeping has not yet reached it to remove it from the port
1193 ;; table (scm_i_port_table). Provoking those gc conditions is a little
1194 ;; tricky, but the following code made it happen in 1.8.2.
1195 (pass-if "passing freed cell"
256f34e7
KR		 1196 (let ((lst '()))
1197 ;; clear out the heap
1198 (gc) (gc) (gc)
1199 ;; allocate cells so the opened ports aren't at the start of the heap
1200 (make-list 1000)
1201 (open-input-file "/dev/null")
1202 (make-list 1000)
1203 (open-input-file "/dev/null")
1204 ;; this gc leaves the above ports unmarked, ie. inaccessible
1205 (gc)
1206 ;; but they're still in the port table, so this sees them
1207 (port-for-each (lambda (port)
1208 (set! lst (cons port lst))))
1209 ;; this forces completion of the sweeping
1210 (gc) (gc) (gc)
1211 ;; and (if the bug is present) the cells accumulated in LST are now
1212 ;; freed cells, which give #f from `port?'
1213 (not (memq #f (map port? lst))))))
1214
e9966dbb
HWN		 1215(with-test-prefix
1216 "fdes->port"
1217 (pass-if "fdes->ports finds port"
1218 (let ((port (open-file (test-file) "w")))
1219
1220 (not (not (memq port (fdes->ports (port->fdes port))))))))
1221
8ab3d8a0
KR		 1222;;;
1223;;; seek
1224;;;
1225
1226(with-test-prefix "seek"
1227
1228 (with-test-prefix "file port"
1229
1230 (pass-if "SEEK_CUR"
1231 (call-with-output-file (test-file)
1232 (lambda (port)
1233 (display "abcde" port)))
1234 (let ((port (open-file (test-file) "r")))
1235 (read-char port)
1236 (seek port 2 SEEK_CUR)
1237 (eqv? #\d (read-char port))))
1238
1239 (pass-if "SEEK_SET"
1240 (call-with-output-file (test-file)
1241 (lambda (port)
1242 (display "abcde" port)))
1243 (let ((port (open-file (test-file) "r")))
1244 (read-char port)
1245 (seek port 3 SEEK_SET)
1246 (eqv? #\d (read-char port))))
1247
1248 (pass-if "SEEK_END"
1249 (call-with-output-file (test-file)
1250 (lambda (port)
1251 (display "abcde" port)))
1252 (let ((port (open-file (test-file) "r")))
1253 (read-char port)
1254 (seek port -2 SEEK_END)
1255 (eqv? #\d (read-char port))))))
1256
6e7d5622
KR		 1257;;;
1258;;; truncate-file
1259;;;
1260
1261(with-test-prefix "truncate-file"
1262
8ab3d8a0
KR		 1263 (pass-if-exception "flonum file" exception:wrong-type-arg
1264 (truncate-file 1.0 123))
1265
1266 (pass-if-exception "frac file" exception:wrong-type-arg
1267 (truncate-file 7/3 123))
1268
6e7d5622
KR		 1269 (with-test-prefix "filename"
1270
8ab3d8a0
KR		 1271 (pass-if-exception "flonum length" exception:wrong-type-arg
1272 (call-with-output-file (test-file)
1273 (lambda (port)
1274 (display "hello" port)))
1275 (truncate-file (test-file) 1.0))
1276
6e7d5622
KR		 1277 (pass-if "shorten"
1278 (call-with-output-file (test-file)
1279 (lambda (port)
1280 (display "hello" port)))
1281 (truncate-file (test-file) 1)
8ab3d8a0
KR		 1282 (eqv? 1 (stat:size (stat (test-file)))))
1283
1284 (pass-if-exception "shorten to current pos" exception:miscellaneous-error
1285 (call-with-output-file (test-file)
1286 (lambda (port)
1287 (display "hello" port)))
1288 (truncate-file (test-file))))
6e7d5622
KR		 1289
1290 (with-test-prefix "file descriptor"
1291
1292 (pass-if "shorten"
1293 (call-with-output-file (test-file)
1294 (lambda (port)
1295 (display "hello" port)))
1296 (let ((fd (open-fdes (test-file) O_RDWR)))
1297 (truncate-file fd 1)
1298 (close-fdes fd))
8ab3d8a0
KR		 1299 (eqv? 1 (stat:size (stat (test-file)))))
1300
1301 (pass-if "shorten to current pos"
1302 (call-with-output-file (test-file)
1303 (lambda (port)
1304 (display "hello" port)))
1305 (let ((fd (open-fdes (test-file) O_RDWR)))
1306 (seek fd 1 SEEK_SET)
1307 (truncate-file fd)
1308 (close-fdes fd))
6e7d5622
KR		 1309 (eqv? 1 (stat:size (stat (test-file))))))
1310
1311 (with-test-prefix "file port"
1312
1313 (pass-if "shorten"
1314 (call-with-output-file (test-file)
1315 (lambda (port)
1316 (display "hello" port)))
1317 (let ((port (open-file (test-file) "r+")))
1318 (truncate-file port 1))
8ab3d8a0
KR		 1319 (eqv? 1 (stat:size (stat (test-file)))))
1320
1321 (pass-if "shorten to current pos"
1322 (call-with-output-file (test-file)
1323 (lambda (port)
1324 (display "hello" port)))
1325 (let ((port (open-file (test-file) "r+")))
1326 (read-char port)
1327 (truncate-file port))
6e7d5622
KR		 1328 (eqv? 1 (stat:size (stat (test-file)))))))
1329
7424deab 1330
5bc1201f
JB		 1331;;;; testing read-delimited and friends
1332
1333(with-test-prefix "read-delimited!"
1334 (let ((c (make-string 20 #\!)))
1335 (call-with-input-string
1336 "defdef\nghighi\n"
1337 (lambda (port)
1338
1339 (read-delimited! "\n" c port 'concat)
1340 (pass-if "read-delimited! reads a first line"
1341 (string=? c "defdef\n!!!!!!!!!!!!!"))
1342
1343 (read-delimited! "\n" c port 'concat 3)
1344 (pass-if "read-delimited! reads a first line"
1345 (string=? c "defghighi\n!!!!!!!!!!"))))))
1b054952
JB		 1346
1347\f
1348;;;; char-ready?
1349
1350(call-with-input-string
1351 "howdy"
1352 (lambda (port)
1353 (pass-if "char-ready? returns true on string port"
1354 (char-ready? port))))
1355
1356;;; This segfaults on some versions of Guile. We really should run
1357;;; the tests in a subprocess...
1358
1359(call-with-input-string
1360 "howdy"
1361 (lambda (port)
1362 (with-input-from-port
1363 port
1364 (lambda ()
1365 (pass-if "char-ready? returns true on string port as default port"
1366 (char-ready?))))))
fe5b6beb
JB		 1367
1368\f
45c0878b
MW		 1369;;;; pending-eof behavior
1370
1371(with-test-prefix "pending EOF behavior"
1372 ;; Make a test port that will produce the given sequence. Each
1373 ;; element of 'lst' may be either a character or #f (which means EOF).
1374 (define (test-soft-port . lst)
1375 (make-soft-port
1376 (vector (lambda (c) #f) ; write char
1377 (lambda (s) #f) ; write string
1378 (lambda () #f) ; flush
1379 (lambda () ; read char
1380 (let ((c (car lst)))
1381 (set! lst (cdr lst))
1382 c))
1383 (lambda () #f)) ; close
1384 "rw"))
1385
1386 (define (call-with-port p proc)
1387 (dynamic-wind
1388 (lambda () #f)
1389 (lambda () (proc p))
1390 (lambda () (close-port p))))
1391
1392 (define (call-with-test-file str proc)
1393 (let ((filename (test-file)))
1394 (dynamic-wind
1395 (lambda () (call-with-output-file filename
1396 (lambda (p) (display str p))))
1397 (lambda () (call-with-input-file filename proc))
1398 (lambda () (delete-file (test-file))))))
1399
1400 (pass-if "peek-char does not swallow EOF (soft port)"
1401 (call-with-port (test-soft-port #\a #f #\b)
1402 (lambda (p)
1403 (and (char=? #\a (peek-char p))
1404 (char=? #\a (read-char p))
1405 (eof-object? (peek-char p))
1406 (eof-object? (read-char p))
1407 (char=? #\b (peek-char p))
1408 (char=? #\b (read-char p))))))
1409
1410 (pass-if "unread clears pending EOF (soft port)"
1411 (call-with-port (test-soft-port #\a #f #\b)
1412 (lambda (p)
1413 (and (char=? #\a (read-char p))
1414 (eof-object? (peek-char p))
1415 (begin (unread-char #\u p)
1416 (char=? #\u (read-char p)))))))
1417
1418 (pass-if "unread clears pending EOF (string port)"
1419 (call-with-input-string "a"
1420 (lambda (p)
1421 (and (char=? #\a (read-char p))
1422 (eof-object? (peek-char p))
1423 (begin (unread-char #\u p)
1424 (char=? #\u (read-char p)))))))
1425
1426 (pass-if "unread clears pending EOF (file port)"
1427 (call-with-test-file
1428 "a"
1429 (lambda (p)
1430 (and (char=? #\a (read-char p))
1431 (eof-object? (peek-char p))
1432 (begin (unread-char #\u p)
1433 (char=? #\u (read-char p)))))))
1434
1435 (pass-if "seek clears pending EOF (string port)"
1436 (call-with-input-string "a"
1437 (lambda (p)
1438 (and (char=? #\a (read-char p))
1439 (eof-object? (peek-char p))
1440 (begin (seek p 0 SEEK_SET)
1441 (char=? #\a (read-char p)))))))
1442
1443 (pass-if "seek clears pending EOF (file port)"
1444 (call-with-test-file
1445 "a"
1446 (lambda (p)
1447 (and (char=? #\a (read-char p))
1448 (eof-object? (peek-char p))
1449 (begin (seek p 0 SEEK_SET)
1450 (char=? #\a (read-char p))))))))
1451
1452\f
fe5b6beb
JB		 1453;;;; Close current-input-port, and make sure everyone can handle it.
1454
1455(with-test-prefix "closing current-input-port"
1456 (for-each (lambda (procedure name)
1457 (with-input-from-port
1458 (call-with-input-string "foo" (lambda (p) p))
1459 (lambda ()
1460 (close-port (current-input-port))
6b4113af
DH		 1461 (pass-if-exception name
1462 exception:wrong-type-arg
1463 (procedure)))))
fe5b6beb
JB		 1464 (list read read-char read-line)
1465 '("read" "read-char" "read-line")))
c56c0f79 1466
e8b21eec
LC		 1467\f
1468
1469(with-test-prefix "setvbuf"
1470
122f24cc
LC		 1471 (pass-if-exception "closed port"
1472 exception:wrong-type-arg
1473 (let ((port (open-input-file "/dev/null")))
1474 (close-port port)
1475 (setvbuf port _IOFBF)))
1476
1477 (pass-if-exception "string port"
1478 exception:wrong-type-arg
1479 (let ((port (open-input-string "Hey!")))
1480 (close-port port)
1481 (setvbuf port _IOFBF)))
1482
e8b21eec
LC		 1483 (pass-if "line/column number preserved"
1484 ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1485 ;; line and/or column number.
1486 (call-with-output-file (test-file)
1487 (lambda (p)
1488 (display "This is GNU Guile.\nWelcome." p)))
1489 (call-with-input-file (test-file)
1490 (lambda (p)
764246cf 1491 (and (eqv? #\T (read-char p))
e8b21eec
LC		 1492 (let ((line (port-line p))
1493 (col (port-column p)))
1494 (and (= line 0) (= col 1)
1495 (begin
1496 (setvbuf p _IOFBF 777)
1497 (let ((line* (port-line p))
1498 (col* (port-column p)))
1499 (and (= line line*)
1500 (= col col*)))))))))))
1501
2ae7b7b6
LC		 1502\f
1503
7f6c3f8f
MW		 1504(pass-if-equal "unget-bytevector"
1505 #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
1506 1 2 3 4 251 253 254 255)
1507 (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
1508 (unget-bytevector port #vu8(200 201 202 203))
1509 (unget-bytevector port #vu8(20 21 22 23 24))
1510 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
1511 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
1512 (unget-bytevector port #vu8(10 11))
1513 (get-bytevector-all port)))
1514
1515\f
1516
cdd3d6c9
MW		 1517(with-test-prefix "unicode byte-order marks (BOMs)"
1518
1519 (define (bv-read-test* encoding bv proc)
1520 (let ((port (open-bytevector-input-port bv)))
1521 (set-port-encoding! port encoding)
1522 (proc port)))
1523
1524 (define (bv-read-test encoding bv)
1525 (bv-read-test* encoding bv read-string))
1526
1527 (define (bv-write-test* encoding proc)
1528 (call-with-values
1529 (lambda () (open-bytevector-output-port))
1530 (lambda (port get-bytevector)
1531 (set-port-encoding! port encoding)
1532 (proc port)
1533 (get-bytevector))))
1534
1535 (define (bv-write-test encoding str)
1536 (bv-write-test* encoding
1537 (lambda (p)
1538 (display str p))))
1539
1540 (pass-if-equal "BOM not discarded from Latin-1 stream"
1541 "\xEF\xBB\xBF\x61"
1542 (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
1543
1544 (pass-if-equal "BOM not discarded from Latin-2 stream"
1545 "\u010F\u0165\u017C\x61"
1546 (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
1547
1548 (pass-if-equal "BOM not discarded from UTF-16BE stream"
1549 "\uFEFF\x61"
1550 (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
1551
1552 (pass-if-equal "BOM not discarded from UTF-16LE stream"
1553 "\uFEFF\x61"
1554 (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
1555
1556 (pass-if-equal "BOM not discarded from UTF-32BE stream"
1557 "\uFEFF\x61"
1558 (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
1559 #x00 #x00 #x00 #x61)))
1560
1561 (pass-if-equal "BOM not discarded from UTF-32LE stream"
1562 "\uFEFF\x61"
1563 (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
1564 #x61 #x00 #x00 #x00)))
1565
1566 (pass-if-equal "BOM not written to UTF-8 stream"
1567 #vu8(#x61)
1568 (bv-write-test "UTF-8" "a"))
1569
1570 (pass-if-equal "BOM not written to UTF-16BE stream"
1571 #vu8(#x00 #x61)
1572 (bv-write-test "UTF-16BE" "a"))
1573
1574 (pass-if-equal "BOM not written to UTF-16LE stream"
1575 #vu8(#x61 #x00)
1576 (bv-write-test "UTF-16LE" "a"))
1577
1578 (pass-if-equal "BOM not written to UTF-32BE stream"
1579 #vu8(#x00 #x00 #x00 #x61)
1580 (bv-write-test "UTF-32BE" "a"))
1581
1582 (pass-if-equal "BOM not written to UTF-32LE stream"
1583 #vu8(#x61 #x00 #x00 #x00)
1584 (bv-write-test "UTF-32LE" "a"))
1585
1586 (pass-if "Don't read from the port unless user asks to"
1587 (let* ((p (make-soft-port
1588 (vector
1589 (lambda (c) #f) ; write char
1590 (lambda (s) #f) ; write string
1591 (lambda () #f) ; flush
1592 (lambda () (throw 'fail)) ; read char
1593 (lambda () #f))
1594 "rw")))
1595 (set-port-encoding! p "UTF-16")
1596 (display "abc" p)
1597 (set-port-encoding! p "UTF-32")
1598 (display "def" p)
1599 #t))
1600
1601 ;; TODO: test that input and output streams are independent when
1602 ;; appropriate, and linked when appropriate.
1603
1604 (pass-if-equal "BOM discarded from start of UTF-8 stream"
1605 "a"
1606 (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
1607
1608 (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
1609 '(#\a "a")
1610 (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
1611 (lambda (p)
1612 (let ((c (read-char p)))
1613 (seek p 0 SEEK_SET)
1614 (let ((s (read-string p)))
1615 (list c s))))))
1616
1617 (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
1618 "\uFEFFa"
1619 (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
1620
1621 (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
1622 "\uFEFFb"
1623 (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
1624 (lambda (p)
1625 (seek p 1 SEEK_SET)
1626 (read-string p))))
1627
1628 (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
1629 "a\uFEFFb"
1630 (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
1631
1632 (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
1633 #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
1634 (bv-write-test "UTF-16" "ab"))
1635
1636 (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
1637 #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
1638 (bv-write-test* "UTF-16"
1639 (lambda (p)
1640 (display "ab" p)
1641 (set-port-encoding! p "UTF-16")
1642 (display "cd" p))))
1643
1644 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
1645 "a"
1646 (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
1647
1648 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
1649 '(#\a "a")
1650 (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
1651 (lambda (p)
1652 (let ((c (read-char p)))
1653 (seek p 0 SEEK_SET)
1654 (let ((s (read-string p)))
1655 (list c s))))))
1656
1657 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
1658 "\uFEFFa"
1659 (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
1660
1661 (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
1662 "\uFEFFa"
1663 (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
1664 (lambda (p)
1665 (seek p 2 SEEK_SET)
1666 (read-string p))))
1667
1668 (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
1669 "a\uFEFFb"
3f315b64 1670 (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
cdd3d6c9
MW		 1671
1672 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
1673 "a"
1674 (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
1675
1676 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
1677 '(#\a "a")
1678 (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
1679 (lambda (p)
1680 (let ((c (read-char p)))
1681 (seek p 0 SEEK_SET)
1682 (let ((s (read-string p)))
1683 (list c s))))))
1684
1685 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
1686 "\uFEFFa"
1687 (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
1688
1689 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
1690 "a"
1691 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1692 #x00 #x00 #x00 #x61)))
1693
1694 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
1695 '(#\a "a")
1696 (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
1697 #x00 #x00 #x00 #x61)
1698 (lambda (p)
1699 (let ((c (read-char p)))
1700 (seek p 0 SEEK_SET)
1701 (let ((s (read-string p)))
1702 (list c s))))))
1703
1704 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
1705 "\uFEFFa"
1706 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1707 #x00 #x00 #xFE #xFF
1708 #x00 #x00 #x00 #x61)))
1709
1710 (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
1711 "\uFEFFa"
1712 (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
1713 #x00 #x00 #xFE #xFF
1714 #x00 #x00 #x00 #x61)
1715 (lambda (p)
1716 (seek p 4 SEEK_SET)
1717 (read-string p))))
1718
1719 (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
1720 "ab"
1721 (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
1722 (lambda (p)
1723 (let ((a (read-char p)))
1724 (set-port-encoding! p "UTF-16")
1725 (string a (read-char p))))))
1726
1727 (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
1728 "ab"
1729 (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
1730 (lambda (p)
1731 (let ((a (read-char p)))
1732 (set-port-encoding! p "UTF-16")
1733 (string a (read-char p))))))
1734
1735 (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
1736 "ab"
1737 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1738 #x00 #x00 #xFE #xFF
1739 #x00 #x00 #x00 #x62)
1740 (lambda (p)
1741 (let ((a (read-char p)))
1742 (set-port-encoding! p "UTF-32")
1743 (string a (read-char p))))))
1744
1745 (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
1746 "ab"
1747 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1748 #xFF #xFE #x00 #x00
1749 #x62 #x00 #x00 #x00)
1750 (lambda (p)
1751 (let ((a (read-char p)))
1752 (set-port-encoding! p "UTF-32")
1753 (string a (read-char p))))))
1754
1755 (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
1756 "a\uFEFFb"
3f315b64 1757 (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
f6f4feb0
MW		 1758 #x00 #x00 #xFE #xFF
1759 #x00 #x00 #x00 #x62)))
cdd3d6c9
MW		 1760
1761 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
1762 "a"
1763 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1764 #x61 #x00 #x00 #x00)))
1765
1766 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
1767 '(#\a "a")
1768 (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
1769 #x61 #x00 #x00 #x00)
1770 (lambda (p)
1771 (let ((c (read-char p)))
1772 (seek p 0 SEEK_SET)
1773 (let ((s (read-string p)))
1774 (list c s))))))
1775
1776 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
1777 "\uFEFFa"
1778 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1779 #xFF #xFE #x00 #x00
1780 #x61 #x00 #x00 #x00))))
1781
1782\f
1783
2ae7b7b6
LC		 1784(define-syntax-rule (with-load-path path body ...)
1785 (let ((new path)
1786 (old %load-path))
1787 (dynamic-wind
1788 (lambda ()
1789 (set! %load-path new))
1790 (lambda ()
1791 body ...)
1792 (lambda ()
1793 (set! %load-path old)))))
1794
1795(with-test-prefix "%file-port-name-canonicalization"
1796
2a7d614c 1797 (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
2ae7b7b6
LC		 1798 ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
1799 ;; of "/dev/null". See
1800 ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
1801 ;; for a discussion.
2a7d614c
LC		 1802 (with-load-path (cons "" (delete "/" %load-path))
1803 (with-fluids ((%file-port-name-canonicalization 'relative))
1804 (port-filename (open-input-file "/dev/null")))))
1805
1806 (pass-if-equal "relative canonicalization with /" "dev/null"
1807 (with-load-path (cons "/" %load-path)
1808 (with-fluids ((%file-port-name-canonicalization 'relative))
1809 (port-filename (open-input-file "/dev/null")))))
1810
1811 (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
1812 ;; If an entry in %LOAD-PATH is not canonical, then
1813 ;; `scm_i_relativize_path' is unable to do its job.
1814 (if (equal? (map canonicalize-path %load-path) %load-path)
1815 (with-fluids ((%file-port-name-canonicalization 'relative))
1816 (port-filename
1817 (open-input-file (%search-load-path "ice-9/q.scm"))))
1818 (throw 'unresolved)))
1819
1820 (pass-if-equal "absolute canonicalization from ice-9"
1821 (canonicalize-path
1822 (string-append (assoc-ref %guile-build-info 'top_srcdir)
1823 "/module/ice-9/q.scm"))
1824 (with-fluids ((%file-port-name-canonicalization 'absolute))
1825 (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
2ae7b7b6 1826
c56c0f79 1827(delete-file (test-file))
9a201881
LC		 1828
1829;;; Local Variables:
1830;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
2ae7b7b6 1831;;; eval: (put 'with-load-path 'scheme-indent-function 1)
9a201881 1832;;; End:
Unnamed repository; edit this file 'description' to name the repository.