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