test-suite/tests/r6rs-ports.test

   1 ;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- coding: utf-8; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
   4 ;;;; Ludovic Courtès
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-io-ports)
  21   #:use-module (test-suite lib)
  22   #:use-module (test-suite guile-test)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-11)
  25   #:use-module (rnrs io ports)
  26   #:use-module (rnrs io simple)
  27   #:use-module (rnrs exceptions)
  28   #:use-module (rnrs bytevectors))
  29
  30 (define-syntax pass-if-condition
  31   (syntax-rules ()
  32     ((_ name predicate body0 body ...)
  33      (let ((cookie (list 'cookie)))
  34        (pass-if name
  35          (eq? cookie (guard (c ((predicate c) cookie))
  36                        body0 body ...)))))))
  37
  38 (define (test-file)
  39   (data-file-name "ports-test.tmp"))
  40
  41 ;; A input/output port that swallows all output, and produces just
  42 ;; spaces on input.  Reading and writing beyond `failure-position'
  43 ;; produces `system-error' exceptions.  Used for testing exception
  44 ;; behavior.
  45 (define* (make-failing-port #:optional (failure-position 0))
  46   (define (maybe-fail index errno)
  47     (if (> index failure-position)
  48         (scm-error 'system-error
  49                    'failing-port
  50                    "I/O beyond failure position" '()
  51                    (list errno))))
  52   (let ((read-index  0)
  53         (write-index 0))
  54     (define (write-char chr)
  55       (set! write-index (+ 1 write-index))
  56       (maybe-fail write-index ENOSPC))
  57     (make-soft-port
  58      (vector write-char
  59              (lambda (str)   ;; write-string
  60                (for-each write-char (string->list str)))
  61              (lambda () #t)  ;; flush-output
  62              (lambda ()      ;; read-char
  63                (set! read-index (+ read-index 1))
  64                (maybe-fail read-index EIO)
  65                #\space)
  66              (lambda () #t)) ;; close-port
  67      "rw")))
  68
  69 (define (call-with-bytevector-output-port/transcoded transcoder receiver)
  70   (call-with-bytevector-output-port
  71     (lambda (bv-port)
  72       (call-with-port (transcoded-port bv-port transcoder)
  73         receiver))))
  74
  75 \f
  76 (with-test-prefix "7.2.5 End-of-File Object"
  77
  78   (pass-if "eof-object"
  79     (and (eqv? (eof-object) (eof-object))
  80          (eq?  (eof-object) (eof-object))))
  81
  82   (pass-if "port-eof?"
  83     (port-eof? (open-input-string ""))))
  84
  85 \f
  86 (with-test-prefix "7.2.8 Binary Input"
  87
  88   (pass-if "get-u8"
  89     (let ((port (open-input-string "A")))
  90       (and (= (char->integer #\A) (get-u8 port))
  91            (eof-object? (get-u8 port)))))
  92
  93   (pass-if "lookahead-u8"
  94     (let ((port (open-input-string "A")))
  95       (and (= (char->integer #\A) (lookahead-u8 port))
  96            (= (char->integer #\A) (lookahead-u8 port))
  97            (= (char->integer #\A) (get-u8 port))
  98            (eof-object? (get-u8 port)))))
  99
 100   (pass-if "lookahead-u8 non-ASCII"
 101     (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
 102                   (open-input-string "λ"))))
 103       (and (= 206 (lookahead-u8 port))
 104            (= 206 (lookahead-u8 port))
 105            (= 206 (get-u8 port))
 106            (= 187 (lookahead-u8 port))
 107            (= 187 (lookahead-u8 port))
 108            (= 187 (get-u8 port))
 109            (eof-object? (lookahead-u8 port))
 110            (eof-object? (get-u8 port)))))
 111
 112   (pass-if "lookahead-u8: result is unsigned"
 113     ;; Bug #31081.
 114     (let ((port (open-bytevector-input-port #vu8(255))))
 115       (= (lookahead-u8 port) 255)))
 116
 117   (pass-if "get-bytevector-n [short]"
 118     (let* ((port (open-input-string "GNU Guile"))
 119            (bv (get-bytevector-n port 4)))
 120       (and (bytevector? bv)
 121            (equal? (bytevector->u8-list bv)
 122                    (map char->integer (string->list "GNU "))))))
 123
 124   (pass-if "get-bytevector-n [long]"
 125     (let* ((port (open-input-string "GNU Guile"))
 126            (bv (get-bytevector-n port 256)))
 127       (and (bytevector? bv)
 128            (equal? (bytevector->u8-list bv)
 129                    (map char->integer (string->list "GNU Guile"))))))
 130
 131   (pass-if-exception "get-bytevector-n with closed port"
 132     exception:wrong-type-arg
 133
 134     (let ((port (%make-void-port "r")))
 135
 136       (close-port port)
 137       (get-bytevector-n port 3)))
 138
 139   (pass-if "get-bytevector-n! [short]"
 140     (let* ((port (open-input-string "GNU Guile"))
 141            (bv   (make-bytevector 4))
 142            (read (get-bytevector-n! port bv 0 4)))
 143       (and (equal? read 4)
 144            (equal? (bytevector->u8-list bv)
 145                    (map char->integer (string->list "GNU "))))))
 146
 147   (pass-if "get-bytevector-n! [long]"
 148     (let* ((str  "GNU Guile")
 149            (port (open-input-string str))
 150            (bv   (make-bytevector 256))
 151            (read (get-bytevector-n! port bv 0 256)))
 152       (and (equal? read (string-length str))
 153            (equal? (map (lambda (i)
 154                           (bytevector-u8-ref bv i))
 155                         (iota read))
 156                    (map char->integer (string->list str))))))
 157
 158   (pass-if "get-bytevector-some [simple]"
 159     (let* ((str  "GNU Guile")
 160            (port (open-input-string str))
 161            (bv   (get-bytevector-some port)))
 162       (and (bytevector? bv)
 163            (equal? (bytevector->u8-list bv)
 164                    (map char->integer (string->list str))))))
 165
 166   (pass-if "get-bytevector-all"
 167     (let* ((str   "GNU Guile")
 168            (index 0)
 169            (port  (make-soft-port
 170                    (vector #f #f #f
 171                            (lambda ()
 172                              (if (>= index (string-length str))
 173                                  (eof-object)
 174                                  (let ((c (string-ref str index)))
 175                                    (set! index (+ index 1))
 176                                    c)))
 177                            (lambda () #t)
 178                            (let ((cont? #f))
 179                              (lambda ()
 180                                ;; Number of readily available octets: falls to
 181                                ;; zero after 4 octets have been read and then
 182                                ;; starts again.
 183                                (let ((a (if cont?
 184                                             (- (string-length str) index)
 185                                             (- 4 (modulo index 5)))))
 186                                  (if (= 0 a) (set! cont? #t))
 187                                  a))))
 188                    "r"))
 189            (bv    (get-bytevector-all port)))
 190       (and (bytevector? bv)
 191            (= index (string-length str))
 192            (= (bytevector-length bv) (string-length str))
 193            (equal? (bytevector->u8-list bv)
 194                    (map char->integer (string->list str)))))))
 195
 196 \f
 197 (define (make-soft-output-port)
 198   (let* ((bv (make-bytevector 1024))
 199          (read-index  0)
 200          (write-index 0)
 201          (write-char (lambda (chr)
 202                        (bytevector-u8-set! bv write-index
 203                                            (char->integer chr))
 204                        (set! write-index (+ 1 write-index)))))
 205     (make-soft-port
 206      (vector write-char
 207              (lambda (str)   ;; write-string
 208                (for-each write-char (string->list str)))
 209              (lambda () #t)  ;; flush-output
 210              (lambda ()      ;; read-char
 211                (if (>= read-index (bytevector-length bv))
 212                    (eof-object)
 213                    (let ((c (bytevector-u8-ref bv read-index)))
 214                      (set! read-index (+ read-index 1))
 215                      (integer->char c))))
 216              (lambda () #t)) ;; close-port
 217      "rw")))
 218
 219 (with-test-prefix "7.2.11 Binary Output"
 220
 221   (pass-if "put-u8"
 222     (let ((port (make-soft-output-port)))
 223       (put-u8 port 77)
 224       (equal? (get-u8 port) 77)))
 225
 226   ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
 227   ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
 228   ;; the bytes through, unmodified.  This is hacky, but we can't use
 229   ;; "custom binary output ports" here because they're only tested
 230   ;; later.
 231
 232   (pass-if "put-bytevector [2 args]"
 233     (with-latin1-locale
 234      (let ((port (make-soft-output-port))
 235            (bv   (make-bytevector 256)))
 236        (put-bytevector port bv)
 237        (equal? (bytevector->u8-list bv)
 238                (bytevector->u8-list
 239                 (get-bytevector-n port (bytevector-length bv)))))))
 240
 241   (pass-if "put-bytevector [3 args]"
 242     (with-latin1-locale
 243      (let ((port  (make-soft-output-port))
 244            (bv    (make-bytevector 256))
 245            (start 10))
 246        (put-bytevector port bv start)
 247        (equal? (drop (bytevector->u8-list bv) start)
 248                (bytevector->u8-list
 249                 (get-bytevector-n port (- (bytevector-length bv) start)))))))
 250
 251   (pass-if "put-bytevector [4 args]"
 252     (with-latin1-locale
 253      (let ((port  (make-soft-output-port))
 254            (bv    (make-bytevector 256))
 255            (start 10)
 256            (count 77))
 257        (put-bytevector port bv start count)
 258        (equal? (take (drop (bytevector->u8-list bv) start) count)
 259                (bytevector->u8-list
 260                 (get-bytevector-n port count))))))
 261
 262   (pass-if-exception "put-bytevector with closed port"
 263     exception:wrong-type-arg
 264
 265     (let* ((bv   (make-bytevector 4))
 266            (port (%make-void-port "w")))
 267
 268       (close-port port)
 269       (put-bytevector port bv)))
 270
 271   (pass-if "put-bytevector with UTF-16 string port"
 272     (let* ((str "hello, world")
 273            (bv  (string->utf16 str)))
 274       (equal? str
 275               (with-fluids ((%default-port-encoding "UTF-16BE"))
 276                 (call-with-output-string
 277                   (lambda (port)
 278                     (put-bytevector port bv)))))))
 279
 280   (pass-if "put-bytevector with wrong-encoding string port"
 281     (let* ((str "hello, world")
 282            (bv  (string->utf16 str)))
 283       (catch 'decoding-error
 284         (lambda ()
 285           (with-fluids ((%default-port-encoding "UTF-32")
 286                         (%default-port-conversion-strategy 'error))
 287             (call-with-output-string
 288               (lambda (port)
 289                 (put-bytevector port bv)))
 290             #f))                           ; fail if we reach this point
 291         (lambda (key subr message errno port)
 292           (string? (strerror errno)))))))
 293
 294 \f
 295 (define (test-input-file-opener open filename)
 296   (let ((contents (string->utf8 "GNU λ")))
 297     ;; Create file
 298     (call-with-output-file filename
 299       (lambda (port) (put-bytevector port contents)))
 300
 301     (pass-if "opens binary input port with correct contents"
 302       (with-fluids ((%default-port-encoding "UTF-8"))
 303         (call-with-port (open-file-input-port filename)
 304           (lambda (port)
 305             (and (binary-port? port)
 306                  (input-port? port)
 307                  (bytevector=? contents (get-bytevector-all port))))))))
 308
 309   (delete-file filename))
 310
 311 (with-test-prefix "7.2.7 Input Ports"
 312
 313   (with-test-prefix "open-file-input-port"
 314     (test-input-file-opener open-file-input-port (test-file)))
 315
 316   ;; This section appears here so that it can use the binary input
 317   ;; primitives.
 318
 319   (pass-if "open-bytevector-input-port [1 arg]"
 320     (let* ((str "Hello Port!")
 321            (bv (u8-list->bytevector (map char->integer
 322                                          (string->list str))))
 323            (port (open-bytevector-input-port bv))
 324            (read-to-string
 325             (lambda (port)
 326               (let loop ((chr (read-char port))
 327                          (result '()))
 328                 (if (eof-object? chr)
 329                     (apply string (reverse! result))
 330                     (loop (read-char port)
 331                           (cons chr result)))))))
 332
 333       (equal? (read-to-string port) str)))
 334
 335   (pass-if "bytevector-input-port is binary"
 336     (with-fluids ((%default-port-encoding "UTF-8"))
 337       (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
 338
 339   (pass-if-exception "bytevector-input-port is read-only"
 340     exception:wrong-type-arg
 341
 342     (let* ((str "Hello Port!")
 343            (bv (u8-list->bytevector (map char->integer
 344                                          (string->list str))))
 345            (port (open-bytevector-input-port bv #f)))
 346
 347       (write "hello" port)))
 348
 349   (pass-if "bytevector input port supports seeking"
 350     (let* ((str "Hello Port!")
 351            (bv (u8-list->bytevector (map char->integer
 352                                          (string->list str))))
 353            (port (open-bytevector-input-port bv #f)))
 354
 355       (and (port-has-port-position? port)
 356            (= 0 (port-position port))
 357            (port-has-set-port-position!? port)
 358            (begin
 359              (set-port-position! port 6)
 360              (= 6 (port-position port)))
 361            (bytevector=? (get-bytevector-all port)
 362                          (u8-list->bytevector
 363                           (map char->integer (string->list "Port!")))))))
 364
 365   (pass-if "bytevector input port can seek to very end"
 366     (let ((empty (open-bytevector-input-port '#vu8()))
 367           (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
 368       (and (begin (set-port-position! empty (port-position empty))
 369                   (= 0 (port-position empty)))
 370            (begin (get-bytevector-n not-empty 3)
 371                   (set-port-position! not-empty (port-position not-empty))
 372                   (= 3 (port-position not-empty))))))
 373
 374   (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
 375     exception:wrong-num-args
 376
 377     ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
 378     ;; optional.
 379     (make-custom-binary-input-port "port" (lambda args #t)))
 380
 381   (pass-if "make-custom-binary-input-port"
 382     (let* ((source (make-bytevector 7777))
 383            (read! (let ((pos 0)
 384                         (len (bytevector-length source)))
 385                     (lambda (bv start count)
 386                       (let ((amount (min count (- len pos))))
 387                         (if (> amount 0)
 388                             (bytevector-copy! source pos
 389                                               bv start amount))
 390                         (set! pos (+ pos amount))
 391                         amount))))
 392            (port (make-custom-binary-input-port "the port" read!
 393                                                 #f #f #f)))
 394
 395       (and (binary-port? port)
 396            (input-port? port)
 397            (bytevector=? (get-bytevector-all port) source))))
 398
 399   (pass-if "custom binary input port does not support `port-position'"
 400     (let* ((str "Hello Port!")
 401            (source (open-bytevector-input-port
 402                     (u8-list->bytevector
 403                      (map char->integer (string->list str)))))
 404            (read! (lambda (bv start count)
 405                     (let ((r (get-bytevector-n! source bv start count)))
 406                       (if (eof-object? r)
 407                           0
 408                           r))))
 409            (port (make-custom-binary-input-port "the port" read!
 410                                                 #f #f #f)))
 411       (not (or (port-has-port-position? port)
 412                (port-has-set-port-position!? port)))))
 413
 414   (pass-if-equal "custom binary input port supports `port-position', \
 415 not `set-port-position!'"
 416       42
 417     (let ((port (make-custom-binary-input-port "the port" (const 0)
 418                                                (const 42) #f #f)))
 419       (and (port-has-port-position? port)
 420            (not (port-has-set-port-position!? port))
 421            (port-position port))))
 422
 423   (pass-if "custom binary input port supports `port-position'"
 424     (let* ((str "Hello Port!")
 425            (source (open-bytevector-input-port
 426                     (u8-list->bytevector
 427                      (map char->integer (string->list str)))))
 428            (read! (lambda (bv start count)
 429                     (let ((r (get-bytevector-n! source bv start count)))
 430                       (if (eof-object? r)
 431                           0
 432                           r))))
 433            (get-pos (lambda ()
 434                       (port-position source)))
 435            (set-pos! (lambda (pos)
 436                        (set-port-position! source pos)))
 437            (port (make-custom-binary-input-port "the port" read!
 438                                                 get-pos set-pos! #f)))
 439
 440       (and (port-has-port-position? port)
 441            (= 0 (port-position port))
 442            (port-has-set-port-position!? port)
 443            (begin
 444              (set-port-position! port 6)
 445              (= 6 (port-position port)))
 446            (bytevector=? (get-bytevector-all port)
 447                          (u8-list->bytevector
 448                           (map char->integer (string->list "Port!")))))))
 449
 450   (pass-if "custom binary input port `close-proc' is called"
 451     (let* ((closed?  #f)
 452            (read!    (lambda (bv start count) 0))
 453            (get-pos  (lambda () 0))
 454            (set-pos! (lambda (pos) #f))
 455            (close!   (lambda () (set! closed? #t)))
 456            (port     (make-custom-binary-input-port "the port" read!
 457                                                     get-pos set-pos!
 458                                                     close!)))
 459
 460       (close-port port)
 461       (gc) ; Test for marking a closed port.
 462       closed?))
 463
 464   (pass-if "standard-input-port is binary"
 465     (with-fluids ((%default-port-encoding "UTF-8"))
 466       (binary-port? (standard-input-port)))))
 467
 468 \f
 469 (define (test-output-file-opener open filename)
 470   (with-fluids ((%default-port-encoding "UTF-8"))
 471     (pass-if "opens binary output port"
 472              (call-with-port (open filename)
 473                (lambda (port)
 474                  (put-bytevector port '#vu8(1 2 3))
 475                  (and (binary-port? port)
 476                       (output-port? port))))))
 477
 478   (pass-if-condition "exception: already-exists"
 479                      i/o-file-already-exists-error?
 480                      (open filename))
 481
 482   (pass-if "no-fail no-truncate"
 483            (and
 484              (call-with-port (open filename (file-options no-fail no-truncate))
 485                (lambda (port)
 486                  (= 0 (port-position port))))
 487              (= 3 (stat:size (stat filename)))))
 488
 489   (pass-if "no-fail"
 490            (and
 491              (call-with-port (open filename (file-options no-fail))
 492                binary-port?)
 493              (= 0 (stat:size (stat filename)))))
 494
 495   (delete-file filename)
 496
 497   (pass-if-condition "exception: does-not-exist"
 498                      i/o-file-does-not-exist-error?
 499                      (open filename (file-options no-create))))
 500
 501 (with-test-prefix "8.2.10 Output ports"
 502
 503   (with-test-prefix "open-file-output-port"
 504     (test-output-file-opener open-file-output-port (test-file)))
 505
 506   (pass-if "open-bytevector-output-port"
 507     (let-values (((port get-content)
 508                   (open-bytevector-output-port #f)))
 509       (let ((source (make-bytevector 7777)))
 510         (put-bytevector port source)
 511         (and (bytevector=? (get-content) source)
 512              (bytevector=? (get-content) (make-bytevector 0))))))
 513
 514   (pass-if "bytevector-output-port is binary"
 515     (binary-port? (open-bytevector-output-port)))
 516
 517   (pass-if "open-bytevector-output-port [extract after close]"
 518     (let-values (((port get-content)
 519                   (open-bytevector-output-port)))
 520       (let ((source (make-bytevector 12345 #xFE)))
 521         (put-bytevector port source)
 522         (close-port port)
 523         (bytevector=? (get-content) source))))
 524
 525   (pass-if "open-bytevector-output-port [put-u8]"
 526     (let-values (((port get-content)
 527                   (open-bytevector-output-port)))
 528       (put-u8 port 77)
 529       (and (bytevector=? (get-content) (make-bytevector 1 77))
 530            (bytevector=? (get-content) (make-bytevector 0)))))
 531
 532   (pass-if "open-bytevector-output-port [display]"
 533     (let-values (((port get-content)
 534                   (open-bytevector-output-port)))
 535       (display "hello" port)
 536       (and (bytevector=? (get-content) (string->utf8 "hello"))
 537            (bytevector=? (get-content) (make-bytevector 0)))))
 538
 539   (pass-if "bytevector output port supports `port-position'"
 540     (let-values (((port get-content)
 541                   (open-bytevector-output-port)))
 542       (let ((source (make-bytevector 7777))
 543             (overwrite (make-bytevector 33)))
 544         (and (port-has-port-position? port)
 545              (port-has-set-port-position!? port)
 546              (begin
 547                (put-bytevector port source)
 548                (= (bytevector-length source)
 549                   (port-position port)))
 550              (begin
 551                (set-port-position! port 10)
 552                (= 10 (port-position port)))
 553              (begin
 554                (put-bytevector port overwrite)
 555                (bytevector-copy! overwrite 0 source 10
 556                                  (bytevector-length overwrite))
 557                (= (port-position port)
 558                   (+ 10 (bytevector-length overwrite))))
 559              (bytevector=? (get-content) source)
 560              (bytevector=? (get-content) (make-bytevector 0))))))
 561
 562   (pass-if "make-custom-binary-output-port"
 563     (let ((port (make-custom-binary-output-port "cbop"
 564                                                 (lambda (x y z) 0)
 565                                                 #f #f #f)))
 566       (and (output-port? port)
 567            (binary-port? port)
 568            (not (port-has-port-position? port))
 569            (not (port-has-set-port-position!? port)))))
 570
 571   (pass-if "make-custom-binary-output-port [partial writes]"
 572     (let* ((source   (uint-list->bytevector (iota 333)
 573                                             (native-endianness) 2))
 574            (sink     (make-bytevector (bytevector-length source)))
 575            (sink-pos 0)
 576            (eof?     #f)
 577            (write!   (lambda (bv start count)
 578                        (if (= 0 count)
 579                            (begin
 580                              (set! eof? #t)
 581                              0)
 582                            (let ((u8 (bytevector-u8-ref bv start)))
 583                              ;; Get one byte at a time.
 584                              (bytevector-u8-set! sink sink-pos u8)
 585                              (set! sink-pos (+ 1 sink-pos))
 586                              1))))
 587            (port     (make-custom-binary-output-port "cbop" write!
 588                                                      #f #f #f)))
 589       (put-bytevector port source)
 590       (and (= sink-pos (bytevector-length source))
 591            (not eof?)
 592            (bytevector=? sink source))))
 593
 594   (pass-if "make-custom-binary-output-port [full writes]"
 595     (let* ((source   (uint-list->bytevector (iota 333)
 596                                             (native-endianness) 2))
 597            (sink     (make-bytevector (bytevector-length source)))
 598            (sink-pos 0)
 599            (eof?     #f)
 600            (write!   (lambda (bv start count)
 601                        (if (= 0 count)
 602                            (begin
 603                              (set! eof? #t)
 604                              0)
 605                            (begin
 606                              (bytevector-copy! bv start
 607                                                sink sink-pos
 608                                                count)
 609                              (set! sink-pos (+ sink-pos count))
 610                              count))))
 611            (port     (make-custom-binary-output-port "cbop" write!
 612                                                      #f #f #f)))
 613       (put-bytevector port source)
 614       (and (= sink-pos (bytevector-length source))
 615            (not eof?)
 616            (bytevector=? sink source))))
 617
 618   (pass-if "standard-output-port is binary"
 619     (with-fluids ((%default-port-encoding "UTF-8"))
 620       (binary-port? (standard-output-port))))
 621
 622   (pass-if "standard-error-port is binary"
 623     (with-fluids ((%default-port-encoding "UTF-8"))
 624       (binary-port? (standard-error-port)))))
 625
 626 \f
 627 (with-test-prefix "8.2.6  Input and output ports"
 628
 629   (pass-if "transcoded-port [output]"
 630     (let ((s "Hello\nÄÖÜ"))
 631       (bytevector=?
 632        (string->utf8 s)
 633        (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
 634          (lambda (utf8-port)
 635            (put-string utf8-port s))))))
 636
 637   (pass-if "transcoded-port [input]"
 638     (let ((s "Hello\nÄÖÜ"))
 639       (string=?
 640        s
 641        (get-string-all
 642         (transcoded-port (open-bytevector-input-port (string->utf8 s))
 643                          (make-transcoder (utf-8-codec)))))))
 644
 645   (pass-if "transcoded-port [input line]"
 646     (string=? "ÄÖÜ"
 647               (get-line (transcoded-port
 648                          (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
 649                          (make-transcoder (utf-8-codec))))))
 650
 651   (pass-if "transcoded-port [error handling mode = raise]"
 652     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 653                                 (error-handling-mode raise)))
 654            (b  (open-bytevector-input-port #vu8(255 2 1)))
 655            (tp (transcoded-port b t)))
 656       (guard (c ((i/o-decoding-error? c)
 657                  (eq? (i/o-error-port c) tp)))
 658         (get-line tp)
 659         #f)))                              ; fail if we reach this point
 660
 661   (pass-if "transcoded-port [error handling mode = replace]"
 662     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 663                                 (error-handling-mode replace)))
 664            (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
 665            (tp (transcoded-port b t)))
 666       (string-suffix? "gnu" (get-line tp))))
 667
 668   (pass-if "transcoded-port, output [error handling mode = raise]"
 669     (let-values (((p get)
 670                   (open-bytevector-output-port)))
 671       (let* ((t  (make-transcoder (latin-1-codec) (native-eol-style)
 672                                   (error-handling-mode raise)))
 673              (tp (transcoded-port p t)))
 674         (guard (c ((i/o-encoding-error? c)
 675                    (and (eq? (i/o-error-port c) tp)
 676                         (char=? (i/o-encoding-error-char c) #\λ)
 677                         (bytevector=? (get) (string->utf8 "The letter ")))))
 678           (put-string tp "The letter λ cannot be represented in Latin-1.")
 679           #f))))
 680
 681   (pass-if "port-transcoder [binary port]"
 682     (not (port-transcoder (open-bytevector-input-port #vu8()))))
 683
 684   (pass-if "port-transcoder [transcoded port]"
 685     (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
 686                                (make-transcoder (utf-8-codec))))
 687            (t (port-transcoder p)))
 688       (and t
 689            (transcoder-codec t)
 690            (eq? (native-eol-style)
 691                 (transcoder-eol-style t))
 692            (eq? (error-handling-mode replace)
 693                 (transcoder-error-handling-mode t))))))
 694
 695 (with-test-prefix "8.2.9  Textual input"
 696
 697   (pass-if "get-string-n [short]"
 698     (let ((port (open-input-string "GNU Guile")))
 699       (string=? "GNU " (get-string-n port 4))))
 700   (pass-if "get-string-n [long]"
 701     (let ((port (open-input-string "GNU Guile")))
 702       (string=? "GNU Guile" (get-string-n port 256))))
 703   (pass-if "get-string-n [eof]"
 704     (let ((port (open-input-string "")))
 705       (eof-object? (get-string-n port 4))))
 706
 707   (pass-if "get-string-n! [short]"
 708     (let ((port (open-input-string "GNU Guile"))
 709           (s (string-copy "Isn't XXX great?")))
 710       (and (= 3 (get-string-n! port s 6 3))
 711            (string=? s "Isn't GNU great?"))))
 712
 713   (with-test-prefix "read error"
 714     (pass-if-condition "get-char" i/o-read-error?
 715       (get-char (make-failing-port)))
 716     (pass-if-condition "lookahead-char" i/o-read-error?
 717       (lookahead-char (make-failing-port)))
 718     ;; FIXME: these are not yet exception-correct
 719     #|
 720     (pass-if-condition "get-string-n" i/o-read-error?
 721       (get-string-n (make-failing-port) 5))
 722     (pass-if-condition "get-string-n!" i/o-read-error?
 723       (get-string-n! (make-failing-port) (make-string 5) 0 5))
 724     |#
 725     (pass-if-condition "get-string-all" i/o-read-error?
 726       (get-string-all (make-failing-port 100)))
 727     (pass-if-condition "get-line" i/o-read-error?
 728       (get-line (make-failing-port)))
 729     (pass-if-condition "get-datum" i/o-read-error?
 730       (get-datum (make-failing-port)))))
 731
 732 (define (encoding-error-predicate char)
 733   (lambda (c)
 734     (and (i/o-encoding-error? c)
 735          (char=? char (i/o-encoding-error-char c)))))
 736
 737 (with-test-prefix "8.2.12 Textual Output"
 738
 739   (with-test-prefix "write error"
 740     (pass-if-condition "put-char" i/o-write-error?
 741       (put-char (make-failing-port) #\G))
 742     (pass-if-condition "put-string" i/o-write-error?
 743       (put-string (make-failing-port) "Hello World!"))
 744     (pass-if-condition "put-datum" i/o-write-error?
 745       (put-datum (make-failing-port) '(hello world!))))
 746   (with-test-prefix "encoding error"
 747     (pass-if-condition "put-char" (encoding-error-predicate #\λ)
 748       (call-with-bytevector-output-port/transcoded
 749           (make-transcoder (latin-1-codec)
 750                            (native-eol-style)
 751                            (error-handling-mode raise))
 752         (lambda (port)
 753           (put-char port #\λ))))
 754     (pass-if-condition "put-string" (encoding-error-predicate #\λ)
 755       (call-with-bytevector-output-port/transcoded
 756           (make-transcoder (latin-1-codec)
 757                            (native-eol-style)
 758                            (error-handling-mode raise))
 759         (lambda (port)
 760           (put-string port "FooλBar"))))))
 761
 762 (with-test-prefix "8.3 Simple I/O"
 763   (with-test-prefix "read error"
 764     (pass-if-condition "read-char" i/o-read-error?
 765       (read-char (make-failing-port)))
 766     (pass-if-condition "peek-char" i/o-read-error?
 767       (peek-char (make-failing-port)))
 768     (pass-if-condition "read" i/o-read-error?
 769       (read (make-failing-port))))
 770   (with-test-prefix "write error"
 771     (pass-if-condition "display" i/o-write-error?
 772       (display "Hi there!" (make-failing-port)))
 773     (pass-if-condition "write" i/o-write-error?
 774       (write '(hi there!) (make-failing-port)))
 775     (pass-if-condition "write-char" i/o-write-error?
 776       (write-char #\G (make-failing-port)))
 777     (pass-if-condition "newline" i/o-write-error?
 778       (newline (make-failing-port))))
 779   (let ((filename (test-file)))
 780     ;; ensure the test file exists
 781     (call-with-output-file filename
 782       (lambda (port) (write "foo" port)))
 783     (pass-if "call-with-input-file [port is textual]"
 784       (call-with-input-file filename textual-port?))
 785     (pass-if-condition "call-with-input-file [exception: not-found]"
 786         i/o-file-does-not-exist-error?
 787       (call-with-input-file ",this-is-highly-unlikely-to-exist!"
 788         values))
 789     (pass-if-condition "call-with-output-file [exception: already-exists]"
 790         i/o-file-already-exists-error?
 791       (call-with-output-file filename
 792         values))
 793     (delete-file filename)))
 794
 795 (with-test-prefix "8.2.13 Input/output ports"
 796   (with-test-prefix "open-file-input/output-port [output]"
 797     (test-output-file-opener open-file-input/output-port (test-file)))
 798   (with-test-prefix "open-file-input/output-port [input]"
 799     (test-input-file-opener open-file-input/output-port (test-file))))
 800
 801 ;;; Local Variables:
 802 ;;; mode: scheme
 803 ;;; eval: (put 'guard 'scheme-indent-function 1)
 804 ;;; End: