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