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 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                                    (uniform-vector->list
 247                                     (string->utf8 test-string))))))
 248                  (write-line test-string port)
 249                  (close-port port)
 250                  (let* ((in-port (open-file filename "rb"))
 251                         (line (read-line in-port)))
 252                    (close-port in-port)
 253                    (delete-file filename)
 254                    (string=? line binary-test-string)))))
 255
 256 ;;; binary mode ignores file coding declaration
 257 (pass-if "file: binary mode ignores file coding declaration"
 258   (with-fluids ((%default-port-encoding "UTF-8"))
 259                (let* ((filename (test-file))
 260                       (port (open-file filename "w"))
 261                       (test-string "一二三")
 262                       (binary-test-string
 263                        (apply string
 264                               (map integer->char
 265                                    (uniform-vector->list
 266                                     (string->utf8 test-string))))))
 267                  (write-line ";; coding: utf-8" port)
 268                  (write-line test-string port)
 269                  (close-port port)
 270                  (let* ((in-port (open-file filename "rb"))
 271                         (line1 (read-line in-port))
 272                         (line2 (read-line in-port)))
 273                    (close-port in-port)
 274                    (delete-file filename)
 275                    (string=? line2 binary-test-string)))))
 276
 277 ;; open-file ignores file coding declaration
 278 (pass-if "file: open-file ignores coding declarations"
 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 ;;; ungetting characters and strings.
 294 (with-input-from-string "walk on the moon\nmoon"
 295                         (lambda ()
 296                           (read-char)
 297                           (unread-char #\a (current-input-port))
 298                           (pass-if "unread-char"
 299                                    (char=? (read-char) #\a))
 300                           (read-line)
 301                           (let ((replacenoid "chicken enchilada"))
 302                             (unread-char #\newline (current-input-port))
 303                             (unread-string replacenoid (current-input-port))
 304                             (pass-if "unread-string"
 305                                      (string=? (read-line) replacenoid)))
 306                           (pass-if "unread residue"
 307                                    (string=? (read-line) "moon"))))
 308
 309 ;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
 310 ;;; the reading end.  try to read a byte: should get EAGAIN or
 311 ;;; EWOULDBLOCK error.
 312 (let* ((p (pipe))
 313        (r (car p)))
 314   (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
 315   (pass-if "non-blocking-I/O"
 316            (catch 'system-error
 317                   (lambda () (read-char r) #f)
 318                   (lambda (key . args)
 319                     (and (eq? key 'system-error)
 320                          (let ((errno (car (list-ref args 3))))
 321                            (or (= errno EAGAIN)
 322                                (= errno EWOULDBLOCK))))))))
 323
 324 \f
 325 ;;;; Pipe (popen) ports.
 326
 327 ;;; Run a command, and read its output.
 328 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
 329        (in-string (read-all pipe)))
 330   (close-pipe pipe)
 331   (pass-if "pipe: read"
 332            (equal? in-string "Howdy there, partner!\n")))
 333
 334 ;;; Run a command, send some output to it, and see if it worked.
 335 (let* ((filename (test-file))
 336        (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
 337   (display "Now Jimmy lives on a mushroom cloud\n" pipe)
 338   (display "Mommy, why does everybody have a bomb?\n" pipe)
 339   (close-pipe pipe)
 340   (let ((in-string (read-file filename)))
 341     (pass-if "pipe: write"
 342              (equal? in-string "Mommy, why does everybody have a bomb?\n")))
 343   (delete-file filename))
 344
 345 \f
 346 ;;;; Void ports.  These are so trivial we don't test them.
 347
 348 \f
 349 ;;;; String ports.
 350
 351 (with-test-prefix "string ports"
 352
 353   ;; Write text to a string port.
 354   (let* ((string "Howdy there, partner!")
 355          (in-string (call-with-output-string
 356                      (lambda (port)
 357                        (display string port)
 358                        (newline port)))))
 359     (pass-if "display text"
 360              (equal? in-string (string-append string "\n"))))
 361
 362   ;; Write an s-expression to a string port.
 363   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
 364          (in-sexpr
 365           (call-with-input-string (call-with-output-string
 366                                    (lambda (port)
 367                                      (write sexpr port)))
 368                                   read)))
 369     (pass-if "write/read sexpr"
 370              (equal? in-sexpr sexpr)))
 371
 372   ;; seeking and unreading from an input string.
 373   (let ((text "that text didn't look random to me"))
 374     (call-with-input-string text
 375                             (lambda (p)
 376                               (pass-if "input tell 0"
 377                                        (= (seek p 0 SEEK_CUR) 0))
 378                               (read-char p)
 379                               (pass-if "input tell 1"
 380                                        (= (seek p 0 SEEK_CUR) 1))
 381                               (unread-char #\x p)
 382                               (pass-if "input tell back to 0"
 383                                        (= (seek p 0 SEEK_CUR) 0))
 384                               (pass-if "input ungetted char"
 385                                        (char=? (read-char p) #\x))
 386                               (seek p 0 SEEK_END)
 387                               (pass-if "input seek to end"
 388                                        (= (seek p 0 SEEK_CUR)
 389                                           (string-length text)))
 390                               (unread-char #\x p)
 391                               (pass-if "input seek to beginning"
 392                                        (= (seek p 0 SEEK_SET) 0))
 393                               (pass-if "input reread first char"
 394                                        (char=? (read-char p)
 395                                                (string-ref text 0))))))
 396
 397   ;; seeking an output string.
 398   (let* ((text (string-copy "123456789"))
 399          (len (string-length text))
 400          (result (call-with-output-string
 401                   (lambda (p)
 402                     (pass-if "output tell 0"
 403                              (= (seek p 0 SEEK_CUR) 0))
 404                     (display text p)
 405                     (pass-if "output tell end"
 406                              (= (seek p 0 SEEK_CUR) len))
 407                     (pass-if "output seek to beginning"
 408                              (= (seek p 0 SEEK_SET) 0))
 409                     (write-char #\a p)
 410                     (seek p -1 SEEK_END)
 411                     (pass-if "output seek to last char"
 412                              (= (seek p 0 SEEK_CUR)
 413                                 (- len 1)))
 414                     (write-char #\b p)))))
 415     (string-set! text 0 #\a)
 416     (string-set! text (- len 1) #\b)
 417     (pass-if "output check"
 418              (string=? text result)))
 419
 420   (pass-if "encoding failure leads to exception"
 421     ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
 422     ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
 423     (catch 'encoding-error
 424       (lambda ()
 425         (with-fluids ((%default-port-encoding "ISO-8859-1"))
 426           (let ((p (open-input-string "λ")))      ; raise an exception
 427             #f)))
 428       (lambda (key . rest)
 429         #t)
 430       (lambda (key . rest)
 431         ;; At this point, the port-table mutex used to be still held,
 432         ;; hence the deadlock.  This situation would occur when trying
 433         ;; to print a backtrace, for instance.
 434         (input-port? (open-input-string "foo")))))
 435
 436   (pass-if "%default-port-encoding is honored"
 437     (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
 438       (equal? (map (lambda (e)
 439                      (with-fluids ((%default-port-encoding e))
 440                        (call-with-output-string
 441                          (lambda (p)
 442                            (and (string=? e (port-encoding p))
 443                                 (display (port-encoding p) p))))))
 444                    encodings)
 445               encodings)))
 446
 447   (pass-if "%default-port-conversion-strategy is honored"
 448     (let ((strategies '(error substitute escape)))
 449       (equal? (map (lambda (s)
 450                      (with-fluids ((%default-port-conversion-strategy s))
 451                        (call-with-output-string
 452                         (lambda (p)
 453                           (and (eq? s (port-conversion-strategy p))
 454                                (begin
 455                                  (set-port-conversion-strategy! p s)
 456                                  (display (port-conversion-strategy p)
 457                                           p)))))))
 458                    strategies)
 459               (map symbol->string strategies))))
 460
 461   (pass-if "suitable encoding [latin-1]"
 462     (let ((str "hello, world"))
 463       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 464         (equal? str
 465                 (with-output-to-string
 466                   (lambda ()
 467                     (display str)))))))
 468
 469   (pass-if "suitable encoding [latin-3]"
 470     (let ((str "ĉu bone?"))
 471       (with-fluids ((%default-port-encoding "ISO-8859-3"))
 472         (equal? str
 473                 (with-output-to-string
 474                   (lambda ()
 475                     (display str)))))))
 476
 477   (pass-if "wrong encoding, error"
 478     (let ((str "ĉu bone?"))
 479       (catch 'encoding-error
 480         (lambda ()
 481           ;; Latin-1 cannot represent ‘ĉ’.
 482           (with-fluids ((%default-port-encoding "ISO-8859-1")
 483                         (%default-port-conversion-strategy 'error))
 484             (with-output-to-string
 485               (lambda ()
 486                 (display str))))
 487           #f)                            ; so the test really fails here
 488         (lambda (key subr message errno port chr)
 489           (and (eqv? chr #\ĉ)
 490                (string? (strerror errno)))))))
 491
 492   (pass-if "wrong encoding, substitute"
 493     (let ((str "ĉu bone?"))
 494       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 495         (string=? (with-output-to-string
 496                     (lambda ()
 497                       (set-port-conversion-strategy! (current-output-port)
 498                                                      'substitute)
 499                       (display str)))
 500                   "?u bone?"))))
 501
 502   (pass-if "wrong encoding, escape"
 503     (let ((str "ĉu bone?"))
 504       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 505         (string=? (with-output-to-string
 506                     (lambda ()
 507                       (set-port-conversion-strategy! (current-output-port)
 508                                                      'escape)
 509                       (display str)))
 510                   "\\u0109u bone?"))))
 511
 512   (pass-if "peek-char [latin-1]"
 513     (let ((p (with-fluids ((%default-port-encoding #f))
 514                (open-input-string "hello, world"))))
 515       (and (char=? (peek-char p) #\h)
 516            (char=? (peek-char p) #\h)
 517            (char=? (peek-char p) #\h)
 518            (= (port-line p) 0)
 519            (= (port-column p) 0))))
 520
 521   (pass-if "peek-char [utf-8]"
 522     (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
 523                (open-input-string "안녕하세요"))))
 524       (and (char=? (peek-char p) #\안)
 525            (char=? (peek-char p) #\안)
 526            (char=? (peek-char p) #\안)
 527            (= (port-line p) 0)
 528            (= (port-column p) 0))))
 529
 530   (pass-if "peek-char [utf-16]"
 531     (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
 532                (open-input-string "안녕하세요"))))
 533       (and (char=? (peek-char p) #\안)
 534            (char=? (peek-char p) #\안)
 535            (char=? (peek-char p) #\안)
 536            (= (port-line p) 0)
 537            (= (port-column p) 0))))
 538
 539   ;; Mini DSL to test decoding error handling.
 540   (letrec-syntax ((decoding-error?
 541                    (syntax-rules ()
 542                      ((_ port exp)
 543                       (catch 'decoding-error
 544                         (lambda ()
 545                           (pk 'exp exp)
 546                           #f)
 547                         (lambda (key subr message errno p)
 548                           (and (eq? p port)
 549                                (not (= 0 errno))))))))
 550                   (make-check
 551                    (syntax-rules (-> error eof)
 552                      ((_ port (proc -> error))
 553                       (if (eq? 'substitute
 554                                (port-conversion-strategy port))
 555                           (eqv? (proc port) #\?)
 556                           (decoding-error? port (proc port))))
 557                      ((_ port (proc -> eof))
 558                       (eof-object? (proc port)))
 559                      ((_ port (proc -> char))
 560                       (eqv? (proc port) char))))
 561                   (make-checks
 562                    (syntax-rules ()
 563                      ((_ port check ...)
 564                       (and (make-check port check) ...))))
 565                   (make-peek+read-checks
 566                    (syntax-rules ()
 567                      ((_ port (result ...) e1 expected ...)
 568                       (make-peek+read-checks port
 569                                              (result ...
 570                                                      (peek-char -> e1)
 571                                                      (read-char -> e1))
 572                                              expected ...))
 573                      ((_ port (result ...))
 574                       (make-checks port result ...))
 575                      ((_ port #f e1 expected ...)
 576                       (make-peek+read-checks port
 577                                              ((peek-char -> e1)
 578                                               (read-char -> e1))
 579                                              expected ...))))
 580
 581                   (test-decoding-error*
 582                       (syntax-rules ()
 583                         ((_ sequence encoding strategy (expected ...))
 584                          (begin
 585                           (pass-if (format #f "test-decoding-error: ~s ~s ~s"
 586                                            'sequence encoding strategy)
 587                             (let ((p (open-bytevector-input-port
 588                                       (u8-list->bytevector 'sequence))))
 589                               (set-port-encoding! p encoding)
 590                               (set-port-conversion-strategy! p strategy)
 591                               (make-checks p
 592                                            (read-char -> expected) ...)))
 593
 594                           ;; Generate the same test, but with one
 595                           ;; `peek-char' call before each `read-char'.
 596                           ;; Both should yield the same result.
 597                           (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
 598                                            'sequence encoding strategy)
 599                             (let ((p (open-bytevector-input-port
 600                                       (u8-list->bytevector 'sequence))))
 601                               (set-port-encoding! p encoding)
 602                               (set-port-conversion-strategy! p strategy)
 603                               (make-peek+read-checks p #f expected
 604                                                      ...)))))))
 605                   (test-decoding-error
 606                       (syntax-rules ()
 607                         ((_ sequence encoding (expected ...))
 608                          (begin
 609                            (test-decoding-error* sequence encoding 'error
 610                              (expected ...))
 611
 612                            ;; `escape' should behave exactly like `error'.
 613                            (test-decoding-error* sequence encoding 'escape
 614                              (expected ...))
 615
 616                            (test-decoding-error* sequence encoding 'substitute
 617                              (expected ...)))))))
 618
 619     (test-decoding-error (255 65 66 67) "UTF-8"
 620       (error #\A #\B #\C eof))
 621
 622     (test-decoding-error (255 206 187 206 188) "UTF-8"
 623       (error #\λ #\μ eof))
 624
 625     (test-decoding-error (206 187 206) "UTF-8"
 626       ;; Unterminated sequence.
 627       (#\λ error eof))
 628
 629     ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
 630     ;; of the "Conformance" chapter of Unicode 6.0.0.)
 631
 632     (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
 633       (error                ;; C0: should be in the C2..DF range
 634        error                ;; 80: invalid
 635        #\A
 636        eof))
 637
 638     (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
 639       ;; Section 3.9 of Unicode 6.0.0 reads:
 640       ;;   "If the converter encounters an ill-formed UTF-8 code unit
 641       ;;   sequence which starts with a valid first byte, but which does
 642       ;;   not continue with valid successor bytes (see Table 3-7), it
 643       ;;   must not consume the successor bytes".
 644       ;; Glibc/libiconv do not conform to it and instead swallow the
 645       ;; #x41.  This example appears literally in Section 3.9.
 646       (error                ;; 41: invalid successor
 647        #\A                  ;; 41: valid starting byte
 648        #\B
 649        eof))
 650
 651     (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
 652       ;; According to Unicode 6.0.0, Section 3.9, "the only formal
 653       ;; requirement mandated by Unicode conformance for a converter is
 654       ;; that the <41> be processed and correctly interpreted as
 655       ;; <U+0041>".
 656       (error                ;; 2nd byte should be in the A0..BF range
 657        error                ;; 80: not a valid starting byte
 658        error                ;; 80: not a valid starting byte
 659        #\A
 660        eof))
 661
 662     (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
 663       (error                ;; 3rd byte should be in the 80..BF range
 664        #\A
 665        #\B
 666        eof))
 667
 668     (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
 669       (error                ;; 2nd byte should be in the 90..BF range
 670        error                ;; 88: not a valid starting byte
 671        error                ;; 88: not a valid starting byte
 672        error                ;; 88: not a valid starting byte
 673        eof))))
 674
 675 (with-test-prefix "call-with-output-string"
 676
 677   ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
 678   ;; occur.
 679   (pass-if-exception "proc closes port" exception:wrong-type-arg
 680     (call-with-output-string close-port)))
 681
 682
 683 \f
 684 ;;;; Soft ports.  No tests implemented yet.
 685
 686 \f
 687 ;;;; Generic operations across all port types.
 688
 689 (let ((port-loop-temp (test-file)))
 690
 691   ;; Return a list of input ports that all return the same text.
 692   ;; We map tests over this list.
 693   (define (input-port-list text)
 694
 695     ;; Create a text file some of the ports will use.
 696     (let ((out-port (open-output-file port-loop-temp)))
 697       (display text out-port)
 698       (close-port out-port))
 699
 700     (list (open-input-file port-loop-temp)
 701           (open-input-pipe (string-append "cat " port-loop-temp))
 702           (call-with-input-string text (lambda (x) x))
 703           ;; We don't test soft ports at the moment.
 704           ))
 705
 706   (define port-list-names '("file" "pipe" "string"))
 707
 708   ;; Test the line counter.
 709   (define (test-line-counter text second-line final-column)
 710     (with-test-prefix "line counter"
 711       (let ((ports (input-port-list text)))
 712         (for-each
 713          (lambda (port port-name)
 714            (with-test-prefix port-name
 715              (pass-if "at beginning of input"
 716                       (= (port-line port) 0))
 717              (pass-if "read first character"
 718                       (eqv? (read-char port) #\x))
 719              (pass-if "after reading one character"
 720                       (= (port-line port) 0))
 721              (pass-if "read first newline"
 722                       (eqv? (read-char port) #\newline))
 723              (pass-if "after reading first newline char"
 724                       (= (port-line port) 1))
 725              (pass-if "second line read correctly"
 726                       (equal? (read-line port) second-line))
 727              (pass-if "read-line increments line number"
 728                       (= (port-line port) 2))
 729              (pass-if "read-line returns EOF"
 730                       (let loop ((i 0))
 731                         (cond
 732                          ((eof-object? (read-line port)) #t)
 733                          ((> i 20) #f)
 734                          (else (loop (+ i 1))))))
 735              (pass-if "line count is 5 at EOF"
 736                       (= (port-line port) 5))
 737              (pass-if "column is correct at EOF"
 738                       (= (port-column port) final-column))))
 739          ports port-list-names)
 740         (for-each close-port ports)
 741         (delete-file port-loop-temp))))
 742
 743   (with-test-prefix "newline"
 744     (test-line-counter
 745      (string-append "x\n"
 746                     "He who receives an idea from me, receives instruction\n"
 747                     "himself without lessening mine; as he who lights his\n"
 748                     "taper at mine, receives light without darkening me.\n"
 749                     "  --- Thomas Jefferson\n")
 750      "He who receives an idea from me, receives instruction"
 751      0))
 752
 753   (with-test-prefix "no newline"
 754     (test-line-counter
 755      (string-append "x\n"
 756                     "He who receives an idea from me, receives instruction\n"
 757                     "himself without lessening mine; as he who lights his\n"
 758                     "taper at mine, receives light without darkening me.\n"
 759                     "  --- Thomas Jefferson\n"
 760                     "no newline here")
 761      "He who receives an idea from me, receives instruction"
 762      15)))
 763
 764 ;; Test port-line and port-column for output ports
 765
 766 (define (test-output-line-counter text final-column)
 767   (with-test-prefix "port-line and port-column for output ports"
 768     (let ((port (open-output-string)))
 769       (pass-if "at beginning of input"
 770                (and (= (port-line port) 0)
 771                     (= (port-column port) 0)))
 772       (write-char #\x port)
 773       (pass-if "after writing one character"
 774                (and (= (port-line port) 0)
 775                     (= (port-column port) 1)))
 776       (write-char #\newline port)
 777       (pass-if "after writing first newline char"
 778                (and (= (port-line port) 1)
 779                     (= (port-column port) 0)))
 780       (display text port)
 781       (pass-if "line count is 5 at end"
 782                (= (port-line port) 5))
 783       (pass-if "column is correct at end"
 784                (= (port-column port) final-column)))))
 785
 786 (test-output-line-counter
 787  (string-append "He who receives an idea from me, receives instruction\n"
 788                 "himself without lessening mine; as he who lights his\n"
 789                 "taper at mine, receives light without darkening me.\n"
 790                 "  --- Thomas Jefferson\n"
 791                 "no newline here")
 792  15)
 793
 794 (with-test-prefix "port-column"
 795
 796   (with-test-prefix "output"
 797
 798     (pass-if "x"
 799       (let ((port (open-output-string)))
 800         (display "x" port)
 801         (= 1 (port-column port))))
 802
 803     (pass-if "\\a"
 804       (let ((port (open-output-string)))
 805         (display "\a" port)
 806         (= 0 (port-column port))))
 807
 808     (pass-if "x\\a"
 809       (let ((port (open-output-string)))
 810         (display "x\a" port)
 811         (= 1 (port-column port))))
 812
 813     (pass-if "\\x08 backspace"
 814       (let ((port (open-output-string)))
 815         (display "\x08" port)
 816         (= 0 (port-column port))))
 817
 818     (pass-if "x\\x08 backspace"
 819       (let ((port (open-output-string)))
 820         (display "x\x08" port)
 821         (= 0 (port-column port))))
 822
 823     (pass-if "\\n"
 824       (let ((port (open-output-string)))
 825         (display "\n" port)
 826         (= 0 (port-column port))))
 827
 828     (pass-if "x\\n"
 829       (let ((port (open-output-string)))
 830         (display "x\n" port)
 831         (= 0 (port-column port))))
 832
 833     (pass-if "\\r"
 834       (let ((port (open-output-string)))
 835         (display "\r" port)
 836         (= 0 (port-column port))))
 837
 838     (pass-if "x\\r"
 839       (let ((port (open-output-string)))
 840         (display "x\r" port)
 841         (= 0 (port-column port))))
 842
 843     (pass-if "\\t"
 844       (let ((port (open-output-string)))
 845         (display "\t" port)
 846         (= 8 (port-column port))))
 847
 848     (pass-if "x\\t"
 849       (let ((port (open-output-string)))
 850         (display "x\t" port)
 851         (= 8 (port-column port)))))
 852
 853   (with-test-prefix "input"
 854
 855     (pass-if "x"
 856       (let ((port (open-input-string "x")))
 857         (while (not (eof-object? (read-char port))))
 858         (= 1 (port-column port))))
 859
 860     (pass-if "\\a"
 861       (let ((port (open-input-string "\a")))
 862         (while (not (eof-object? (read-char port))))
 863         (= 0 (port-column port))))
 864
 865     (pass-if "x\\a"
 866       (let ((port (open-input-string "x\a")))
 867         (while (not (eof-object? (read-char port))))
 868         (= 1 (port-column port))))
 869
 870     (pass-if "\\x08 backspace"
 871       (let ((port (open-input-string "\x08")))
 872         (while (not (eof-object? (read-char port))))
 873         (= 0 (port-column port))))
 874
 875     (pass-if "x\\x08 backspace"
 876       (let ((port (open-input-string "x\x08")))
 877         (while (not (eof-object? (read-char port))))
 878         (= 0 (port-column port))))
 879
 880     (pass-if "\\n"
 881       (let ((port (open-input-string "\n")))
 882         (while (not (eof-object? (read-char port))))
 883         (= 0 (port-column port))))
 884
 885     (pass-if "x\\n"
 886       (let ((port (open-input-string "x\n")))
 887         (while (not (eof-object? (read-char port))))
 888         (= 0 (port-column port))))
 889
 890     (pass-if "\\r"
 891       (let ((port (open-input-string "\r")))
 892         (while (not (eof-object? (read-char port))))
 893         (= 0 (port-column port))))
 894
 895     (pass-if "x\\r"
 896       (let ((port (open-input-string "x\r")))
 897         (while (not (eof-object? (read-char port))))
 898         (= 0 (port-column port))))
 899
 900     (pass-if "\\t"
 901       (let ((port (open-input-string "\t")))
 902         (while (not (eof-object? (read-char port))))
 903         (= 8 (port-column port))))
 904
 905     (pass-if "x\\t"
 906       (let ((port (open-input-string "x\t")))
 907         (while (not (eof-object? (read-char port))))
 908         (= 8 (port-column port))))))
 909
 910 (with-test-prefix "port-line"
 911
 912   ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
 913   ;; scm_t_port actually holds a long; this restricted the range on 64-bit
 914   ;; systems
 915   (pass-if "set most-positive-fixnum/2"
 916     (let ((n    (quotient most-positive-fixnum 2))
 917           (port (open-output-string)))
 918       (set-port-line! port n)
 919       (eqv? n (port-line port)))))
 920
 921 (with-test-prefix "port-encoding"
 922
 923   (pass-if-exception "set-port-encoding!, wrong encoding"
 924     exception:miscellaneous-error
 925     (let ((p (open-input-string "")))
 926       (set-port-encoding! p "does-not-exist")
 927       (read p)))
 928
 929   (pass-if-exception "%default-port-encoding, wrong encoding"
 930     exception:miscellaneous-error
 931     (read (with-fluids ((%default-port-encoding "does-not-exist"))
 932             (open-input-string "")))))
 933
 934 ;;;
 935 ;;; port-for-each
 936 ;;;
 937
 938 (with-test-prefix "port-for-each"
 939
 940   ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
 941   ;; its iterator func if a port was inaccessible in the last gc mark but
 942   ;; the lazy sweeping has not yet reached it to remove it from the port
 943   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
 944   ;; tricky, but the following code made it happen in 1.8.2.
 945   (pass-if "passing freed cell"
 946     (let ((lst '()))
 947       ;; clear out the heap
 948       (gc) (gc) (gc)
 949       ;; allocate cells so the opened ports aren't at the start of the heap
 950       (make-list 1000)
 951       (open-input-file "/dev/null")
 952       (make-list 1000)
 953       (open-input-file "/dev/null")
 954       ;; this gc leaves the above ports unmarked, ie. inaccessible
 955       (gc)
 956       ;; but they're still in the port table, so this sees them
 957       (port-for-each (lambda (port)
 958                        (set! lst (cons port lst))))
 959       ;; this forces completion of the sweeping
 960       (gc) (gc) (gc)
 961       ;; and (if the bug is present) the cells accumulated in LST are now
 962       ;; freed cells, which give #f from `port?'
 963       (not (memq #f (map port? lst))))))
 964
 965 (with-test-prefix
 966  "fdes->port"
 967  (pass-if "fdes->ports finds port"
 968           (let ((port (open-file (test-file) "w")))
 969
 970             (not (not (memq port (fdes->ports (port->fdes port))))))))
 971
 972 ;;;
 973 ;;; seek
 974 ;;;
 975
 976 (with-test-prefix "seek"
 977
 978   (with-test-prefix "file port"
 979
 980     (pass-if "SEEK_CUR"
 981       (call-with-output-file (test-file)
 982         (lambda (port)
 983           (display "abcde" port)))
 984       (let ((port (open-file (test-file) "r")))
 985         (read-char port)
 986         (seek port 2 SEEK_CUR)
 987         (eqv? #\d (read-char port))))
 988
 989     (pass-if "SEEK_SET"
 990       (call-with-output-file (test-file)
 991         (lambda (port)
 992           (display "abcde" port)))
 993       (let ((port (open-file (test-file) "r")))
 994         (read-char port)
 995         (seek port 3 SEEK_SET)
 996         (eqv? #\d (read-char port))))
 997
 998     (pass-if "SEEK_END"
 999       (call-with-output-file (test-file)
1000         (lambda (port)
1001           (display "abcde" port)))
1002       (let ((port (open-file (test-file) "r")))
1003         (read-char port)
1004         (seek port -2 SEEK_END)
1005         (eqv? #\d (read-char port))))))
1006
1007 ;;;
1008 ;;; truncate-file
1009 ;;;
1010
1011 (with-test-prefix "truncate-file"
1012
1013   (pass-if-exception "flonum file" exception:wrong-type-arg
1014     (truncate-file 1.0 123))
1015
1016   (pass-if-exception "frac file" exception:wrong-type-arg
1017     (truncate-file 7/3 123))
1018
1019   (with-test-prefix "filename"
1020
1021     (pass-if-exception "flonum length" exception:wrong-type-arg
1022       (call-with-output-file (test-file)
1023         (lambda (port)
1024           (display "hello" port)))
1025       (truncate-file (test-file) 1.0))
1026
1027     (pass-if "shorten"
1028       (call-with-output-file (test-file)
1029         (lambda (port)
1030           (display "hello" port)))
1031       (truncate-file (test-file) 1)
1032       (eqv? 1 (stat:size (stat (test-file)))))
1033
1034     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
1035       (call-with-output-file (test-file)
1036         (lambda (port)
1037           (display "hello" port)))
1038       (truncate-file (test-file))))
1039
1040   (with-test-prefix "file descriptor"
1041
1042     (pass-if "shorten"
1043       (call-with-output-file (test-file)
1044         (lambda (port)
1045           (display "hello" port)))
1046       (let ((fd (open-fdes (test-file) O_RDWR)))
1047         (truncate-file fd 1)
1048         (close-fdes fd))
1049       (eqv? 1 (stat:size (stat (test-file)))))
1050
1051     (pass-if "shorten to current pos"
1052       (call-with-output-file (test-file)
1053         (lambda (port)
1054           (display "hello" port)))
1055       (let ((fd (open-fdes (test-file) O_RDWR)))
1056         (seek fd 1 SEEK_SET)
1057         (truncate-file fd)
1058         (close-fdes fd))
1059       (eqv? 1 (stat:size (stat (test-file))))))
1060
1061   (with-test-prefix "file port"
1062
1063     (pass-if "shorten"
1064       (call-with-output-file (test-file)
1065         (lambda (port)
1066           (display "hello" port)))
1067       (let ((port (open-file (test-file) "r+")))
1068         (truncate-file port 1))
1069       (eqv? 1 (stat:size (stat (test-file)))))
1070
1071     (pass-if "shorten to current pos"
1072       (call-with-output-file (test-file)
1073         (lambda (port)
1074           (display "hello" port)))
1075       (let ((port (open-file (test-file) "r+")))
1076         (read-char port)
1077         (truncate-file port))
1078       (eqv? 1 (stat:size (stat (test-file)))))))
1079
1080
1081 ;;;; testing read-delimited and friends
1082
1083 (with-test-prefix "read-delimited!"
1084   (let ((c (make-string 20 #\!)))
1085     (call-with-input-string
1086      "defdef\nghighi\n"
1087      (lambda (port)
1088
1089        (read-delimited! "\n" c port 'concat)
1090        (pass-if "read-delimited! reads a first line"
1091                 (string=? c "defdef\n!!!!!!!!!!!!!"))
1092
1093        (read-delimited! "\n" c port 'concat 3)
1094        (pass-if "read-delimited! reads a first line"
1095                 (string=? c "defghighi\n!!!!!!!!!!"))))))
1096
1097 \f
1098 ;;;; char-ready?
1099
1100 (call-with-input-string
1101  "howdy"
1102  (lambda (port)
1103    (pass-if "char-ready? returns true on string port"
1104             (char-ready? port))))
1105
1106 ;;; This segfaults on some versions of Guile.  We really should run
1107 ;;; the tests in a subprocess...
1108
1109 (call-with-input-string
1110  "howdy"
1111  (lambda (port)
1112    (with-input-from-port
1113        port
1114      (lambda ()
1115        (pass-if "char-ready? returns true on string port as default port"
1116                 (char-ready?))))))
1117
1118 \f
1119 ;;;; pending-eof behavior
1120
1121 (with-test-prefix "pending EOF behavior"
1122   ;; Make a test port that will produce the given sequence.  Each
1123   ;; element of 'lst' may be either a character or #f (which means EOF).
1124   (define (test-soft-port . lst)
1125     (make-soft-port
1126      (vector (lambda (c) #f)            ; write char
1127              (lambda (s) #f)            ; write string
1128              (lambda () #f)             ; flush
1129              (lambda ()                 ; read char
1130                (let ((c (car lst)))
1131                  (set! lst (cdr lst))
1132                  c))
1133              (lambda () #f))            ; close
1134      "rw"))
1135
1136   (define (call-with-port p proc)
1137     (dynamic-wind
1138       (lambda () #f)
1139       (lambda () (proc p))
1140       (lambda () (close-port p))))
1141
1142   (define (call-with-test-file str proc)
1143     (let ((filename (test-file)))
1144       (dynamic-wind
1145         (lambda () (call-with-output-file filename
1146                      (lambda (p) (display str p))))
1147         (lambda () (call-with-input-file filename proc))
1148         (lambda () (delete-file (test-file))))))
1149
1150   (pass-if "peek-char does not swallow EOF (soft port)"
1151     (call-with-port (test-soft-port #\a #f #\b)
1152       (lambda (p)
1153         (and (char=? #\a  (peek-char p))
1154              (char=? #\a  (read-char p))
1155              (eof-object? (peek-char p))
1156              (eof-object? (read-char p))
1157              (char=? #\b  (peek-char p))
1158              (char=? #\b  (read-char p))))))
1159
1160   (pass-if "unread clears pending EOF (soft port)"
1161     (call-with-port (test-soft-port #\a #f #\b)
1162       (lambda (p)
1163         (and (char=? #\a  (read-char p))
1164              (eof-object? (peek-char p))
1165              (begin (unread-char #\u p)
1166                     (char=? #\u  (read-char p)))))))
1167
1168   (pass-if "unread clears pending EOF (string port)"
1169     (call-with-input-string "a"
1170       (lambda (p)
1171         (and (char=? #\a  (read-char p))
1172              (eof-object? (peek-char p))
1173              (begin (unread-char #\u p)
1174                     (char=? #\u  (read-char p)))))))
1175
1176   (pass-if "unread clears pending EOF (file port)"
1177     (call-with-test-file
1178      "a"
1179      (lambda (p)
1180        (and (char=? #\a  (read-char p))
1181             (eof-object? (peek-char p))
1182             (begin (unread-char #\u p)
1183                    (char=? #\u  (read-char p)))))))
1184
1185   (pass-if "seek clears pending EOF (string port)"
1186     (call-with-input-string "a"
1187       (lambda (p)
1188         (and (char=? #\a  (read-char p))
1189              (eof-object? (peek-char p))
1190              (begin (seek p 0 SEEK_SET)
1191                     (char=? #\a (read-char p)))))))
1192
1193   (pass-if "seek clears pending EOF (file port)"
1194     (call-with-test-file
1195      "a"
1196      (lambda (p)
1197        (and (char=? #\a  (read-char p))
1198             (eof-object? (peek-char p))
1199             (begin (seek p 0 SEEK_SET)
1200                    (char=? #\a (read-char p))))))))
1201
1202 \f
1203 ;;;; Close current-input-port, and make sure everyone can handle it.
1204
1205 (with-test-prefix "closing current-input-port"
1206   (for-each (lambda (procedure name)
1207               (with-input-from-port
1208                   (call-with-input-string "foo" (lambda (p) p))
1209                 (lambda ()
1210                   (close-port (current-input-port))
1211                   (pass-if-exception name
1212                     exception:wrong-type-arg
1213                     (procedure)))))
1214             (list read read-char read-line)
1215             '("read" "read-char" "read-line")))
1216
1217 \f
1218
1219 (with-test-prefix "setvbuf"
1220
1221   (pass-if "line/column number preserved"
1222     ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1223     ;; line and/or column number.
1224     (call-with-output-file (test-file)
1225       (lambda (p)
1226         (display "This is GNU Guile.\nWelcome." p)))
1227     (call-with-input-file (test-file)
1228       (lambda (p)
1229         (and (eqv? #\T (read-char p))
1230              (let ((line (port-line p))
1231                    (col  (port-column p)))
1232                (and (= line 0) (= col 1)
1233                     (begin
1234                       (setvbuf p _IOFBF 777)
1235                       (let ((line* (port-line p))
1236                             (col*  (port-column p)))
1237                         (and (= line line*)
1238                              (= col col*)))))))))))
1239
1240 \f
1241
1242 (pass-if-equal "unget-bytevector"
1243     #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
1244             1 2 3 4 251 253 254 255)
1245   (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
1246     (unget-bytevector port #vu8(200 201 202 203))
1247     (unget-bytevector port #vu8(20 21 22 23 24))
1248     (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
1249     (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
1250     (unget-bytevector port #vu8(10 11))
1251     (get-bytevector-all port)))
1252
1253 \f
1254
1255 (with-test-prefix "unicode byte-order marks (BOMs)"
1256
1257   (define (bv-read-test* encoding bv proc)
1258     (let ((port (open-bytevector-input-port bv)))
1259       (set-port-encoding! port encoding)
1260       (proc port)))
1261
1262   (define (bv-read-test encoding bv)
1263     (bv-read-test* encoding bv read-string))
1264
1265   (define (bv-write-test* encoding proc)
1266     (call-with-values
1267         (lambda () (open-bytevector-output-port))
1268       (lambda (port get-bytevector)
1269         (set-port-encoding! port encoding)
1270         (proc port)
1271         (get-bytevector))))
1272
1273   (define (bv-write-test encoding str)
1274     (bv-write-test* encoding
1275                     (lambda (p)
1276                       (display str p))))
1277
1278   (pass-if-equal "BOM not discarded from Latin-1 stream"
1279       "\xEF\xBB\xBF\x61"
1280     (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
1281
1282   (pass-if-equal "BOM not discarded from Latin-2 stream"
1283       "\u010F\u0165\u017C\x61"
1284     (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
1285
1286   (pass-if-equal "BOM not discarded from UTF-16BE stream"
1287       "\uFEFF\x61"
1288     (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
1289
1290   (pass-if-equal "BOM not discarded from UTF-16LE stream"
1291       "\uFEFF\x61"
1292     (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
1293
1294   (pass-if-equal "BOM not discarded from UTF-32BE stream"
1295       "\uFEFF\x61"
1296     (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
1297                                        #x00 #x00 #x00 #x61)))
1298
1299   (pass-if-equal "BOM not discarded from UTF-32LE stream"
1300       "\uFEFF\x61"
1301     (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
1302                                        #x61 #x00 #x00 #x00)))
1303
1304   (pass-if-equal "BOM not written to UTF-8 stream"
1305       #vu8(#x61)
1306     (bv-write-test "UTF-8" "a"))
1307
1308   (pass-if-equal "BOM not written to UTF-16BE stream"
1309       #vu8(#x00 #x61)
1310     (bv-write-test "UTF-16BE" "a"))
1311
1312   (pass-if-equal "BOM not written to UTF-16LE stream"
1313       #vu8(#x61 #x00)
1314     (bv-write-test "UTF-16LE" "a"))
1315
1316   (pass-if-equal "BOM not written to UTF-32BE stream"
1317       #vu8(#x00 #x00 #x00 #x61)
1318     (bv-write-test "UTF-32BE" "a"))
1319
1320   (pass-if-equal "BOM not written to UTF-32LE stream"
1321       #vu8(#x61 #x00 #x00 #x00)
1322     (bv-write-test "UTF-32LE" "a"))
1323
1324   (pass-if "Don't read from the port unless user asks to"
1325     (let* ((p (make-soft-port
1326                (vector
1327                 (lambda (c) #f)           ; write char
1328                 (lambda (s) #f)           ; write string
1329                 (lambda () #f)            ; flush
1330                 (lambda () (throw 'fail)) ; read char
1331                 (lambda () #f))
1332                "rw")))
1333       (set-port-encoding! p "UTF-16")
1334       (display "abc" p)
1335       (set-port-encoding! p "UTF-32")
1336       (display "def" p)
1337       #t))
1338
1339   ;; TODO: test that input and output streams are independent when
1340   ;; appropriate, and linked when appropriate.
1341
1342   (pass-if-equal "BOM discarded from start of UTF-8 stream"
1343       "a"
1344     (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
1345
1346   (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
1347       '(#\a "a")
1348     (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
1349                    (lambda (p)
1350                      (let ((c (read-char p)))
1351                        (seek p 0 SEEK_SET)
1352                        (let ((s (read-string p)))
1353                          (list c s))))))
1354
1355   (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
1356       "\uFEFFa"
1357     (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
1358
1359   (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
1360       "\uFEFFb"
1361     (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
1362                    (lambda (p)
1363                      (seek p 1 SEEK_SET)
1364                      (read-string p))))
1365
1366   (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
1367       "a\uFEFFb"
1368     (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
1369
1370   (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
1371       #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
1372     (bv-write-test "UTF-16" "ab"))
1373
1374   (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
1375       #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
1376     (bv-write-test* "UTF-16"
1377                     (lambda (p)
1378                       (display "ab" p)
1379                       (set-port-encoding! p "UTF-16")
1380                       (display "cd" p))))
1381
1382   (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
1383       "a"
1384     (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
1385
1386   (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
1387       '(#\a "a")
1388     (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
1389                    (lambda (p)
1390                      (let ((c (read-char p)))
1391                        (seek p 0 SEEK_SET)
1392                        (let ((s (read-string p)))
1393                          (list c s))))))
1394
1395   (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
1396       "\uFEFFa"
1397     (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
1398
1399   (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
1400       "\uFEFFa"
1401     (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
1402                    (lambda (p)
1403                      (seek p 2 SEEK_SET)
1404                      (read-string p))))
1405
1406   (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
1407       "a\uFEFFb"
1408     (let ((be (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
1409           (le (bv-read-test "utf-16" #vu8(#x61 #x00 #xFF #xFE #x62 #x00))))
1410       (if (char=? #\a (string-ref be 0))
1411           be
1412           le)))
1413
1414   (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
1415       "a"
1416     (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
1417
1418   (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
1419       '(#\a "a")
1420     (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
1421                    (lambda (p)
1422                      (let ((c (read-char p)))
1423                        (seek p 0 SEEK_SET)
1424                        (let ((s (read-string p)))
1425                          (list c s))))))
1426
1427   (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
1428       "\uFEFFa"
1429     (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
1430
1431   (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
1432       "a"
1433     (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1434                                      #x00 #x00 #x00 #x61)))
1435
1436   (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
1437       '(#\a "a")
1438     (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
1439                                       #x00 #x00 #x00 #x61)
1440                    (lambda (p)
1441                      (let ((c (read-char p)))
1442                        (seek p 0 SEEK_SET)
1443                        (let ((s (read-string p)))
1444                          (list c s))))))
1445
1446   (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
1447       "\uFEFFa"
1448     (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
1449                                      #x00 #x00 #xFE #xFF
1450                                      #x00 #x00 #x00 #x61)))
1451
1452   (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
1453       "\uFEFFa"
1454     (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
1455                                       #x00 #x00 #xFE #xFF
1456                                       #x00 #x00 #x00 #x61)
1457                    (lambda (p)
1458                      (seek p 4 SEEK_SET)
1459                      (read-string p))))
1460
1461   (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
1462       "ab"
1463     (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
1464                    (lambda (p)
1465                      (let ((a (read-char p)))
1466                        (set-port-encoding! p "UTF-16")
1467                        (string a (read-char p))))))
1468
1469   (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
1470       "ab"
1471     (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
1472                    (lambda (p)
1473                      (let ((a (read-char p)))
1474                        (set-port-encoding! p "UTF-16")
1475                        (string a (read-char p))))))
1476
1477   (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
1478       "ab"
1479     (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1480                                       #x00 #x00 #xFE #xFF
1481                                       #x00 #x00 #x00 #x62)
1482                    (lambda (p)
1483                      (let ((a (read-char p)))
1484                        (set-port-encoding! p "UTF-32")
1485                        (string a (read-char p))))))
1486
1487   (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
1488       "ab"
1489     (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
1490                                       #xFF #xFE #x00 #x00
1491                                       #x62 #x00 #x00 #x00)
1492                    (lambda (p)
1493                      (let ((a (read-char p)))
1494                        (set-port-encoding! p "UTF-32")
1495                        (string a (read-char p))))))
1496
1497   (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
1498       "a\uFEFFb"
1499     (let ((be (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
1500                                                #x00 #x00 #xFE #xFF
1501                                                #x00 #x00 #x00 #x62)))
1502           (le (bv-read-test "UTF-32" #vu8(#x61 #x00 #x00 #x00
1503                                                #xFF #xFE #x00 #x00
1504                                                #x62 #x00 #x00 #x00))))
1505       (if (char=? #\a (string-ref be 0))
1506           be
1507           le)))
1508
1509   (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
1510       "a"
1511     (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1512                                      #x61 #x00 #x00 #x00)))
1513
1514   (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
1515       '(#\a "a")
1516     (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
1517                                       #x61 #x00 #x00 #x00)
1518                    (lambda (p)
1519                      (let ((c (read-char p)))
1520                        (seek p 0 SEEK_SET)
1521                        (let ((s (read-string p)))
1522                          (list c s))))))
1523
1524   (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
1525       "\uFEFFa"
1526     (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
1527                                      #xFF #xFE #x00 #x00
1528                                      #x61 #x00 #x00 #x00))))
1529
1530 \f
1531
1532 (define-syntax-rule (with-load-path path body ...)
1533   (let ((new path)
1534         (old %load-path))
1535     (dynamic-wind
1536       (lambda ()
1537         (set! %load-path new))
1538       (lambda ()
1539         body ...)
1540       (lambda ()
1541         (set! %load-path old)))))
1542
1543 (with-test-prefix "%file-port-name-canonicalization"
1544
1545   (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
1546     ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
1547     ;; of "/dev/null".  See
1548     ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
1549     ;; for a discussion.
1550     (with-load-path (cons "" (delete "/" %load-path))
1551       (with-fluids ((%file-port-name-canonicalization 'relative))
1552         (port-filename (open-input-file "/dev/null")))))
1553
1554   (pass-if-equal "relative canonicalization with /" "dev/null"
1555     (with-load-path (cons "/" %load-path)
1556       (with-fluids ((%file-port-name-canonicalization 'relative))
1557         (port-filename (open-input-file "/dev/null")))))
1558
1559   (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm"
1560     ;; If an entry in %LOAD-PATH is not canonical, then
1561     ;; `scm_i_relativize_path' is unable to do its job.
1562     (if (equal? (map canonicalize-path %load-path) %load-path)
1563         (with-fluids ((%file-port-name-canonicalization 'relative))
1564           (port-filename
1565            (open-input-file (%search-load-path "ice-9/q.scm"))))
1566         (throw 'unresolved)))
1567
1568   (pass-if-equal "absolute canonicalization from ice-9"
1569       (canonicalize-path
1570        (string-append (assoc-ref %guile-build-info 'top_srcdir)
1571                       "/module/ice-9/q.scm"))
1572     (with-fluids ((%file-port-name-canonicalization 'absolute))
1573       (port-filename (open-input-file (%search-load-path "ice-9/q.scm"))))))
1574
1575 (delete-file (test-file))
1576
1577 ;;; Local Variables:
1578 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
1579 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)
1580 ;;; End: