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