test-suite/tests/ports.test

   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 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 (rnrs bytevectors)
  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)))
  33
  34 (define (display-line . args)
  35   (for-each display args)
  36   (newline))
  37
  38 (define (test-file)
  39   (data-file-name "ports-test.tmp"))
  40
  41 \f
  42 ;;;; Some general utilities for testing ports.
  43
  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)))
  50
  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
  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
  94 ;;;; Normal file ports.
  95
  96 ;;; Write out an s-expression, and read it back.
  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))
 109
 110 ;;; Write out a string, and read it back a character at a time.
 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))
 120
 121 ;;; Buffered input/output port with seeking.
 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))
 138   (close-port port)
 139   (delete-file filename))
 140
 141 ;;; Unbuffered input/output port with seeking.
 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))
 158   (close-port port)
 159   (delete-file filename))
 160
 161 ;;; Buffered output-only and input-only ports with seeking.
 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))
 186
 187 ;;; unusual characters.
 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"
 204              (eof-object? (read-char port)))
 205     (close-port port))
 206   (delete-file filename))
 207
 208 ;;; line buffering mode.
 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))
 220
 221 ;;; read-line should use the port encoding (not the locale encoding).
 222 (let ((str "ĉu bone?"))
 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                                    (array->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                                    (array->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
 277 ;; open-file ignores file coding declaration by default
 278 (pass-if "file: open-file ignores coding declaration by default"
 279   (with-fluids ((%default-port-encoding "UTF-8"))
 280                (let* ((filename (test-file))
 281                       (port (open-output-file filename))
 282                       (test-string "€100"))
 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)))))
 292
 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
 574 ;;; ungetting characters and strings.
 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"))))
 589
 590 ;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
 591 ;;; the reading end.  try to read a byte: should get EAGAIN or
 592 ;;; EWOULDBLOCK error.
 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))))))))
 604
 605 \f
 606 ;;;; Pipe (popen) ports.
 607
 608 ;;; Run a command, and read its output.
 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")))
 614
 615 ;;; Run a command, send some output to it, and see if it worked.
 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))
 625
 626 (pass-if-equal "pipe, fdopen, and _IOLBF"
 627     "foo\nbar\n"
 628   (let ((in+out (pipe))
 629         (pid    (primitive-fork)))
 630     (if (zero? pid)
 631         (dynamic-wind
 632           (const #t)
 633           (lambda ()
 634             (close-port (car in+out))
 635             (let ((port (cdr in+out)))
 636               (setvbuf port _IOLBF )
 637               ;; Strings containing '\n' or should be flushed; others
 638               ;; should be kept in PORT's buffer.
 639               (display "foo\n" port)
 640               (display "bar\n" port)
 641               (display "this will be kept in PORT's buffer" port)))
 642           (lambda ()
 643             (primitive-_exit 0)))
 644         (begin
 645           (close-port (cdr in+out))
 646           (let ((str (read-all (car in+out))))
 647             (waitpid pid)
 648             str)))))
 649
 650 \f
 651 ;;;; Void ports.  These are so trivial we don't test them.
 652
 653 \f
 654 ;;;; String ports.
 655
 656 (with-test-prefix "string ports"
 657
 658   ;; Write text to a string port.
 659   (let* ((string "Howdy there, partner!")
 660          (in-string (call-with-output-string
 661                      (lambda (port)
 662                        (display string port)
 663                        (newline port)))))
 664     (pass-if "display text"
 665              (equal? in-string (string-append string "\n"))))
 666
 667   ;; Write an s-expression to a string port.
 668   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
 669          (in-sexpr
 670           (call-with-input-string (call-with-output-string
 671                                    (lambda (port)
 672                                      (write sexpr port)))
 673                                   read)))
 674     (pass-if "write/read sexpr"
 675              (equal? in-sexpr sexpr)))
 676
 677   ;; seeking and unreading from an input string.
 678   (let ((text "that text didn't look random to me"))
 679     (call-with-input-string text
 680                             (lambda (p)
 681                               (pass-if "input tell 0"
 682                                        (= (seek p 0 SEEK_CUR) 0))
 683                               (read-char p)
 684                               (pass-if "input tell 1"
 685                                        (= (seek p 0 SEEK_CUR) 1))
 686                               (unread-char #\x p)
 687                               (pass-if "input tell back to 0"
 688                                        (= (seek p 0 SEEK_CUR) 0))
 689                               (pass-if "input ungetted char"
 690                                        (char=? (read-char p) #\x))
 691                               (seek p 0 SEEK_END)
 692                               (pass-if "input seek to end"
 693                                        (= (seek p 0 SEEK_CUR)
 694                                           (string-length text)))
 695                               (unread-char #\x p)
 696                               (pass-if "input seek to beginning"
 697                                        (= (seek p 0 SEEK_SET) 0))
 698                               (pass-if "input reread first char"
 699                                        (char=? (read-char p)
 700                                                (string-ref text 0))))))
 701
 702   ;; seeking an output string.
 703   (let* ((text (string-copy "123456789"))
 704          (len (string-length text))
 705          (result (call-with-output-string
 706                   (lambda (p)
 707                     (pass-if "output tell 0"
 708                              (= (seek p 0 SEEK_CUR) 0))
 709                     (display text p)
 710                     (pass-if "output tell end"
 711                              (= (seek p 0 SEEK_CUR) len))
 712                     (pass-if "output seek to beginning"
 713                              (= (seek p 0 SEEK_SET) 0))
 714                     (write-char #\a p)
 715                     (seek p -1 SEEK_END)
 716                     (pass-if "output seek to last char"
 717                              (= (seek p 0 SEEK_CUR)
 718                                 (- len 1)))
 719                     (write-char #\b p)))))
 720     (string-set! text 0 #\a)
 721     (string-set! text (- len 1) #\b)
 722     (pass-if "output check"
 723              (string=? text result)))
 724
 725   (pass-if "encoding failure leads to exception"
 726     ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
 727     ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
 728     (catch 'encoding-error
 729       (lambda ()
 730         (with-fluids ((%default-port-encoding "ISO-8859-1"))
 731           (let ((p (open-input-string "λ")))      ; raise an exception
 732             #f)))
 733       (lambda (key . rest)
 734         #t)
 735       (lambda (key . rest)
 736         ;; At this point, the port-table mutex used to be still held,
 737         ;; hence the deadlock.  This situation would occur when trying
 738         ;; to print a backtrace, for instance.
 739         (input-port? (open-input-string "foo")))))
 740
 741   (pass-if "%default-port-encoding is honored"
 742     (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
 743       (equal? (map (lambda (e)
 744                      (with-fluids ((%default-port-encoding e))
 745                        (call-with-output-string
 746                          (lambda (p)
 747                            (and (string=? e (port-encoding p))
 748                                 (display (port-encoding p) p))))))
 749                    encodings)
 750               encodings)))
 751
 752   (pass-if "%default-port-conversion-strategy is honored"
 753     (let ((strategies '(error substitute escape)))
 754       (equal? (map (lambda (s)
 755                      (with-fluids ((%default-port-conversion-strategy s))
 756                        (call-with-output-string
 757                         (lambda (p)
 758                           (and (eq? s (port-conversion-strategy p))
 759                                (begin
 760                                  (set-port-conversion-strategy! p s)
 761                                  (display (port-conversion-strategy p)
 762                                           p)))))))
 763                    strategies)
 764               (map symbol->string strategies))))
 765
 766   (pass-if "suitable encoding [latin-1]"
 767     (let ((str "hello, world"))
 768       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 769         (equal? str
 770                 (with-output-to-string
 771                   (lambda ()
 772                     (display str)))))))
 773
 774   (pass-if "suitable encoding [latin-3]"
 775     (let ((str "ĉu bone?"))
 776       (with-fluids ((%default-port-encoding "ISO-8859-3"))
 777         (equal? str
 778                 (with-output-to-string
 779                   (lambda ()
 780                     (display str)))))))
 781
 782   (pass-if "wrong encoding, error"
 783     (let ((str "ĉu bone?"))
 784       (catch 'encoding-error
 785         (lambda ()
 786           ;; Latin-1 cannot represent ‘ĉ’.
 787           (with-fluids ((%default-port-encoding "ISO-8859-1")
 788                         (%default-port-conversion-strategy 'error))
 789             (with-output-to-string
 790               (lambda ()
 791                 (display str))))
 792           #f)                            ; so the test really fails here
 793         (lambda (key subr message errno port chr)
 794           (and (eqv? chr #\ĉ)
 795                (string? (strerror errno)))))))
 796
 797   (pass-if "wrong encoding, substitute"
 798     (let ((str "ĉu bone?"))
 799       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 800         (string=? (with-output-to-string
 801                     (lambda ()
 802                       (set-port-conversion-strategy! (current-output-port)
 803                                                      'substitute)
 804                       (display str)))
 805                   "?u bone?"))))
 806
 807   (pass-if "wrong encoding, escape"
 808     (let ((str "ĉu bone?"))
 809       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 810         (string=? (with-output-to-string
 811                     (lambda ()
 812                       (set-port-conversion-strategy! (current-output-port)
 813                                                      'escape)
 814                       (display str)))
 815                   "\\u0109u bone?"))))
 816
 817   (pass-if "peek-char [latin-1]"
 818     (let ((p (with-fluids ((%default-port-encoding #f))
 819                (open-input-string "hello, world"))))
 820       (and (char=? (peek-char p) #\h)
 821            (char=? (peek-char p) #\h)
 822            (char=? (peek-char p) #\h)
 823            (= (port-line p) 0)
 824            (= (port-column p) 0))))
 825
 826   (pass-if "peek-char [utf-8]"
 827     (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
 828                (open-input-string "안녕하세요"))))
 829       (and (char=? (peek-char p) #\안)
 830            (char=? (peek-char p) #\안)
 831            (char=? (peek-char p) #\안)
 832            (= (port-line p) 0)
 833            (= (port-column p) 0))))
 834
 835   (pass-if "peek-char [utf-16]"
 836     (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
 837                (open-input-string "안녕하세요"))))
 838       (and (char=? (peek-char p) #\안)
 839            (char=? (peek-char p) #\안)
 840            (char=? (peek-char p) #\안)
 841            (= (port-line p) 0)
 842            (= (port-column p) 0))))
 843
 844   ;; Mini DSL to test decoding error handling.
 845   (letrec-syntax ((decoding-error?
 846                    (syntax-rules ()
 847                      ((_ port exp)
 848                       (catch 'decoding-error
 849                         (lambda ()
 850                           (pk 'exp exp)
 851                           #f)
 852                         (lambda (key subr message errno p)
 853                           (and (eq? p port)
 854                                (not (= 0 errno))))))))
 855                   (make-check
 856                    (syntax-rules (-> error eof)
 857                      ((_ port (proc -> error))
 858                       (if (eq? 'substitute
 859                                (port-conversion-strategy port))
 860                           (eqv? (proc port) #\?)
 861                           (decoding-error? port (proc port))))
 862                      ((_ port (proc -> eof))
 863                       (eof-object? (proc port)))
 864                      ((_ port (proc -> char))
 865                       (eqv? (proc port) char))))
 866                   (make-checks
 867                    (syntax-rules ()
 868                      ((_ port check ...)
 869                       (and (make-check port check) ...))))
 870                   (make-peek+read-checks
 871                    (syntax-rules ()
 872                      ((_ port (result ...) e1 expected ...)
 873                       (make-peek+read-checks port
 874                                              (result ...
 875                                                      (peek-char -> e1)
 876                                                      (read-char -> e1))
 877                                              expected ...))
 878                      ((_ port (result ...))
 879                       (make-checks port result ...))
 880                      ((_ port #f e1 expected ...)
 881                       (make-peek+read-checks port
 882                                              ((peek-char -> e1)
 883                                               (read-char -> e1))
 884                                              expected ...))))
 885
 886                   (test-decoding-error*
 887                       (syntax-rules ()
 888                         ((_ sequence encoding strategy (expected ...))
 889                          (begin
 890                           (pass-if (format #f "test-decoding-error: ~s ~s ~s"
 891                                            'sequence encoding strategy)
 892                             (let ((p (open-bytevector-input-port
 893                                       (u8-list->bytevector 'sequence))))
 894                               (set-port-encoding! p encoding)
 895                               (set-port-conversion-strategy! p strategy)
 896                               (make-checks p
 897                                            (read-char -> expected) ...)))
 898
 899                           ;; Generate the same test, but with one
 900                           ;; `peek-char' call before each `read-char'.
 901                           ;; Both should yield the same result.
 902                           (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
 903                                            'sequence encoding strategy)
 904                             (let ((p (open-bytevector-input-port
 905                                       (u8-list->bytevector 'sequence))))
 906                               (set-port-encoding! p encoding)
 907                               (set-port-conversion-strategy! p strategy)
 908                               (make-peek+read-checks p #f expected
 909                                                      ...)))))))
 910                   (test-decoding-error
 911                       (syntax-rules ()
 912                         ((_ sequence encoding (expected ...))
 913                          (begin
 914                            (test-decoding-error* sequence encoding 'error
 915                              (expected ...))
 916
 917                            ;; `escape' should behave exactly like `error'.
 918                            (test-decoding-error* sequence encoding 'escape
 919                              (expected ...))
 920
 921                            (test-decoding-error* sequence encoding 'substitute
 922                              (expected ...)))))))
 923
 924     (test-decoding-error (255 65 66 67) "UTF-8"
 925       (error #\A #\B #\C eof))
 926
 927     (test-decoding-error (255 206 187 206 188) "UTF-8"
 928       (error #\λ #\μ eof))
 929
 930     (test-decoding-error (206 187 206) "UTF-8"
 931       ;; Unterminated sequence.
 932       (#\λ error eof))
 933
 934     ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
 935     ;; of the "Conformance" chapter of Unicode 6.0.0.)
 936
 937     (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
 938       (error                ;; C0: should be in the C2..DF range
 939        error                ;; 80: invalid
 940        #\A
 941        eof))
 942
 943     (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
 944       ;; Section 3.9 of Unicode 6.0.0 reads:
 945       ;;   "If the converter encounters an ill-formed UTF-8 code unit
 946       ;;   sequence which starts with a valid first byte, but which does
 947       ;;   not continue with valid successor bytes (see Table 3-7), it
 948       ;;   must not consume the successor bytes".
 949       ;; Glibc/libiconv do not conform to it and instead swallow the
 950       ;; #x41.  This example appears literally in Section 3.9.
 951       (error                ;; 41: invalid successor
 952        #\A                  ;; 41: valid starting byte
 953        #\B
 954        eof))
 955
 956     (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
 957       ;; According to Unicode 6.0.0, Section 3.9, "the only formal
 958       ;; requirement mandated by Unicode conformance for a converter is
 959       ;; that the <41> be processed and correctly interpreted as
 960       ;; <U+0041>".
 961       (error                ;; 2nd byte should be in the A0..BF range
 962        error                ;; 80: not a valid starting byte
 963        error                ;; 80: not a valid starting byte
 964        #\A
 965        eof))
 966
 967     (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
 968       (error                ;; 3rd byte should be in the 80..BF range
 969        #\A
 970        #\B
 971        eof))
 972
 973     (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
 974       (error                ;; 2nd byte should be in the 90..BF range
 975        error                ;; 88: not a valid starting byte
 976        error                ;; 88: not a valid starting byte
 977        error                ;; 88: not a valid starting byte
 978        eof))))
 979
 980 (with-test-prefix "call-with-output-string"
 981
 982   ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
 983   ;; occur.
 984   (pass-if-exception "proc closes port" exception:wrong-type-arg
 985     (call-with-output-string close-port)))
 986
 987
 988 \f
 989 ;;;; Soft ports.  No tests implemented yet.
 990
 991 \f
 992 ;;;; Generic operations across all port types.
 993
 994 (let ((port-loop-temp (test-file)))
 995
 996   ;; Return a list of input ports that all return the same text.
 997   ;; We map tests over this list.
 998   (define (input-port-list text)
 999
1000     ;; Create a text file some of the ports will use.
1001     (let ((out-port (open-output-file port-loop-temp)))
1002       (display text out-port)
1003       (close-port out-port))
1004
1005     (list (open-input-file port-loop-temp)
1006           (open-input-pipe (string-append "cat " port-loop-temp))
1007           (call-with-input-string text (lambda (x) x))
1008           ;; We don't test soft ports at the moment.
1009           ))
1010
1011   (define port-list-names '("file" "pipe" "string"))
1012
1013   ;; Test the line counter.
1014   (define (test-line-counter text second-line final-column)
1015     (with-test-prefix "line counter"
1016       (let ((ports (input-port-list text)))
1017         (for-each
1018          (lambda (port port-name)
1019            (with-test-prefix port-name
1020              (pass-if "at beginning of input"
1021                       (= (port-line port) 0))
1022              (pass-if "read first character"
1023                       (eqv? (read-char port) #\x))
1024              (pass-if "after reading one character"
1025                       (= (port-line port) 0))
1026              (pass-if "read first newline"
1027                       (eqv? (read-char port) #\newline))
1028              (pass-if "after reading first newline char"
1029                       (= (port-line port) 1))
1030              (pass-if "second line read correctly"
1031                       (equal? (read-line port) second-line))
1032              (pass-if "read-line increments line number"
1033                       (= (port-line port) 2))
1034              (pass-if "read-line returns EOF"
1035                       (let loop ((i 0))
1036                         (cond
1037                          ((eof-object? (read-line port)) #t)
1038                          ((> i 20) #f)
1039                          (else (loop (+ i 1))))))
1040              (pass-if "line count is 5 at EOF"
1041                       (= (port-line port) 5))
1042              (pass-if "column is correct at EOF"
1043                       (= (port-column port) final-column))))
1044          ports port-list-names)
1045         (for-each close-port ports)
1046         (delete-file port-loop-temp))))
1047
1048   (with-test-prefix "newline"
1049     (test-line-counter
1050      (string-append "x\n"
1051                     "He who receives an idea from me, receives instruction\n"
1052                     "himself without lessening mine; as he who lights his\n"
1053                     "taper at mine, receives light without darkening me.\n"
1054                     "  --- Thomas Jefferson\n")
1055      "He who receives an idea from me, receives instruction"
1056      0))
1057
1058   (with-test-prefix "no newline"
1059     (test-line-counter
1060      (string-append "x\n"
1061                     "He who receives an idea from me, receives instruction\n"
1062                     "himself without lessening mine; as he who lights his\n"
1063                     "taper at mine, receives light without darkening me.\n"
1064                     "  --- Thomas Jefferson\n"
1065                     "no newline here")
1066      "He who receives an idea from me, receives instruction"
1067      15)))
1068
1069 ;; Test port-line and port-column for output ports
1070
1071 (define (test-output-line-counter text final-column)
1072   (with-test-prefix "port-line and port-column for output ports"
1073     (let ((port (open-output-string)))
1074       (pass-if "at beginning of input"
1075                (and (= (port-line port) 0)
1076                     (= (port-column port) 0)))
1077       (write-char #\x port)
1078       (pass-if "after writing one character"
1079                (and (= (port-line port) 0)
1080                     (= (port-column port) 1)))
1081       (write-char #\newline port)
1082       (pass-if "after writing first newline char"
1083                (and (= (port-line port) 1)
1084                     (= (port-column port) 0)))
1085       (display text port)
1086       (pass-if "line count is 5 at end"
1087                (= (port-line port) 5))
1088       (pass-if "column is correct at end"
1089                (= (port-column port) final-column)))))
1090
1091 (test-output-line-counter
1092  (string-append "He who receives an idea from me, receives instruction\n"
1093                 "himself without lessening mine; as he who lights his\n"
1094                 "taper at mine, receives light without darkening me.\n"
1095                 "  --- Thomas Jefferson\n"
1096                 "no newline here")
1097  15)
1098
1099 (with-test-prefix "port-column"
1100
1101   (with-test-prefix "output"
1102
1103     (pass-if "x"
1104       (let ((port (open-output-string)))
1105         (display "x" port)
1106         (= 1 (port-column port))))
1107
1108     (pass-if "\\a"
1109       (let ((port (open-output-string)))
1110         (display "\a" port)
1111         (= 0 (port-column port))))
1112
1113     (pass-if "x\\a"
1114       (let ((port (open-output-string)))
1115         (display "x\a" port)
1116         (= 1 (port-column port))))
1117
1118     (pass-if "\\x08 backspace"
1119       (let ((port (open-output-string)))
1120         (display "\x08" port)
1121         (= 0 (port-column port))))
1122
1123     (pass-if "x\\x08 backspace"
1124       (let ((port (open-output-string)))
1125         (display "x\x08" port)
1126         (= 0 (port-column port))))
1127
1128     (pass-if "\\n"
1129       (let ((port (open-output-string)))
1130         (display "\n" port)
1131         (= 0 (port-column port))))
1132
1133     (pass-if "x\\n"
1134       (let ((port (open-output-string)))
1135         (display "x\n" port)
1136         (= 0 (port-column port))))
1137
1138     (pass-if "\\r"
1139       (let ((port (open-output-string)))
1140         (display "\r" port)
1141         (= 0 (port-column port))))
1142
1143     (pass-if "x\\r"
1144       (let ((port (open-output-string)))
1145         (display "x\r" port)
1146         (= 0 (port-column port))))
1147
1148     (pass-if "\\t"
1149       (let ((port (open-output-string)))
1150         (display "\t" port)
1151         (= 8 (port-column port))))
1152
1153     (pass-if "x\\t"
1154       (let ((port (open-output-string)))
1155         (display "x\t" port)
1156         (= 8 (port-column port)))))
1157
1158   (with-test-prefix "input"
1159
1160     (pass-if "x"
1161       (let ((port (open-input-string "x")))
1162         (while (not (eof-object? (read-char port))))
1163         (= 1 (port-column port))))
1164
1165     (pass-if "\\a"
1166       (let ((port (open-input-string "\a")))
1167         (while (not (eof-object? (read-char port))))
1168         (= 0 (port-column port))))
1169
1170     (pass-if "x\\a"
1171       (let ((port (open-input-string "x\a")))
1172         (while (not (eof-object? (read-char port))))
1173         (= 1 (port-column port))))
1174
1175     (pass-if "\\x08 backspace"
1176       (let ((port (open-input-string "\x08")))
1177         (while (not (eof-object? (read-char port))))
1178         (= 0 (port-column port))))
1179
1180     (pass-if "x\\x08 backspace"
1181       (let ((port (open-input-string "x\x08")))
1182         (while (not (eof-object? (read-char port))))
1183         (= 0 (port-column port))))
1184
1185     (pass-if "\\n"
1186       (let ((port (open-input-string "\n")))
1187         (while (not (eof-object? (read-char port))))
1188         (= 0 (port-column port))))
1189
1190     (pass-if "x\\n"
1191       (let ((port (open-input-string "x\n")))
1192         (while (not (eof-object? (read-char port))))
1193         (= 0 (port-column port))))
1194
1195     (pass-if "\\r"
1196       (let ((port (open-input-string "\r")))
1197         (while (not (eof-object? (read-char port))))
1198         (= 0 (port-column port))))
1199
1200     (pass-if "x\\r"
1201       (let ((port (open-input-string "x\r")))
1202         (while (not (eof-object? (read-char port))))
1203         (= 0 (port-column port))))
1204
1205     (pass-if "\\t"
1206       (let ((port (open-input-string "\t")))
1207         (while (not (eof-object? (read-char port))))
1208         (= 8 (port-column port))))
1209
1210     (pass-if "x\\t"
1211       (let ((port (open-input-string "x\t")))
1212         (while (not (eof-object? (read-char port))))
1213         (= 8 (port-column port))))))
1214
1215 (with-test-prefix "port-line"
1216
1217   ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
1218   ;; scm_t_port actually holds a long; this restricted the range on 64-bit
1219   ;; systems
1220   (pass-if "set most-positive-fixnum/2"
1221     (let ((n    (quotient most-positive-fixnum 2))
1222           (port (open-output-string)))
1223       (set-port-line! port n)
1224       (eqv? n (port-line port)))))
1225
1226 (with-test-prefix "port-encoding"
1227
1228   (pass-if-exception "set-port-encoding!, wrong encoding"
1229     exception:miscellaneous-error
1230     (let ((p (open-input-string "")))
1231       (set-port-encoding! p "does-not-exist")
1232       (read p)))
1233
1234   (pass-if-exception "%default-port-encoding, wrong encoding"
1235     exception:miscellaneous-error
1236     (read (with-fluids ((%default-port-encoding "does-not-exist"))
1237             (open-input-string "")))))
1238
1239 ;;;
1240 ;;; port-for-each
1241 ;;;
1242
1243 (with-test-prefix "port-for-each"
1244
1245   ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
1246   ;; its iterator func if a port was inaccessible in the last gc mark but
1247   ;; the lazy sweeping has not yet reached it to remove it from the port
1248   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
1249   ;; tricky, but the following code made it happen in 1.8.2.
1250   (pass-if "passing freed cell"
1251     (let ((lst '()))
1252       ;; clear out the heap
1253       (gc) (gc) (gc)
1254       ;; allocate cells so the opened ports aren't at the start of the heap
1255       (make-list 1000)
1256       (open-input-file "/dev/null")
1257       (make-list 1000)
1258       (open-input-file "/dev/null")
1259       ;; this gc leaves the above ports unmarked, ie. inaccessible
1260       (gc)
1261       ;; but they're still in the port table, so this sees them
1262       (port-for-each (lambda (port)
1263                        (set! lst (cons port lst))))
1264       ;; this forces completion of the sweeping
1265       (gc) (gc) (gc)
1266       ;; and (if the bug is present) the cells accumulated in LST are now
1267       ;; freed cells, which give #f from `port?'
1268       (not (memq #f (map port? lst))))))
1269
1270 (with-test-prefix
1271  "fdes->port"
1272  (pass-if "fdes->ports finds port"
1273           (let* ((port (open-file (test-file) "w"))
1274                  (res (not (not (memq port (fdes->ports (port->fdes port)))))))
1275             (close-port port)
1276             res)))
1277
1278 ;;;
1279 ;;; seek
1280 ;;;
1281
1282 (with-test-prefix "seek"
1283
1284   (with-test-prefix "file port"
1285
1286     (pass-if "SEEK_CUR"
1287       (call-with-output-file (test-file)
1288         (lambda (port)
1289           (display "abcde" port)))
1290       (let ((port (open-file (test-file) "r")))
1291         (read-char port)
1292         (seek port 2 SEEK_CUR)
1293         (let ((res (eqv? #\d (read-char port))))
1294           (close-port port)
1295           res)))
1296
1297     (pass-if "SEEK_SET"
1298       (call-with-output-file (test-file)
1299         (lambda (port)
1300           (display "abcde" port)))
1301       (let ((port (open-file (test-file) "r")))
1302         (read-char port)
1303         (seek port 3 SEEK_SET)
1304         (let ((res (eqv? #\d (read-char port))))
1305           (close-port port)
1306           res)))
1307
1308     (pass-if "SEEK_END"
1309       (call-with-output-file (test-file)
1310         (lambda (port)
1311           (display "abcde" port)))
1312       (let ((port (open-file (test-file) "r")))
1313         (read-char port)
1314         (seek port -2 SEEK_END)
1315         (let ((res (eqv? #\d (read-char port))))
1316           (close-port port)
1317           res)))))
1318
1319 ;;;
1320 ;;; truncate-file
1321 ;;;
1322
1323 (with-test-prefix "truncate-file"
1324
1325   (pass-if-exception "flonum file" exception:wrong-type-arg
1326     (truncate-file 1.0 123))
1327
1328   (pass-if-exception "frac file" exception:wrong-type-arg
1329     (truncate-file 7/3 123))
1330
1331   (with-test-prefix "filename"
1332
1333     (pass-if-exception "flonum length" exception:wrong-type-arg
1334       (call-with-output-file (test-file)
1335         (lambda (port)
1336           (display "hello" port)))
1337       (truncate-file (test-file) 1.0))
1338
1339     (pass-if "shorten"
1340       (call-with-output-file (test-file)
1341         (lambda (port)
1342           (display "hello" port)))
1343       (truncate-file (test-file) 1)
1344       (eqv? 1 (stat:size (stat (test-file)))))
1345
1346     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
1347       (call-with-output-file (test-file)
1348         (lambda (port)
1349           (display "hello" port)))
1350       (truncate-file (test-file))))
1351
1352   (with-test-prefix "file descriptor"
1353
1354     (pass-if "shorten"
1355       (call-with-output-file (test-file)
1356         (lambda (port)
1357           (display "hello" port)))
1358       (let ((fd (open-fdes (test-file) O_RDWR)))
1359         (truncate-file fd 1)
1360         (close-fdes fd))
1361       (eqv? 1 (stat:size (stat (test-file)))))
1362
1363     (pass-if "shorten to current pos"
1364       (call-with-output-file (test-file)
1365         (lambda (port)
1366           (display "hello" port)))
1367       (let ((fd (open-fdes (test-file) O_RDWR)))
1368         (seek fd 1 SEEK_SET)
1369         (truncate-file fd)
1370         (close-fdes fd))
1371       (eqv? 1 (stat:size (stat (test-file))))))
1372
1373   (with-test-prefix "file port"
1374
1375     (pass-if "shorten"
1376       (call-with-output-file (test-file)
1377         (lambda (port)
1378           (display "hello" port)))
1379       (let ((port (open-file (test-file) "r+")))
1380         (truncate-file port 1)
1381         (close-port port))
1382       (eqv? 1 (stat:size (stat (test-file)))))
1383
1384     (pass-if "shorten to current pos"
1385       (call-with-output-file (test-file)
1386         (lambda (port)
1387           (display "hello" port)))
1388       (let ((port (open-file (test-file) "r+")))
1389         (read-char port)
1390         (truncate-file port)
1391         (close-port port))
1392       (eqv? 1 (stat:size (stat (test-file)))))))
1393
1394
1395 ;;;; testing read-delimited and friends
1396
1397 (with-test-prefix "read-delimited!"
1398   (let ((c (make-string 20 #\!)))
1399     (call-with-input-string
1400      "defdef\nghighi\n"
1401      (lambda (port)
1402
1403        (read-delimited! "\n" c port 'concat)
1404        (pass-if "read-delimited! reads a first line"
1405                 (string=? c "defdef\n!!!!!!!!!!!!!"))
1406
1407        (read-delimited! "\n" c port 'concat 3)
1408        (pass-if "read-delimited! reads a first line"
1409                 (string=? c "defghighi\n!!!!!!!!!!"))))))
1410
1411 \f
1412 ;;;; char-ready?
1413
1414 (call-with-input-string
1415  "howdy"
1416  (lambda (port)
1417    (pass-if "char-ready? returns true on string port"
1418             (char-ready? port))))
1419
1420 ;;; This segfaults on some versions of Guile.  We really should run
1421 ;;; the tests in a subprocess...
1422
1423 (call-with-input-string
1424  "howdy"
1425  (lambda (port)
1426    (with-input-from-port
1427        port
1428      (lambda ()
1429        (pass-if "char-ready? returns true on string port as default port"
1430                 (char-ready?))))))
1431
1432 \f
1433 ;;;; pending-eof behavior
1434
1435 (with-test-prefix "pending EOF behavior"
1436   ;; Make a test port that will produce the given sequence.  Each
1437   ;; element of 'lst' may be either a character or #f (which means EOF).
1438   (define (test-soft-port . lst)
1439     (make-soft-port
1440      (vector (lambda (c) #f)            ; write char
1441              (lambda (s) #f)            ; write string
1442              (lambda () #f)             ; flush
1443              (lambda ()                 ; read char
1444                (let ((c (car lst)))
1445                  (set! lst (cdr lst))
1446                  c))
1447              (lambda () #f))            ; close
1448      "rw"))
1449
1450   (define (call-with-port p proc)
1451     (dynamic-wind
1452       (lambda () #f)
1453       (lambda () (proc p))
1454       (lambda () (close-port p))))
1455
1456   (define (call-with-test-file str proc)
1457     (let ((filename (test-file)))
1458       (dynamic-wind
1459         (lambda () (call-with-output-file filename
1460                      (lambda (p) (display str p))))
1461         (lambda () (call-with-input-file filename proc))
1462         (lambda () (delete-file (test-file))))))
1463
1464   (pass-if "peek-char does not swallow EOF (soft port)"
1465     (call-with-port (test-soft-port #\a #f #\b)
1466       (lambda (p)
1467         (and (char=? #\a  (peek-char p))
1468              (char=? #\a  (read-char p))
1469              (eof-object? (peek-char p))
1470              (eof-object? (read-char p))
1471              (char=? #\b  (peek-char p))
1472              (char=? #\b  (read-char p))))))
1473
1474   (pass-if "unread clears pending EOF (soft port)"
1475     (call-with-port (test-soft-port #\a #f #\b)
1476       (lambda (p)
1477         (and (char=? #\a  (read-char p))
1478              (eof-object? (peek-char p))
1479              (begin (unread-char #\u p)
1480                     (char=? #\u  (read-char p)))))))
1481
1482   (pass-if "unread clears pending EOF (string port)"
1483     (call-with-input-string "a"
1484       (lambda (p)
1485         (and (char=? #\a  (read-char p))
1486              (eof-object? (peek-char p))
1487              (begin (unread-char #\u p)
1488                     (char=? #\u  (read-char p)))))))
1489
1490   (pass-if "unread clears pending EOF (file port)"
1491     (call-with-test-file
1492      "a"
1493      (lambda (p)
1494        (and (char=? #\a  (read-char p))
1495             (eof-object? (peek-char p))
1496             (begin (unread-char #\u p)
1497                    (char=? #\u  (read-char p)))))))
1498
1499   (pass-if "seek clears pending EOF (string port)"
1500     (call-with-input-string "a"
1501       (lambda (p)
1502         (and (char=? #\a  (read-char p))
1503              (eof-object? (peek-char p))
1504              (begin (seek p 0 SEEK_SET)
1505                     (char=? #\a (read-char p)))))))
1506
1507   (pass-if "seek clears pending EOF (file port)"
1508     (call-with-test-file
1509      "a"
1510      (lambda (p)
1511        (and (char=? #\a  (read-char p))
1512             (eof-object? (peek-char p))
1513             (begin (seek p 0 SEEK_SET)
1514                    (char=? #\a (read-char p))))))))
1515
1516 \f
1517 ;;;; Close current-input-port, and make sure everyone can handle it.
1518
1519 (with-test-prefix "closing current-input-port"
1520   (for-each (lambda (procedure name)
1521               (with-input-from-port
1522                   (call-with-input-string "foo" (lambda (p) p))
1523                 (lambda ()
1524                   (close-port (current-input-port))
1525                   (pass-if-exception name
1526                     exception:wrong-type-arg
1527                     (procedure)))))
1528             (list read read-char read-line)
1529             '("read" "read-char" "read-line")))
1530
1531 \f
1532
1533 (with-test-prefix "setvbuf"
1534
1535   (pass-if-exception "closed port"
1536       exception:wrong-type-arg
1537     (let ((port (open-input-file "/dev/null")))
1538       (close-port port)
1539       (setvbuf port _IOFBF)))
1540
1541   (pass-if-exception "string port"
1542       exception:wrong-type-arg
1543     (let ((port (open-input-string "Hey!")))
1544       (close-port port)
1545       (setvbuf port _IOFBF)))
1546
1547   (pass-if "line/column number preserved"
1548     ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1549     ;; line and/or column number.
1550     (call-with-output-file (test-file)
1551       (lambda (p)
1552         (display "This is GNU Guile.\nWelcome." p)))
1553     (call-with-input-file (test-file)
1554       (lambda (p)
1555         (and (eqv? #\T (read-char p))
1556              (let ((line (port-line p))
1557                    (col  (port-column p)))
1558                (and (= line 0) (= col 1)
1559                     (begin
1560                       (setvbuf p _IOFBF 777)
1561                       (let ((line* (port-line p))
1562                             (col*  (port-column p)))
1563                         (and (= line line*)
1564                              (= col col*)))))))))))
1565
1566 \f
1567
1568 (pass-if-equal "unget-bytevector"
1569     #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
1570             1 2 3 4 251 253 254 255)
1571   (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
1572     (unget-bytevector port #vu8(200 201 202 203))
1573     (unget-bytevector port #vu8(20 21 22 23 24))
1574     (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
1575     (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
1576     (unget-bytevector port #vu8(10 11))
1577     (get-bytevector-all port)))
1578
1579 \f
1580
1581 (with-test-prefix "unicode byte-order marks (BOMs)"
1582
1583   (define (bv-read-test* encoding bv proc)
1584     (let ((port (open-bytevector-input-port bv)))
1585       (set-port-encoding! port encoding)
1586       (proc port)))
1587
1588   (define (bv-read-test encoding bv)
1589     (bv-read-test* encoding bv read-string))
1590
1591   (define (bv-write-test* encoding proc)
1592     (call-with-values
1593         (lambda () (open-bytevector-output-port))
1594       (lambda (port get-bytevector)
1595         (set-port-encoding! port encoding)
1596         (proc port)
1597         (get-bytevector))))
1598
1599   (define (bv-write-test encoding str)
1600     (bv-write-test* encoding
1601                     (lambda (p)
1602                       (display str p))))
1603
1604   (pass-if-equal "BOM not discarded from Latin-1 stream"
1605       "\xEF\xBB\xBF\x61"
1606     (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
1607
1608   (pass-if-equal "BOM not discarded from Latin-2 stream"
1609       "\u010F\u0165\u017C\x61"
1610     (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
1611
1612   (pass-if-equal "BOM not discarded from UTF-16BE stream"
1613       "\uFEFF\x61"
1614     (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
1615
1616   (pass-if-equal "BOM not discarded from UTF-16LE stream"
1617       "\uFEFF\x61"
1618     (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
1619
1620   (pass-if-equal "BOM not discarded from UTF-32BE stream"
1621       "\uFEFF\x61"
1622     (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
1623                                        #x00 #x00 #x00 #x61)))
1624
1625   (pass-if-equal "BOM not discarded from UTF-32LE stream"
1626       "\uFEFF\x61"
1627     (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
1628                                        #x61 #x00 #x00 #x00)))
1629
1630   (pass-if-equal "BOM not written to UTF-8 stream"
1631       #vu8(#x61)
1632     (bv-write-test "UTF-8" "a"))
1633
1634   (pass-if-equal "BOM not written to UTF-16BE stream"
1635       #vu8(#x00 #x61)
1636     (bv-write-test "UTF-16BE" "a"))
1637
1638   (pass-if-equal "BOM not written to UTF-16LE stream"
1639       #vu8(#x61 #x00)
1640     (bv-write-test "UTF-16LE" "a"))
1641
1642   (pass-if-equal "BOM not written to UTF-32BE stream"
1643       #vu8(#x00 #x00 #x00 #x61)
1644     (bv-write-test "UTF-32BE" "a"))
1645
1646   (pass-if-equal "BOM not written to UTF-32LE stream"
1647       #vu8(#x61 #x00 #x00 #x00)
1648     (bv-write-test "UTF-32LE" "a"))
1649
1650   (pass-if "Don't read from the port unless user asks to"
1651     (let* ((p (make-soft-port
1652                (vector
1653                 (lambda (c) #f)           ; write char
1654                 (lambda (s) #f)           ; write string
1655                 (lambda () #f)            ; flush
1656                 (lambda () (throw 'fail)) ; read char
1657                 (lambda () #f))
1658                "rw")))
1659       (set-port-encoding! p "UTF-16")
1660       (display "abc" p)
1661       (set-port-encoding! p "UTF-32")
1662       (display "def" p)
1663       #t))
1664
1665   ;; TODO: test that input and output streams are independent when
1666   ;; appropriate, and linked when appropriate.
1667
1668   (pass-if-equal "BOM discarded from start of UTF-8 stream"
1669       "a"
1670     (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
1671
1672   (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
1673       '(#\a "a")
1674     (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
1675                    (lambda (p)
1676                      (let ((c (read-char p)))
1677                        (seek p 0 SEEK_SET)
1678                        (let ((s (read-string p)))
1679                          (list c s))))))
1680
1681   (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
1682       "\uFEFFa"
1683     (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
1684
1685   (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
1686       "\uFEFFb"
1687     (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
1688                    (lambda (p)
1689                      (seek p 1 SEEK_SET)
1690                      (read-string p))))
1691
1692   (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
1693       "a\uFEFFb"
1694     (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
1695
1696   (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
1697       #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
1698     (bv-write-test "UTF-16" "ab"))
1699
1700   (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
1701       #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
1702     (bv-write-test* "UTF-16"
1703                     (lambda (p)
1704                       (display "ab" p)
1705                       (set-port-encoding! p "UTF-16")
1706                       (display "cd" p))))
1707
1708   (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
1709       "a"
1710     (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
1711
1712   (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
1713       '(#\a "a")
1714     (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
1715                    (lambda (p)
1716                      (let ((c (read-char p)))
1717                        (seek p 0 SEEK_SET)
1718                        (let ((s (read-string p)))
1719                          (list c s))))))
1720
1721   (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
1722       "\uFEFFa"
1723     (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
1724
1725   (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
1726       "\uFEFFa"
1727     (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
1728                    (lambda (p)
1729                      (seek p 2 SEEK_SET)
1730                      (read-string p))))
1731
1732   (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
1733       "a\uFEFFb"
1734     (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
1735
1736   (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
1737       "a"
1738     (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
1739
1740   (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
1741       '(#\a "a")
1742     (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
1743                    (lambda (p)
1744                      (let ((c (read-char p)))
1745                        (seek p 0 SEEK_SET)
1746                        (let ((s (read-string p)))
1747                          (list c s))))))
1748
1749   (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
1750       "\uFEFFa"
1751     (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
1752
1753   (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
1754       "a"
1755     (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1756                                      #x00 #x00 #x00 #x61)))
1757
1758   (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
1759       '(#\a "a")
1760     (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
1761                                       #x00 #x00 #x00 #x61)
1762                    (lambda (p)
1763                      (let ((c (read-char p)))
1764                        (seek p 0 SEEK_SET)
1765                        (let ((s (read-string p)))
1766                          (list c s))))))
1767
1768   (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
1769       "\uFEFFa"
1770     (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1771                                      #x00 #x00 #xFE #xFF
1772                                      #x00 #x00 #x00 #x61)))
1773
1774   (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
1775       "\uFEFFa"
1776     (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
1777                                       #x00 #x00 #xFE #xFF
1778                                       #x00 #x00 #x00 #x61)
1779                    (lambda (p)
1780                      (seek p 4 SEEK_SET)
1781                      (read-string p))))
1782
1783   (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
1784       "ab"
1785     (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
1786                    (lambda (p)
1787                      (let ((a (read-char p)))
1788                        (set-port-encoding! p "UTF-16")
1789                        (string a (read-char p))))))
1790
1791   (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
1792       "ab"
1793     (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
1794                    (lambda (p)
1795                      (let ((a (read-char p)))
1796                        (set-port-encoding! p "UTF-16")
1797                        (string a (read-char p))))))
1798
1799   (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
1800       "ab"
1801     (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1802                                       #x00 #x00 #xFE #xFF
1803                                       #x00 #x00 #x00 #x62)
1804                    (lambda (p)
1805                      (let ((a (read-char p)))
1806                        (set-port-encoding! p "UTF-32")
1807                        (string a (read-char p))))))
1808
1809   (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
1810       "ab"
1811     (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1812                                       #xFF #xFE #x00 #x00
1813                                       #x62 #x00 #x00 #x00)
1814                    (lambda (p)
1815                      (let ((a (read-char p)))
1816                        (set-port-encoding! p "UTF-32")
1817                        (string a (read-char p))))))
1818
1819   (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
1820       "a\uFEFFb"
1821     (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
1822                                                #x00 #x00 #xFE #xFF
1823                                                #x00 #x00 #x00 #x62)))
1824
1825   (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
1826       "a"
1827     (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1828                                      #x61 #x00 #x00 #x00)))
1829
1830   (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
1831       '(#\a "a")
1832     (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
1833                                       #x61 #x00 #x00 #x00)
1834                    (lambda (p)
1835                      (let ((c (read-char p)))
1836                        (seek p 0 SEEK_SET)
1837                        (let ((s (read-string p)))
1838                          (list c s))))))
1839
1840   (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
1841       "\uFEFFa"
1842     (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1843                                      #xFF #xFE #x00 #x00
1844                                      #x61 #x00 #x00 #x00))))
1845
1846 \f
1847
1848 (define-syntax-rule (with-load-path path body ...)
1849   (let ((new path)
1850         (old %load-path))
1851     (dynamic-wind
1852       (lambda ()
1853         (set! %load-path new))
1854       (lambda ()
1855         body ...)
1856       (lambda ()
1857         (set! %load-path old)))))
1858
1859 (with-test-prefix "%file-port-name-canonicalization"
1860
1861   (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
1862     ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
1863     ;; of "/dev/null".  See
1864     ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
1865     ;; for a discussion.
1866     (with-load-path (cons "" (delete "/" %load-path))
1867       (with-fluids ((%file-port-name-canonicalization 'relative))
1868         (port-filename (open-input-file "/dev/null")))))
1869
1870   (pass-if-equal "relative canonicalization with /" "dev/null"
1871     (with-load-path (cons "/" %load-path)
1872       (with-fluids ((%file-port-name-canonicalization 'relative))
1873         (port-filename (open-input-file "/dev/null")))))
1874
1875   (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
1876     ;; If an entry in %LOAD-PATH is not canonical, then
1877     ;; `scm_i_relativize_path' is unable to do its job.
1878     (if (equal? (map canonicalize-path %load-path) %load-path)
1879         (with-fluids ((%file-port-name-canonicalization 'relative))
1880           (port-filename
1881            (open-input-file (%search-load-path "ice-9/q.scm"))))
1882         (throw 'unresolved)))
1883
1884   (pass-if-equal "absolute canonicalization from ice-9"
1885       (canonicalize-path
1886        (string-append (assoc-ref %guile-build-info 'top_srcdir)
1887                       "/module/ice-9/q.scm"))
1888     (with-fluids ((%file-port-name-canonicalization 'absolute))
1889       (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
1890
1891 (with-test-prefix "file name separators"
1892
1893   (pass-if "no backslash separators in Windows file names"
1894     ;; In Guile 2.0.11 and earlier, %load-path on Windows could
1895     ;; include file names with backslashes, and `getcwd' on Windows
1896     ;; would always return a directory name with backslashes.
1897     (or (not (file-name-separator? #\\))
1898         (with-load-path (cons (getcwd) %load-path)
1899           (not (string-index (%search-load-path (basename (test-file)))
1900                              #\\))))))
1901
1902 (delete-file (test-file))
1903
1904 ;;; Local Variables:
1905 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
1906 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)
1907 ;;; End: