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 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 ;;; All these tests assume Guile 1.8's port system, where characters are
  31 ;;; treated as octets.
  32
  33 ;; Set the default encoding of future ports to be Latin-1.
  34 (fluid-set! %default-port-encoding #f)
  35
  36 (define-syntax pass-if-condition
  37   (syntax-rules ()
  38     ((_ name predicate body0 body ...)
  39      (let ((cookie (list 'cookie)))
  40        (pass-if name
  41          (eq? cookie (guard (c ((predicate c) cookie))
  42                        body0 body ...)))))))
  43
  44 (define (test-file)
  45   (data-file-name "ports-test.tmp"))
  46
  47 ;; A input/output port that swallows all output, and produces just
  48 ;; spaces on input.  Reading and writing beyond `failure-position'
  49 ;; produces `system-error' exceptions.  Used for testing exception
  50 ;; behavior.
  51 (define* (make-failing-port #:optional (failure-position 0))
  52   (define (maybe-fail index errno)
  53     (if (> index failure-position)
  54         (scm-error 'system-error
  55                    'failing-port
  56                    "I/O beyond failure position" '()
  57                    (list errno))))
  58   (let ((read-index  0)
  59         (write-index 0))
  60     (define (write-char chr)
  61       (set! write-index (+ 1 write-index))
  62       (maybe-fail write-index ENOSPC))
  63     (make-soft-port
  64      (vector write-char
  65              (lambda (str)   ;; write-string
  66                (for-each write-char (string->list str)))
  67              (lambda () #t)  ;; flush-output
  68              (lambda ()      ;; read-char
  69                (set! read-index (+ read-index 1))
  70                (maybe-fail read-index EIO)
  71                #\space)
  72              (lambda () #t)) ;; close-port
  73      "rw")))
  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-some [only-some]"
 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                            (lambda ()
 179                              ;; Number of readily available octets: falls to
 180                              ;; zero after 4 octets have been read.
 181                              (- 4 (modulo index 5))))
 182                    "r"))
 183            (bv    (get-bytevector-some port)))
 184       (and (bytevector? bv)
 185            (= index 4)
 186            (= (bytevector-length bv) index)
 187            (equal? (bytevector->u8-list bv)
 188                    (map char->integer (string->list "GNU "))))))
 189
 190   (pass-if "get-bytevector-all"
 191     (let* ((str   "GNU Guile")
 192            (index 0)
 193            (port  (make-soft-port
 194                    (vector #f #f #f
 195                            (lambda ()
 196                              (if (>= index (string-length str))
 197                                  (eof-object)
 198                                  (let ((c (string-ref str index)))
 199                                    (set! index (+ index 1))
 200                                    c)))
 201                            (lambda () #t)
 202                            (let ((cont? #f))
 203                              (lambda ()
 204                                ;; Number of readily available octets: falls to
 205                                ;; zero after 4 octets have been read and then
 206                                ;; starts again.
 207                                (let ((a (if cont?
 208                                             (- (string-length str) index)
 209                                             (- 4 (modulo index 5)))))
 210                                  (if (= 0 a) (set! cont? #t))
 211                                  a))))
 212                    "r"))
 213            (bv    (get-bytevector-all port)))
 214       (and (bytevector? bv)
 215            (= index (string-length str))
 216            (= (bytevector-length bv) (string-length str))
 217            (equal? (bytevector->u8-list bv)
 218                    (map char->integer (string->list str)))))))
 219
 220 \f
 221 (define (make-soft-output-port)
 222   (let* ((bv (make-bytevector 1024))
 223          (read-index  0)
 224          (write-index 0)
 225          (write-char (lambda (chr)
 226                        (bytevector-u8-set! bv write-index
 227                                            (char->integer chr))
 228                        (set! write-index (+ 1 write-index)))))
 229     (make-soft-port
 230      (vector write-char
 231              (lambda (str)   ;; write-string
 232                (for-each write-char (string->list str)))
 233              (lambda () #t)  ;; flush-output
 234              (lambda ()      ;; read-char
 235                (if (>= read-index (bytevector-length bv))
 236                    (eof-object)
 237                    (let ((c (bytevector-u8-ref bv read-index)))
 238                      (set! read-index (+ read-index 1))
 239                      (integer->char c))))
 240              (lambda () #t)) ;; close-port
 241      "rw")))
 242
 243 (with-test-prefix "7.2.11 Binary Output"
 244
 245   (pass-if "put-u8"
 246     (let ((port (make-soft-output-port)))
 247       (put-u8 port 77)
 248       (equal? (get-u8 port) 77)))
 249
 250   ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
 251   ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
 252   ;; the bytes through, unmodified.  This is hacky, but we can't use
 253   ;; "custom binary output ports" here because they're only tested
 254   ;; later.
 255
 256   (pass-if "put-bytevector [2 args]"
 257     (with-latin1-locale
 258      (let ((port (make-soft-output-port))
 259            (bv   (make-bytevector 256)))
 260        (put-bytevector port bv)
 261        (equal? (bytevector->u8-list bv)
 262                (bytevector->u8-list
 263                 (get-bytevector-n port (bytevector-length bv)))))))
 264
 265   (pass-if "put-bytevector [3 args]"
 266     (with-latin1-locale
 267      (let ((port  (make-soft-output-port))
 268            (bv    (make-bytevector 256))
 269            (start 10))
 270        (put-bytevector port bv start)
 271        (equal? (drop (bytevector->u8-list bv) start)
 272                (bytevector->u8-list
 273                 (get-bytevector-n port (- (bytevector-length bv) start)))))))
 274
 275   (pass-if "put-bytevector [4 args]"
 276     (with-latin1-locale
 277      (let ((port  (make-soft-output-port))
 278            (bv    (make-bytevector 256))
 279            (start 10)
 280            (count 77))
 281        (put-bytevector port bv start count)
 282        (equal? (take (drop (bytevector->u8-list bv) start) count)
 283                (bytevector->u8-list
 284                 (get-bytevector-n port count))))))
 285
 286   (pass-if-exception "put-bytevector with closed port"
 287     exception:wrong-type-arg
 288
 289     (let* ((bv   (make-bytevector 4))
 290            (port (%make-void-port "w")))
 291
 292       (close-port port)
 293       (put-bytevector port bv)))
 294
 295   (pass-if "put-bytevector with UTF-16 string port"
 296     (let* ((str "hello, world")
 297            (bv  (string->utf16 str)))
 298       (equal? str
 299               (with-fluids ((%default-port-encoding "UTF-16BE"))
 300                 (call-with-output-string
 301                   (lambda (port)
 302                     (put-bytevector port bv)))))))
 303
 304   (pass-if "put-bytevector with wrong-encoding string port"
 305     (let* ((str "hello, world")
 306            (bv  (string->utf16 str)))
 307       (catch 'decoding-error
 308         (lambda ()
 309           (with-fluids ((%default-port-encoding "UTF-32"))
 310             (call-with-output-string
 311               (lambda (port)
 312                 (put-bytevector port bv)))))
 313         (lambda (key subr message errno port)
 314           (string? (strerror errno)))))))
 315
 316 \f
 317 (with-test-prefix "7.2.7 Input Ports"
 318
 319   ;; This section appears here so that it can use the binary input
 320   ;; primitives.
 321
 322   (pass-if "open-bytevector-input-port [1 arg]"
 323     (let* ((str "Hello Port!")
 324            (bv (u8-list->bytevector (map char->integer
 325                                          (string->list str))))
 326            (port (open-bytevector-input-port bv))
 327            (read-to-string
 328             (lambda (port)
 329               (let loop ((chr (read-char port))
 330                          (result '()))
 331                 (if (eof-object? chr)
 332                     (apply string (reverse! result))
 333                     (loop (read-char port)
 334                           (cons chr result)))))))
 335
 336       (equal? (read-to-string port) str)))
 337
 338   (pass-if "bytevector-input-port is binary"
 339     (with-fluids ((%default-port-encoding "UTF-8"))
 340       (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
 341
 342   (pass-if-exception "bytevector-input-port is read-only"
 343     exception:wrong-type-arg
 344
 345     (let* ((str "Hello Port!")
 346            (bv (u8-list->bytevector (map char->integer
 347                                          (string->list str))))
 348            (port (open-bytevector-input-port bv #f)))
 349
 350       (write "hello" port)))
 351
 352   (pass-if "bytevector input port supports seeking"
 353     (let* ((str "Hello Port!")
 354            (bv (u8-list->bytevector (map char->integer
 355                                          (string->list str))))
 356            (port (open-bytevector-input-port bv #f)))
 357
 358       (and (port-has-port-position? port)
 359            (= 0 (port-position port))
 360            (port-has-set-port-position!? port)
 361            (begin
 362              (set-port-position! port 6)
 363              (= 6 (port-position port)))
 364            (bytevector=? (get-bytevector-all port)
 365                          (u8-list->bytevector
 366                           (map char->integer (string->list "Port!")))))))
 367
 368   (pass-if "bytevector input port can seek to very end"
 369     (let ((empty (open-bytevector-input-port '#vu8()))
 370           (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
 371       (and (begin (set-port-position! empty (port-position empty))
 372                   (= 0 (port-position empty)))
 373            (begin (get-bytevector-n not-empty 3)
 374                   (set-port-position! not-empty (port-position not-empty))
 375                   (= 3 (port-position not-empty))))))
 376
 377   (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
 378     exception:wrong-num-args
 379
 380     ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
 381     ;; optional.
 382     (make-custom-binary-input-port "port" (lambda args #t)))
 383
 384   (pass-if "make-custom-binary-input-port"
 385     (let* ((source (make-bytevector 7777))
 386            (read! (let ((pos 0)
 387                         (len (bytevector-length source)))
 388                     (lambda (bv start count)
 389                       (let ((amount (min count (- len pos))))
 390                         (if (> amount 0)
 391                             (bytevector-copy! source pos
 392                                               bv start amount))
 393                         (set! pos (+ pos amount))
 394                         amount))))
 395            (port (make-custom-binary-input-port "the port" read!
 396                                                 #f #f #f)))
 397
 398       (and (binary-port? port)
 399            (input-port? port)
 400            (bytevector=? (get-bytevector-all port) source))))
 401
 402   (pass-if "custom binary input port does not support `port-position'"
 403     (let* ((str "Hello Port!")
 404            (source (open-bytevector-input-port
 405                     (u8-list->bytevector
 406                      (map char->integer (string->list str)))))
 407            (read! (lambda (bv start count)
 408                     (let ((r (get-bytevector-n! source bv start count)))
 409                       (if (eof-object? r)
 410                           0
 411                           r))))
 412            (port (make-custom-binary-input-port "the port" read!
 413                                                 #f #f #f)))
 414       (not (or (port-has-port-position? port)
 415                (port-has-set-port-position!? port)))))
 416
 417   (pass-if "custom binary input port supports `port-position'"
 418     (let* ((str "Hello Port!")
 419            (source (open-bytevector-input-port
 420                     (u8-list->bytevector
 421                      (map char->integer (string->list str)))))
 422            (read! (lambda (bv start count)
 423                     (let ((r (get-bytevector-n! source bv start count)))
 424                       (if (eof-object? r)
 425                           0
 426                           r))))
 427            (get-pos (lambda ()
 428                       (port-position source)))
 429            (set-pos! (lambda (pos)
 430                        (set-port-position! source pos)))
 431            (port (make-custom-binary-input-port "the port" read!
 432                                                 get-pos set-pos! #f)))
 433
 434       (and (port-has-port-position? port)
 435            (= 0 (port-position port))
 436            (port-has-set-port-position!? port)
 437            (begin
 438              (set-port-position! port 6)
 439              (= 6 (port-position port)))
 440            (bytevector=? (get-bytevector-all port)
 441                          (u8-list->bytevector
 442                           (map char->integer (string->list "Port!")))))))
 443
 444   (pass-if "custom binary input port `close-proc' is called"
 445     (let* ((closed?  #f)
 446            (read!    (lambda (bv start count) 0))
 447            (get-pos  (lambda () 0))
 448            (set-pos! (lambda (pos) #f))
 449            (close!   (lambda () (set! closed? #t)))
 450            (port     (make-custom-binary-input-port "the port" read!
 451                                                     get-pos set-pos!
 452                                                     close!)))
 453
 454       (close-port port)
 455       (gc) ; Test for marking a closed port.
 456       closed?))
 457
 458   (pass-if "standard-input-port is binary"
 459     (with-fluids ((%default-port-encoding "UTF-8"))
 460       (binary-port? (standard-input-port)))))
 461
 462 \f
 463 (with-test-prefix "8.2.10 Output ports"
 464
 465   (let ((filename (test-file)))
 466     (pass-if "open-file-output-port [opens binary port]"
 467       (call-with-port (open-file-output-port filename)
 468         (lambda (port)
 469           (put-bytevector port '#vu8(1 2 3))
 470           (binary-port? port))))
 471
 472     (pass-if-condition "open-file-output-port [exception: already-exists]"
 473         i/o-file-already-exists-error?
 474       (open-file-output-port filename))
 475
 476     (pass-if "open-file-output-port [no-fail no-truncate]"
 477       (and
 478         (call-with-port (open-file-output-port filename
 479                                                (file-options no-fail no-truncate))
 480           (lambda (port)
 481             (= 0 (port-position port))))
 482         (= 3 (stat:size (stat filename)))))
 483
 484     (pass-if "open-file-output-port [no-fail]"
 485       (and
 486         (call-with-port (open-file-output-port filename (file-options no-fail))
 487           binary-port?)
 488         (= 0 (stat:size (stat filename)))))
 489
 490     (delete-file filename)
 491
 492     (pass-if-condition "open-file-output-port [exception: does-not-exist]"
 493         i/o-file-does-not-exist-error?
 494       (open-file-output-port filename (file-options no-create))))
 495
 496   (pass-if "open-bytevector-output-port"
 497     (let-values (((port get-content)
 498                   (open-bytevector-output-port #f)))
 499       (let ((source (make-bytevector 7777)))
 500         (put-bytevector port source)
 501         (and (bytevector=? (get-content) source)
 502              (bytevector=? (get-content) (make-bytevector 0))))))
 503
 504   (pass-if "bytevector-output-port is binary"
 505     (binary-port? (open-bytevector-output-port)))
 506
 507   (pass-if "open-bytevector-output-port [extract after close]"
 508     (let-values (((port get-content)
 509                   (open-bytevector-output-port)))
 510       (let ((source (make-bytevector 12345 #xFE)))
 511         (put-bytevector port source)
 512         (close-port port)
 513         (bytevector=? (get-content) source))))
 514
 515   (pass-if "open-bytevector-output-port [put-u8]"
 516     (let-values (((port get-content)
 517                   (open-bytevector-output-port)))
 518       (put-u8 port 77)
 519       (and (bytevector=? (get-content) (make-bytevector 1 77))
 520            (bytevector=? (get-content) (make-bytevector 0)))))
 521
 522   (pass-if "open-bytevector-output-port [display]"
 523     (let-values (((port get-content)
 524                   (open-bytevector-output-port)))
 525       (display "hello" port)
 526       (and (bytevector=? (get-content) (string->utf8 "hello"))
 527            (bytevector=? (get-content) (make-bytevector 0)))))
 528
 529   (pass-if "bytevector output port supports `port-position'"
 530     (let-values (((port get-content)
 531                   (open-bytevector-output-port)))
 532       (let ((source (make-bytevector 7777))
 533             (overwrite (make-bytevector 33)))
 534         (and (port-has-port-position? port)
 535              (port-has-set-port-position!? port)
 536              (begin
 537                (put-bytevector port source)
 538                (= (bytevector-length source)
 539                   (port-position port)))
 540              (begin
 541                (set-port-position! port 10)
 542                (= 10 (port-position port)))
 543              (begin
 544                (put-bytevector port overwrite)
 545                (bytevector-copy! overwrite 0 source 10
 546                                  (bytevector-length overwrite))
 547                (= (port-position port)
 548                   (+ 10 (bytevector-length overwrite))))
 549              (bytevector=? (get-content) source)
 550              (bytevector=? (get-content) (make-bytevector 0))))))
 551
 552   (pass-if "make-custom-binary-output-port"
 553     (let ((port (make-custom-binary-output-port "cbop"
 554                                                 (lambda (x y z) 0)
 555                                                 #f #f #f)))
 556       (and (output-port? port)
 557            (binary-port? port)
 558            (not (port-has-port-position? port))
 559            (not (port-has-set-port-position!? port)))))
 560
 561   (pass-if "make-custom-binary-output-port [partial writes]"
 562     (let* ((source   (uint-list->bytevector (iota 333)
 563                                             (native-endianness) 2))
 564            (sink     (make-bytevector (bytevector-length source)))
 565            (sink-pos 0)
 566            (eof?     #f)
 567            (write!   (lambda (bv start count)
 568                        (if (= 0 count)
 569                            (begin
 570                              (set! eof? #t)
 571                              0)
 572                            (let ((u8 (bytevector-u8-ref bv start)))
 573                              ;; Get one byte at a time.
 574                              (bytevector-u8-set! sink sink-pos u8)
 575                              (set! sink-pos (+ 1 sink-pos))
 576                              1))))
 577            (port     (make-custom-binary-output-port "cbop" write!
 578                                                      #f #f #f)))
 579       (put-bytevector port source)
 580       (and (= sink-pos (bytevector-length source))
 581            (not eof?)
 582            (bytevector=? sink source))))
 583
 584   (pass-if "make-custom-binary-output-port [full writes]"
 585     (let* ((source   (uint-list->bytevector (iota 333)
 586                                             (native-endianness) 2))
 587            (sink     (make-bytevector (bytevector-length source)))
 588            (sink-pos 0)
 589            (eof?     #f)
 590            (write!   (lambda (bv start count)
 591                        (if (= 0 count)
 592                            (begin
 593                              (set! eof? #t)
 594                              0)
 595                            (begin
 596                              (bytevector-copy! bv start
 597                                                sink sink-pos
 598                                                count)
 599                              (set! sink-pos (+ sink-pos count))
 600                              count))))
 601            (port     (make-custom-binary-output-port "cbop" write!
 602                                                      #f #f #f)))
 603       (put-bytevector port source)
 604       (and (= sink-pos (bytevector-length source))
 605            (not eof?)
 606            (bytevector=? sink source))))
 607
 608   (pass-if "standard-output-port is binary"
 609     (with-fluids ((%default-port-encoding "UTF-8"))
 610       (binary-port? (standard-output-port))))
 611
 612   (pass-if "standard-error-port is binary"
 613     (with-fluids ((%default-port-encoding "UTF-8"))
 614       (binary-port? (standard-error-port)))))
 615
 616 \f
 617 (with-test-prefix "8.2.6  Input and output ports"
 618
 619   (pass-if "transcoded-port [output]"
 620     (let ((s "Hello\nÄÖÜ"))
 621       (bytevector=?
 622        (string->utf8 s)
 623        (call-with-bytevector-output-port
 624          (lambda (bv-port)
 625            (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
 626              (lambda (utf8-port)
 627                (put-string utf8-port s))))))))
 628
 629   (pass-if "transcoded-port [input]"
 630     (let ((s "Hello\nÄÖÜ"))
 631       (string=?
 632        s
 633        (get-string-all
 634         (transcoded-port (open-bytevector-input-port (string->utf8 s))
 635                          (make-transcoder (utf-8-codec)))))))
 636
 637   (pass-if "transcoded-port [input line]"
 638     (string=? "ÄÖÜ"
 639               (get-line (transcoded-port
 640                          (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
 641                          (make-transcoder (utf-8-codec))))))
 642
 643   (pass-if "transcoded-port [error handling mode = raise]"
 644     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 645                                 (error-handling-mode raise)))
 646            (b  (open-bytevector-input-port #vu8(255 2 1)))
 647            (tp (transcoded-port b t)))
 648       (guard (c ((i/o-decoding-error? c)
 649                  (eq? (i/o-error-port c) tp)))
 650         (get-line tp))))
 651
 652   (pass-if "transcoded-port [error handling mode = replace]"
 653     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 654                                 (error-handling-mode replace)))
 655            (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
 656            (tp (transcoded-port b t)))
 657       (string-suffix? "gnu" (get-line tp))))
 658
 659   (pass-if "transcoded-port, output [error handling mode = raise]"
 660     (let-values (((p get)
 661                   (open-bytevector-output-port)))
 662       (let* ((t  (make-transcoder (latin-1-codec) (native-eol-style)
 663                                   (error-handling-mode raise)))
 664              (tp (transcoded-port p t)))
 665         (guard (c ((i/o-encoding-error? c)
 666                    (and (eq? (i/o-error-port c) tp)
 667                         (char=? (i/o-encoding-error-char c) #\λ)
 668                         (bytevector=? (get) (string->utf8 "The letter ")))))
 669           (put-string tp "The letter λ cannot be represented in Latin-1.")
 670           #f))))
 671
 672   (pass-if "port-transcoder [binary port]"
 673     (not (port-transcoder (open-bytevector-input-port #vu8()))))
 674
 675   (pass-if "port-transcoder [transcoded port]"
 676     (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
 677                                (make-transcoder (utf-8-codec))))
 678            (t (port-transcoder p)))
 679       (and t
 680            (transcoder-codec t)
 681            (eq? (native-eol-style)
 682                 (transcoder-eol-style t))
 683            (eq? (error-handling-mode replace)
 684                 (transcoder-error-handling-mode t))))))
 685
 686 (with-test-prefix "8.2.9  Textual input"
 687
 688   (pass-if "get-string-n [short]"
 689     (let ((port (open-input-string "GNU Guile")))
 690       (string=? "GNU " (get-string-n port 4))))
 691   (pass-if "get-string-n [long]"
 692     (let ((port (open-input-string "GNU Guile")))
 693       (string=? "GNU Guile" (get-string-n port 256))))
 694   (pass-if "get-string-n [eof]"
 695     (let ((port (open-input-string "")))
 696       (eof-object? (get-string-n port 4))))
 697
 698   (pass-if "get-string-n! [short]"
 699     (let ((port (open-input-string "GNU Guile"))
 700           (s (string-copy "Isn't XXX great?")))
 701       (and (= 3 (get-string-n! port s 6 3))
 702            (string=? s "Isn't GNU great?"))))
 703
 704   (with-test-prefix "read error"
 705     (pass-if-condition "get-char" i/o-read-error?
 706       (get-char (make-failing-port)))
 707     (pass-if-condition "lookahead-char" i/o-read-error?
 708       (lookahead-char (make-failing-port)))
 709     ;; FIXME: these are not yet exception-correct
 710     #|
 711     (pass-if-condition "get-string-n" i/o-read-error?
 712       (get-string-n (make-failing-port) 5))
 713     (pass-if-condition "get-string-n!" i/o-read-error?
 714       (get-string-n! (make-failing-port) (make-string 5) 0 5))
 715     |#
 716     (pass-if-condition "get-string-all" i/o-read-error?
 717       (get-string-all (make-failing-port 100)))
 718     (pass-if-condition "get-line" i/o-read-error?
 719       (get-line (make-failing-port)))
 720     (pass-if-condition "get-datum" i/o-read-error?
 721       (get-datum (make-failing-port)))))
 722
 723 (with-test-prefix "8.2.12 Textual Output"
 724
 725   (with-test-prefix "write error"
 726     (pass-if-condition "put-char" i/o-write-error?
 727       (put-char (make-failing-port) #\G))
 728     (pass-if-condition "put-string" i/o-write-error?
 729       (put-string (make-failing-port) "Hello World!"))
 730     (pass-if-condition "put-datum" i/o-write-error?
 731       (put-datum (make-failing-port) '(hello world!)))))
 732
 733 (with-test-prefix "8.3 Simple I/O"
 734   (with-test-prefix "read error"
 735     (pass-if-condition "read-char" i/o-read-error?
 736       (read-char (make-failing-port)))
 737     (pass-if-condition "peek-char" i/o-read-error?
 738       (peek-char (make-failing-port)))
 739     (pass-if-condition "read" i/o-read-error?
 740       (read (make-failing-port))))
 741   (with-test-prefix "write error"
 742     (pass-if-condition "display" i/o-write-error?
 743       (display "Hi there!" (make-failing-port)))
 744     (pass-if-condition "write" i/o-write-error?
 745       (write '(hi there!) (make-failing-port)))
 746     (pass-if-condition "write-char" i/o-write-error?
 747       (write-char #\G (make-failing-port)))
 748     (pass-if-condition "newline" i/o-write-error?
 749       (newline (make-failing-port))))
 750   (let ((filename (test-file)))
 751     ;; ensure the test file exists
 752     (call-with-output-file filename
 753       (lambda (port) (write "foo" port)))
 754     (pass-if "call-with-input-file [port is textual]"
 755       (call-with-input-file filename textual-port?))
 756     (pass-if-condition "call-with-input-file [exception: not-found]"
 757         i/o-file-does-not-exist-error?
 758       (call-with-input-file ",this-is-highly-unlikely-to-exist!"
 759         values))
 760     (pass-if-condition "call-with-output-file [exception: already-exists]"
 761         i/o-file-already-exists-error?
 762       (call-with-output-file filename
 763         values))
 764     (delete-file filename)))
 765
 766 ;;; Local Variables:
 767 ;;; mode: scheme
 768 ;;; eval: (put 'guard 'scheme-indent-function 1)
 769 ;;; End: