test-suite/tests/r6rs-ports.test

   1 ;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- coding: utf-8; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2009-2012, 2013-2015 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 (ice-9 match)
  26   #:use-module (rnrs io ports)
  27   #:use-module (rnrs io simple)
  28   #:use-module (rnrs exceptions)
  29   #:use-module (rnrs bytevectors))
  30
  31 (define-syntax pass-if-condition
  32   (syntax-rules ()
  33     ((_ name predicate body0 body ...)
  34      (let ((cookie (list 'cookie)))
  35        (pass-if name
  36          (eq? cookie (guard (c ((predicate c) cookie))
  37                        body0 body ...)))))))
  38
  39 (define (test-file)
  40   (data-file-name "ports-test.tmp"))
  41
  42 ;; A input/output port that swallows all output, and produces just
  43 ;; spaces on input.  Reading and writing beyond `failure-position'
  44 ;; produces `system-error' exceptions.  Used for testing exception
  45 ;; behavior.
  46 (define* (make-failing-port #:optional (failure-position 0))
  47   (define (maybe-fail index errno)
  48     (if (> index failure-position)
  49         (scm-error 'system-error
  50                    'failing-port
  51                    "I/O beyond failure position" '()
  52                    (list errno))))
  53   (let ((read-index  0)
  54         (write-index 0))
  55     (define (write-char chr)
  56       (set! write-index (+ 1 write-index))
  57       (maybe-fail write-index ENOSPC))
  58     (make-soft-port
  59      (vector write-char
  60              (lambda (str)   ;; write-string
  61                (for-each write-char (string->list str)))
  62              (lambda () #t)  ;; flush-output
  63              (lambda ()      ;; read-char
  64                (set! read-index (+ read-index 1))
  65                (maybe-fail read-index EIO)
  66                #\space)
  67              (lambda () #t)) ;; close-port
  68      "rw")))
  69
  70 (define (call-with-bytevector-output-port/transcoded transcoder receiver)
  71   (call-with-bytevector-output-port
  72     (lambda (bv-port)
  73       (call-with-port (transcoded-port bv-port transcoder)
  74         receiver))))
  75
  76 \f
  77 (with-test-prefix "7.2.5 End-of-File Object"
  78
  79   (pass-if "eof-object"
  80     (and (eqv? (eof-object) (eof-object))
  81          (eq?  (eof-object) (eof-object))))
  82
  83   (pass-if "port-eof?"
  84     (port-eof? (open-input-string ""))))
  85
  86 \f
  87 (with-test-prefix "7.2.8 Binary Input"
  88
  89   (pass-if "get-u8"
  90     (let ((port (open-input-string "A")))
  91       (and (= (char->integer #\A) (get-u8 port))
  92            (eof-object? (get-u8 port)))))
  93
  94   (pass-if "lookahead-u8"
  95     (let ((port (open-input-string "A")))
  96       (and (= (char->integer #\A) (lookahead-u8 port))
  97            (= (char->integer #\A) (lookahead-u8 port))
  98            (= (char->integer #\A) (get-u8 port))
  99            (eof-object? (get-u8 port)))))
 100
 101   (pass-if "lookahead-u8 non-ASCII"
 102     (let ((port (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   (let ((expected (make-bytevector 20 (char->integer #\a))))
 140     (pass-if-equal "http://bugs.gnu.org/17466"
 141         ;; <http://bugs.gnu.org/17466> is about a memory corruption
 142         ;; whereas bytevector shrunk in 'get-bytevector-n' would keep
 143         ;; referring to the previous (larger) bytevector.
 144         expected
 145       (let loop ((count 50))
 146         (if (zero? count)
 147             expected
 148             (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa"
 149                         (lambda (port)
 150                           (get-bytevector-n port 4096)))))
 151               ;; Cause the 4 KiB bytevector initially created by
 152               ;; 'get-bytevector-n' to be reclaimed.
 153               (make-bytevector 4096)
 154
 155               (if (equal? bv expected)
 156                   (loop (- count 1))
 157                   bv))))))
 158
 159   (pass-if "get-bytevector-n! [short]"
 160     (let* ((port (open-input-string "GNU Guile"))
 161            (bv   (make-bytevector 4))
 162            (read (get-bytevector-n! port bv 0 4)))
 163       (and (equal? read 4)
 164            (equal? (bytevector->u8-list bv)
 165                    (map char->integer (string->list "GNU "))))))
 166
 167   (pass-if "get-bytevector-n! [long]"
 168     (let* ((str  "GNU Guile")
 169            (port (open-input-string str))
 170            (bv   (make-bytevector 256))
 171            (read (get-bytevector-n! port bv 0 256)))
 172       (and (equal? read (string-length str))
 173            (equal? (map (lambda (i)
 174                           (bytevector-u8-ref bv i))
 175                         (iota read))
 176                    (map char->integer (string->list str))))))
 177
 178   (pass-if "get-bytevector-some [simple]"
 179     (let* ((str  "GNU Guile")
 180            (port (open-input-string str))
 181            (bv   (get-bytevector-some port)))
 182       (and (bytevector? bv)
 183            (equal? (bytevector->u8-list bv)
 184                    (map char->integer (string->list str))))))
 185
 186   (pass-if "get-bytevector-all"
 187     (let* ((str   "GNU Guile")
 188            (index 0)
 189            (port  (make-soft-port
 190                    (vector #f #f #f
 191                            (lambda ()
 192                              (if (>= index (string-length str))
 193                                  (eof-object)
 194                                  (let ((c (string-ref str index)))
 195                                    (set! index (+ index 1))
 196                                    c)))
 197                            (lambda () #t)
 198                            (let ((cont? #f))
 199                              (lambda ()
 200                                ;; Number of readily available octets: falls to
 201                                ;; zero after 4 octets have been read and then
 202                                ;; starts again.
 203                                (let ((a (if cont?
 204                                             (- (string-length str) index)
 205                                             (- 4 (modulo index 5)))))
 206                                  (if (= 0 a) (set! cont? #t))
 207                                  a))))
 208                    "r"))
 209            (bv    (get-bytevector-all port)))
 210       (and (bytevector? bv)
 211            (= index (string-length str))
 212            (= (bytevector-length bv) (string-length str))
 213            (equal? (bytevector->u8-list bv)
 214                    (map char->integer (string->list str)))))))
 215
 216 \f
 217 (define (make-soft-output-port)
 218   (let* ((bv (make-bytevector 1024))
 219          (read-index  0)
 220          (write-index 0)
 221          (write-char (lambda (chr)
 222                        (bytevector-u8-set! bv write-index
 223                                            (char->integer chr))
 224                        (set! write-index (+ 1 write-index)))))
 225     (make-soft-port
 226      (vector write-char
 227              (lambda (str)   ;; write-string
 228                (for-each write-char (string->list str)))
 229              (lambda () #t)  ;; flush-output
 230              (lambda ()      ;; read-char
 231                (if (>= read-index (bytevector-length bv))
 232                    (eof-object)
 233                    (let ((c (bytevector-u8-ref bv read-index)))
 234                      (set! read-index (+ read-index 1))
 235                      (integer->char c))))
 236              (lambda () #t)) ;; close-port
 237      "rw")))
 238
 239 (with-test-prefix "7.2.11 Binary Output"
 240
 241   (pass-if "put-u8"
 242     (let ((port (make-soft-output-port)))
 243       (put-u8 port 77)
 244       (equal? (get-u8 port) 77)))
 245
 246   ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
 247   ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
 248   ;; the bytes through, unmodified.  This is hacky, but we can't use
 249   ;; "custom binary output ports" here because they're only tested
 250   ;; later.
 251
 252   (pass-if "put-bytevector [2 args]"
 253     (with-latin1-locale
 254      (let ((port (make-soft-output-port))
 255            (bv   (make-bytevector 256)))
 256        (put-bytevector port bv)
 257        (equal? (bytevector->u8-list bv)
 258                (bytevector->u8-list
 259                 (get-bytevector-n port (bytevector-length bv)))))))
 260
 261   (pass-if "put-bytevector [3 args]"
 262     (with-latin1-locale
 263      (let ((port  (make-soft-output-port))
 264            (bv    (make-bytevector 256))
 265            (start 10))
 266        (put-bytevector port bv start)
 267        (equal? (drop (bytevector->u8-list bv) start)
 268                (bytevector->u8-list
 269                 (get-bytevector-n port (- (bytevector-length bv) start)))))))
 270
 271   (pass-if "put-bytevector [4 args]"
 272     (with-latin1-locale
 273      (let ((port  (make-soft-output-port))
 274            (bv    (make-bytevector 256))
 275            (start 10)
 276            (count 77))
 277        (put-bytevector port bv start count)
 278        (equal? (take (drop (bytevector->u8-list bv) start) count)
 279                (bytevector->u8-list
 280                 (get-bytevector-n port count))))))
 281
 282   (pass-if-exception "put-bytevector with closed port"
 283     exception:wrong-type-arg
 284
 285     (let* ((bv   (make-bytevector 4))
 286            (port (%make-void-port "w")))
 287
 288       (close-port port)
 289       (put-bytevector port bv)))
 290
 291   (pass-if "put-bytevector with UTF-16 string port"
 292     (let* ((str "hello, world")
 293            (bv  (string->utf16 str)))
 294       (equal? str
 295               (call-with-output-string
 296                (lambda (port)
 297                  (set-port-encoding! port "UTF-16BE")
 298                  (put-bytevector port bv))))))
 299
 300   (pass-if "put-bytevector with wrong-encoding string port"
 301     (let* ((str "hello, world")
 302            (bv  (string->utf16 str)))
 303       (catch 'decoding-error
 304         (lambda ()
 305           (with-fluids ((%default-port-conversion-strategy 'error))
 306             (call-with-output-string
 307              (lambda (port)
 308                (set-port-encoding! port "UTF-32")
 309                (put-bytevector port bv)))
 310             #f))                           ; fail if we reach this point
 311         (lambda (key subr message errno port)
 312           (string? (strerror errno)))))))
 313
 314 \f
 315 (define (test-input-file-opener open filename)
 316   (let ((contents (string->utf8 "GNU λ")))
 317     ;; Create file
 318     (call-with-output-file filename
 319       (lambda (port) (put-bytevector port contents)))
 320
 321     (pass-if "opens binary input port with correct contents"
 322       (with-fluids ((%default-port-encoding "UTF-8"))
 323         (call-with-port (open-file-input-port filename)
 324           (lambda (port)
 325             (and (binary-port? port)
 326                  (input-port? port)
 327                  (bytevector=? contents (get-bytevector-all port))))))))
 328
 329   (delete-file filename))
 330
 331 (with-test-prefix "7.2.7 Input Ports"
 332
 333   (with-test-prefix "open-file-input-port"
 334     (test-input-file-opener open-file-input-port (test-file)))
 335
 336   ;; This section appears here so that it can use the binary input
 337   ;; primitives.
 338
 339   (pass-if "open-bytevector-input-port [1 arg]"
 340     (let* ((str "Hello Port!")
 341            (bv (u8-list->bytevector (map char->integer
 342                                          (string->list str))))
 343            (port (open-bytevector-input-port bv))
 344            (read-to-string
 345             (lambda (port)
 346               (let loop ((chr (read-char port))
 347                          (result '()))
 348                 (if (eof-object? chr)
 349                     (apply string (reverse! result))
 350                     (loop (read-char port)
 351                           (cons chr result)))))))
 352
 353       (equal? (read-to-string port) str)))
 354
 355   (pass-if "bytevector-input-port is binary"
 356     (with-fluids ((%default-port-encoding "UTF-8"))
 357       (binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
 358
 359   (pass-if-exception "bytevector-input-port is read-only"
 360     exception:wrong-type-arg
 361
 362     (let* ((str "Hello Port!")
 363            (bv (u8-list->bytevector (map char->integer
 364                                          (string->list str))))
 365            (port (open-bytevector-input-port bv #f)))
 366
 367       (write "hello" port)))
 368
 369   (pass-if "bytevector input port supports seeking"
 370     (let* ((str "Hello Port!")
 371            (bv (u8-list->bytevector (map char->integer
 372                                          (string->list str))))
 373            (port (open-bytevector-input-port bv #f)))
 374
 375       (and (port-has-port-position? port)
 376            (= 0 (port-position port))
 377            (port-has-set-port-position!? port)
 378            (begin
 379              (set-port-position! port 6)
 380              (= 6 (port-position port)))
 381            (bytevector=? (get-bytevector-all port)
 382                          (u8-list->bytevector
 383                           (map char->integer (string->list "Port!")))))))
 384
 385   (pass-if "bytevector input port can seek to very end"
 386     (let ((empty (open-bytevector-input-port '#vu8()))
 387           (not-empty (open-bytevector-input-port '#vu8(1 2 3))))
 388       (and (begin (set-port-position! empty (port-position empty))
 389                   (= 0 (port-position empty)))
 390            (begin (get-bytevector-n not-empty 3)
 391                   (set-port-position! not-empty (port-position not-empty))
 392                   (= 3 (port-position not-empty))))))
 393
 394   (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
 395     exception:wrong-num-args
 396
 397     ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
 398     ;; optional.
 399     (make-custom-binary-input-port "port" (lambda args #t)))
 400
 401   (pass-if "make-custom-binary-input-port"
 402     (let* ((source (make-bytevector 7777))
 403            (read! (let ((pos 0)
 404                         (len (bytevector-length source)))
 405                     (lambda (bv start count)
 406                       (let ((amount (min count (- len pos))))
 407                         (if (> amount 0)
 408                             (bytevector-copy! source pos
 409                                               bv start amount))
 410                         (set! pos (+ pos amount))
 411                         amount))))
 412            (port (make-custom-binary-input-port "the port" read!
 413                                                 #f #f #f)))
 414
 415       (and (binary-port? port)
 416            (input-port? port)
 417            (bytevector=? (get-bytevector-all port) source))))
 418
 419   (pass-if "custom binary input port does not support `port-position'"
 420     (let* ((str "Hello Port!")
 421            (source (open-bytevector-input-port
 422                     (u8-list->bytevector
 423                      (map char->integer (string->list str)))))
 424            (read! (lambda (bv start count)
 425                     (let ((r (get-bytevector-n! source bv start count)))
 426                       (if (eof-object? r)
 427                           0
 428                           r))))
 429            (port (make-custom-binary-input-port "the port" read!
 430                                                 #f #f #f)))
 431       (not (or (port-has-port-position? port)
 432                (port-has-set-port-position!? port)))))
 433
 434   (pass-if-exception "custom binary input port 'read!' returns too much"
 435       exception:out-of-range
 436     ;; In Guile <= 2.0.9 this would segfault.
 437     (let* ((read! (lambda (bv start count)
 438                     (+ count 4242)))
 439            (port (make-custom-binary-input-port "the port" read!
 440                                                 #f #f #f)))
 441       (get-bytevector-all port)))
 442
 443   (pass-if-equal "custom binary input port supports `port-position', \
 444 not `set-port-position!'"
 445       42
 446     (let ((port (make-custom-binary-input-port "the port" (const 0)
 447                                                (const 42) #f #f)))
 448       (and (port-has-port-position? port)
 449            (not (port-has-set-port-position!? port))
 450            (port-position port))))
 451
 452   (pass-if "custom binary input port supports `port-position'"
 453     (let* ((str "Hello Port!")
 454            (source (open-bytevector-input-port
 455                     (u8-list->bytevector
 456                      (map char->integer (string->list str)))))
 457            (read! (lambda (bv start count)
 458                     (let ((r (get-bytevector-n! source bv start count)))
 459                       (if (eof-object? r)
 460                           0
 461                           r))))
 462            (get-pos (lambda ()
 463                       (port-position source)))
 464            (set-pos! (lambda (pos)
 465                        (set-port-position! source pos)))
 466            (port (make-custom-binary-input-port "the port" read!
 467                                                 get-pos set-pos! #f)))
 468
 469       (and (port-has-port-position? port)
 470            (= 0 (port-position port))
 471            (port-has-set-port-position!? port)
 472            (begin
 473              (set-port-position! port 6)
 474              (= 6 (port-position port)))
 475            (bytevector=? (get-bytevector-all port)
 476                          (u8-list->bytevector
 477                           (map char->integer (string->list "Port!")))))))
 478
 479   (pass-if-equal "custom binary input port buffered partial reads"
 480       "Hello Port!"
 481     ;; Check what happens when READ! returns less than COUNT bytes.
 482     (let* ((src    (string->utf8 "Hello Port!"))
 483            (chunks '(2 4 5))                ; provide 2 bytes, then 4, etc.
 484            (offset 0)
 485            (read!  (lambda (bv start count)
 486                      (match chunks
 487                        ((count rest ...)
 488                         (bytevector-copy! src offset bv start count)
 489                         (set! chunks rest)
 490                         (set! offset (+ offset count))
 491                         count)
 492                        (()
 493                         0))))
 494            (port   (make-custom-binary-input-port "the port"
 495                                                   read! #f #f #f)))
 496       (get-string-all port)))
 497
 498   (pass-if-equal "custom binary input port unbuffered & 'port-position'"
 499       '(0 2 5 11)
 500     ;; Check that the value returned by 'port-position' is correct, and
 501     ;; that each 'port-position' call leads one call to the
 502     ;; 'get-position' method.
 503     (let* ((str    "Hello Port!")
 504            (output (make-bytevector (string-length str)))
 505            (source (with-fluids ((%default-port-encoding "UTF-8"))
 506                      (open-string-input-port str)))
 507            (read!  (lambda (bv start count)
 508                      (let ((r (get-bytevector-n! source bv start count)))
 509                        (if (eof-object? r)
 510                            0
 511                            r))))
 512            (pos     '())
 513            (get-pos (lambda ()
 514                       (let ((p (port-position source)))
 515                         (set! pos (cons p pos))
 516                         p)))
 517            (port    (make-custom-binary-input-port "the port" read!
 518                                                    get-pos #f #f)))
 519       (setvbuf port _IONBF)
 520       (and (= 0 (port-position port))
 521            (begin
 522              (get-bytevector-n! port output 0 2)
 523              (= 2 (port-position port)))
 524            (begin
 525              (get-bytevector-n! port output 2 3)
 526              (= 5 (port-position port)))
 527            (let ((bv (string->utf8 (get-string-all port))))
 528              (bytevector-copy! bv 0 output 5 (bytevector-length bv))
 529              (= (string-length str) (port-position port)))
 530            (bytevector=? output (string->utf8 str))
 531            (reverse pos))))
 532
 533   (pass-if-equal "custom binary input port unbuffered & 'read!' calls"
 534       `((2 "He") (3 "llo") (42 " Port!"))
 535     (let* ((str    "Hello Port!")
 536            (source (with-fluids ((%default-port-encoding "UTF-8"))
 537                      (open-string-input-port str)))
 538            (reads  '())
 539            (read!  (lambda (bv start count)
 540                      (set! reads (cons count reads))
 541                      (let ((r (get-bytevector-n! source bv start count)))
 542                        (if (eof-object? r)
 543                            0
 544                            r))))
 545            (port   (make-custom-binary-input-port "the port" read!
 546                                                   #f #f #f)))
 547
 548       (setvbuf port _IONBF)
 549       (let ((ret (list (get-bytevector-n port 2)
 550                        (get-bytevector-n port 3)
 551                        (get-bytevector-n port 42))))
 552         (zip (reverse reads)
 553              (map (lambda (obj)
 554                     (if (bytevector? obj)
 555                         (utf8->string obj)
 556                         obj))
 557                   ret)))))
 558
 559   (pass-if-equal "custom binary input port unbuffered & 'get-string-all'"
 560       (make-string 1000 #\a)
 561     ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
 562     ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
 563     (let* ((input (with-fluids ((%default-port-encoding #f))
 564                     (open-input-string (make-string 1000 #\a))))
 565            (read! (lambda (bv index count)
 566                     (let ((n (get-bytevector-n! input bv index
 567                                                 count)))
 568                       (if (eof-object? n) 0 n))))
 569            (port  (make-custom-binary-input-port "foo" read!
 570                                                  #f #f #f)))
 571       (setvbuf port _IONBF)
 572       (get-string-all port)))
 573
 574   (pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'"
 575       (make-string 1000 #\λ)
 576     ;; In Guile 2.0.11 this test would lead to a buffer overrun followed
 577     ;; by an assertion failure.  See <http://bugs.gnu.org/19621>.
 578     (let* ((input (with-fluids ((%default-port-encoding "UTF-8"))
 579                     (open-input-string (make-string 1000 #\λ))))
 580            (read! (lambda (bv index count)
 581                     (let ((n (get-bytevector-n! input bv index
 582                                                 count)))
 583                       (if (eof-object? n) 0 n))))
 584            (port  (make-custom-binary-input-port "foo" read!
 585                                                  #f #f #f)))
 586       (setvbuf port _IONBF)
 587       (set-port-encoding! port "UTF-8")
 588       (get-string-all port)))
 589
 590   (pass-if-equal "custom binary input port, unbuffered then buffered"
 591       `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…")
 592         (777 ,(eof-object)))
 593     (let* ((str    "Lorem ipsum dolor sit amet, consectetur…")
 594            (source (with-fluids ((%default-port-encoding "UTF-8"))
 595                      (open-string-input-port str)))
 596            (reads  '())
 597            (read!  (lambda (bv start count)
 598                      (set! reads (cons count reads))
 599                      (let ((r (get-bytevector-n! source bv start count)))
 600                        (if (eof-object? r)
 601                            0
 602                            r))))
 603            (port   (make-custom-binary-input-port "the port" read!
 604                                                   #f #f #f)))
 605
 606       (setvbuf port _IONBF)
 607       (let ((ret (list (get-bytevector-n port 6)
 608                        (get-bytevector-n port 12)
 609                        (begin
 610                          (setvbuf port _IOFBF 777)
 611                          (get-bytevector-n port 42))
 612                        (get-bytevector-n port 42))))
 613         (zip (reverse reads)
 614              (map (lambda (obj)
 615                     (if (bytevector? obj)
 616                         (utf8->string obj)
 617                         obj))
 618                   ret)))))
 619
 620   (pass-if-equal "custom binary input port, buffered then unbuffered"
 621       `((18
 622          42 14             ; scm_c_read tries to fill the 42-byte buffer
 623          42)
 624         ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object)))
 625     (let* ((str    "Lorem ipsum dolor sit amet, consectetur bla…")
 626            (source (with-fluids ((%default-port-encoding "UTF-8"))
 627                      (open-string-input-port str)))
 628            (reads  '())
 629            (read!  (lambda (bv start count)
 630                      (set! reads (cons count reads))
 631                      (let ((r (get-bytevector-n! source bv start count)))
 632                        (if (eof-object? r)
 633                            0
 634                            r))))
 635            (port   (make-custom-binary-input-port "the port" read!
 636                                                   #f #f #f)))
 637
 638       (setvbuf port _IOFBF 18)
 639       (let ((ret (list (get-bytevector-n port 6)
 640                        (get-bytevector-n port 12)
 641                        (begin
 642                          (setvbuf port _IONBF)
 643                          (get-bytevector-n port 42))
 644                        (get-bytevector-n port 42))))
 645         (list (reverse reads)
 646               (map (lambda (obj)
 647                      (if (bytevector? obj)
 648                          (utf8->string obj)
 649                          obj))
 650                    ret)))))
 651
 652   (pass-if "custom binary input port `close-proc' is called"
 653     (let* ((closed?  #f)
 654            (read!    (lambda (bv start count) 0))
 655            (get-pos  (lambda () 0))
 656            (set-pos! (lambda (pos) #f))
 657            (close!   (lambda () (set! closed? #t)))
 658            (port     (make-custom-binary-input-port "the port" read!
 659                                                     get-pos set-pos!
 660                                                     close!)))
 661
 662       (close-port port)
 663       (gc) ; Test for marking a closed port.
 664       closed?))
 665
 666   (pass-if "standard-input-port is binary"
 667     (with-fluids ((%default-port-encoding "UTF-8"))
 668       (binary-port? (standard-input-port)))))
 669
 670 \f
 671 (define (test-output-file-opener open filename)
 672   (with-fluids ((%default-port-encoding "UTF-8"))
 673     (pass-if "opens binary output port"
 674              (call-with-port (open filename)
 675                (lambda (port)
 676                  (put-bytevector port '#vu8(1 2 3))
 677                  (and (binary-port? port)
 678                       (output-port? port))))))
 679
 680   (pass-if-condition "exception: already-exists"
 681                      i/o-file-already-exists-error?
 682                      (open filename))
 683
 684   (pass-if "no-fail no-truncate"
 685            (and
 686              (call-with-port (open filename (file-options no-fail no-truncate))
 687                (lambda (port)
 688                  (= 0 (port-position port))))
 689              (= 3 (stat:size (stat filename)))))
 690
 691   (pass-if "no-fail"
 692            (and
 693              (call-with-port (open filename (file-options no-fail))
 694                binary-port?)
 695              (= 0 (stat:size (stat filename)))))
 696
 697   (delete-file filename)
 698
 699   (pass-if-condition "exception: does-not-exist"
 700                      i/o-file-does-not-exist-error?
 701                      (open filename (file-options no-create))))
 702
 703 (with-test-prefix "8.2.10 Output ports"
 704
 705   (with-test-prefix "open-file-output-port"
 706     (test-output-file-opener open-file-output-port (test-file)))
 707
 708   (pass-if "open-bytevector-output-port"
 709     (let-values (((port get-content)
 710                   (open-bytevector-output-port #f)))
 711       (let ((source (make-bytevector 7777)))
 712         (put-bytevector port source)
 713         (and (bytevector=? (get-content) source)
 714              (bytevector=? (get-content) (make-bytevector 0))))))
 715
 716   (pass-if "bytevector-output-port is binary"
 717     (binary-port? (open-bytevector-output-port)))
 718
 719   (pass-if "open-bytevector-output-port [extract after close]"
 720     (let-values (((port get-content)
 721                   (open-bytevector-output-port)))
 722       (let ((source (make-bytevector 12345 #xFE)))
 723         (put-bytevector port source)
 724         (close-port port)
 725         (bytevector=? (get-content) source))))
 726
 727   (pass-if "open-bytevector-output-port [put-u8]"
 728     (let-values (((port get-content)
 729                   (open-bytevector-output-port)))
 730       (put-u8 port 77)
 731       (and (bytevector=? (get-content) (make-bytevector 1 77))
 732            (bytevector=? (get-content) (make-bytevector 0)))))
 733
 734   (pass-if "open-bytevector-output-port [display]"
 735     (let-values (((port get-content)
 736                   (open-bytevector-output-port)))
 737       (display "hello" port)
 738       (and (bytevector=? (get-content) (string->utf8 "hello"))
 739            (bytevector=? (get-content) (make-bytevector 0)))))
 740
 741   (pass-if "bytevector output port supports `port-position'"
 742     (let-values (((port get-content)
 743                   (open-bytevector-output-port)))
 744       (let ((source (make-bytevector 7777))
 745             (overwrite (make-bytevector 33)))
 746         (and (port-has-port-position? port)
 747              (port-has-set-port-position!? port)
 748              (begin
 749                (put-bytevector port source)
 750                (= (bytevector-length source)
 751                   (port-position port)))
 752              (begin
 753                (set-port-position! port 10)
 754                (= 10 (port-position port)))
 755              (begin
 756                (put-bytevector port overwrite)
 757                (bytevector-copy! overwrite 0 source 10
 758                                  (bytevector-length overwrite))
 759                (= (port-position port)
 760                   (+ 10 (bytevector-length overwrite))))
 761              (bytevector=? (get-content) source)
 762              (bytevector=? (get-content) (make-bytevector 0))))))
 763
 764   (pass-if "make-custom-binary-output-port"
 765     (let ((port (make-custom-binary-output-port "cbop"
 766                                                 (lambda (x y z) 0)
 767                                                 #f #f #f)))
 768       (and (output-port? port)
 769            (binary-port? port)
 770            (not (port-has-port-position? port))
 771            (not (port-has-set-port-position!? port)))))
 772
 773   (pass-if "make-custom-binary-output-port [partial writes]"
 774     (let* ((source   (uint-list->bytevector (iota 333)
 775                                             (native-endianness) 2))
 776            (sink     (make-bytevector (bytevector-length source)))
 777            (sink-pos 0)
 778            (eof?     #f)
 779            (write!   (lambda (bv start count)
 780                        (if (= 0 count)
 781                            (begin
 782                              (set! eof? #t)
 783                              0)
 784                            (let ((u8 (bytevector-u8-ref bv start)))
 785                              ;; Get one byte at a time.
 786                              (bytevector-u8-set! sink sink-pos u8)
 787                              (set! sink-pos (+ 1 sink-pos))
 788                              1))))
 789            (port     (make-custom-binary-output-port "cbop" write!
 790                                                      #f #f #f)))
 791       (put-bytevector port source)
 792       (and (= sink-pos (bytevector-length source))
 793            (not eof?)
 794            (bytevector=? sink source))))
 795
 796   (pass-if "make-custom-binary-output-port [full writes]"
 797     (let* ((source   (uint-list->bytevector (iota 333)
 798                                             (native-endianness) 2))
 799            (sink     (make-bytevector (bytevector-length source)))
 800            (sink-pos 0)
 801            (eof?     #f)
 802            (write!   (lambda (bv start count)
 803                        (if (= 0 count)
 804                            (begin
 805                              (set! eof? #t)
 806                              0)
 807                            (begin
 808                              (bytevector-copy! bv start
 809                                                sink sink-pos
 810                                                count)
 811                              (set! sink-pos (+ sink-pos count))
 812                              count))))
 813            (port     (make-custom-binary-output-port "cbop" write!
 814                                                      #f #f #f)))
 815       (put-bytevector port source)
 816       (and (= sink-pos (bytevector-length source))
 817            (not eof?)
 818            (bytevector=? sink source))))
 819
 820   (pass-if "standard-output-port is binary"
 821     (with-fluids ((%default-port-encoding "UTF-8"))
 822       (binary-port? (standard-output-port))))
 823
 824   (pass-if "standard-error-port is binary"
 825     (with-fluids ((%default-port-encoding "UTF-8"))
 826       (binary-port? (standard-error-port)))))
 827
 828 \f
 829 (with-test-prefix "8.2.6  Input and output ports"
 830
 831   (pass-if "transcoded-port [output]"
 832     (let ((s "Hello\nÄÖÜ"))
 833       (bytevector=?
 834        (string->utf8 s)
 835        (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
 836          (lambda (utf8-port)
 837            (put-string utf8-port s))))))
 838
 839   (pass-if "transcoded-port [input]"
 840     (let ((s "Hello\nÄÖÜ"))
 841       (string=?
 842        s
 843        (get-string-all
 844         (transcoded-port (open-bytevector-input-port (string->utf8 s))
 845                          (make-transcoder (utf-8-codec)))))))
 846
 847   (pass-if "transcoded-port [input line]"
 848     (string=? "ÄÖÜ"
 849               (get-line (transcoded-port
 850                          (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
 851                          (make-transcoder (utf-8-codec))))))
 852
 853   (pass-if "transcoded-port [error handling mode = raise]"
 854     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 855                                 (error-handling-mode raise)))
 856            (b  (open-bytevector-input-port #vu8(255 2 1)))
 857            (tp (transcoded-port b t)))
 858       (guard (c ((i/o-decoding-error? c)
 859                  (eq? (i/o-error-port c) tp)))
 860         (get-line tp)
 861         #f)))                              ; fail if we reach this point
 862
 863   (pass-if "transcoded-port [error handling mode = replace]"
 864     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 865                                 (error-handling-mode replace)))
 866            (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
 867            (tp (transcoded-port b t)))
 868       (string-suffix? "gnu" (get-line tp))))
 869
 870   (pass-if "transcoded-port, output [error handling mode = raise]"
 871     (let-values (((p get)
 872                   (open-bytevector-output-port)))
 873       (let* ((t  (make-transcoder (latin-1-codec) (native-eol-style)
 874                                   (error-handling-mode raise)))
 875              (tp (transcoded-port p t)))
 876         (guard (c ((i/o-encoding-error? c)
 877                    (and (eq? (i/o-error-port c) tp)
 878                         (char=? (i/o-encoding-error-char c) #\λ)
 879                         (bytevector=? (get) (string->utf8 "The letter ")))))
 880           (put-string tp "The letter λ cannot be represented in Latin-1.")
 881           #f))))
 882
 883   (pass-if "port-transcoder [transcoded port]"
 884     (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
 885                                (make-transcoder (utf-8-codec))))
 886            (t (port-transcoder p)))
 887       (and t
 888            (transcoder-codec t)
 889            (eq? (native-eol-style)
 890                 (transcoder-eol-style t))
 891            (eq? (error-handling-mode replace)
 892                 (transcoder-error-handling-mode t))))))
 893
 894 (with-test-prefix "8.2.9  Textual input"
 895
 896   (pass-if "get-string-n [short]"
 897     (let ((port (open-input-string "GNU Guile")))
 898       (string=? "GNU " (get-string-n port 4))))
 899   (pass-if "get-string-n [long]"
 900     (let ((port (open-input-string "GNU Guile")))
 901       (string=? "GNU Guile" (get-string-n port 256))))
 902   (pass-if "get-string-n [eof]"
 903     (let ((port (open-input-string "")))
 904       (eof-object? (get-string-n port 4))))
 905
 906   (pass-if "get-string-n! [short]"
 907     (let ((port (open-input-string "GNU Guile"))
 908           (s (string-copy "Isn't XXX great?")))
 909       (and (= 3 (get-string-n! port s 6 3))
 910            (string=? s "Isn't GNU great?"))))
 911
 912   (with-test-prefix "read error"
 913     (pass-if-condition "get-char" i/o-read-error?
 914       (get-char (make-failing-port)))
 915     (pass-if-condition "lookahead-char" i/o-read-error?
 916       (lookahead-char (make-failing-port)))
 917     ;; FIXME: these are not yet exception-correct
 918     #|
 919     (pass-if-condition "get-string-n" i/o-read-error?
 920       (get-string-n (make-failing-port) 5))
 921     (pass-if-condition "get-string-n!" i/o-read-error?
 922       (get-string-n! (make-failing-port) (make-string 5) 0 5))
 923     |#
 924     (pass-if-condition "get-string-all" i/o-read-error?
 925       (get-string-all (make-failing-port 100)))
 926     (pass-if-condition "get-line" i/o-read-error?
 927       (get-line (make-failing-port)))
 928     (pass-if-condition "get-datum" i/o-read-error?
 929       (get-datum (make-failing-port)))))
 930
 931 (define (encoding-error-predicate char)
 932   (lambda (c)
 933     (and (i/o-encoding-error? c)
 934          (char=? char (i/o-encoding-error-char c)))))
 935
 936 (with-test-prefix "8.2.12 Textual Output"
 937
 938   (with-test-prefix "write error"
 939     (pass-if-condition "put-char" i/o-write-error?
 940       (put-char (make-failing-port) #\G))
 941     (pass-if-condition "put-string" i/o-write-error?
 942       (put-string (make-failing-port) "Hello World!"))
 943     (pass-if-condition "put-datum" i/o-write-error?
 944       (put-datum (make-failing-port) '(hello world!))))
 945   (with-test-prefix "encoding error"
 946     (pass-if-condition "put-char" (encoding-error-predicate #\λ)
 947       (call-with-bytevector-output-port/transcoded
 948           (make-transcoder (latin-1-codec)
 949                            (native-eol-style)
 950                            (error-handling-mode raise))
 951         (lambda (port)
 952           (put-char port #\λ))))
 953     (pass-if-condition "put-string" (encoding-error-predicate #\λ)
 954       (call-with-bytevector-output-port/transcoded
 955           (make-transcoder (latin-1-codec)
 956                            (native-eol-style)
 957                            (error-handling-mode raise))
 958         (lambda (port)
 959           (put-string port "FooλBar"))))))
 960
 961 (with-test-prefix "8.3 Simple I/O"
 962   (with-test-prefix "read error"
 963     (pass-if-condition "read-char" i/o-read-error?
 964       (read-char (make-failing-port)))
 965     (pass-if-condition "peek-char" i/o-read-error?
 966       (peek-char (make-failing-port)))
 967     (pass-if-condition "read" i/o-read-error?
 968       (read (make-failing-port))))
 969   (with-test-prefix "write error"
 970     (pass-if-condition "display" i/o-write-error?
 971       (display "Hi there!" (make-failing-port)))
 972     (pass-if-condition "write" i/o-write-error?
 973       (write '(hi there!) (make-failing-port)))
 974     (pass-if-condition "write-char" i/o-write-error?
 975       (write-char #\G (make-failing-port)))
 976     (pass-if-condition "newline" i/o-write-error?
 977       (newline (make-failing-port))))
 978   (let ((filename (test-file)))
 979     ;; ensure the test file exists
 980     (call-with-output-file filename
 981       (lambda (port) (write "foo" port)))
 982     (pass-if "call-with-input-file [port is textual]"
 983       (call-with-input-file filename textual-port?))
 984     (pass-if-condition "call-with-input-file [exception: not-found]"
 985         i/o-file-does-not-exist-error?
 986       (call-with-input-file ",this-is-highly-unlikely-to-exist!"
 987         values))
 988     (pass-if-condition "call-with-output-file [exception: already-exists]"
 989         i/o-file-already-exists-error?
 990       (call-with-output-file filename
 991         values))
 992     (delete-file filename)))
 993
 994 (with-test-prefix "8.2.13 Input/output ports"
 995   (with-test-prefix "open-file-input/output-port [output]"
 996     (test-output-file-opener open-file-input/output-port (test-file)))
 997   (with-test-prefix "open-file-input/output-port [input]"
 998     (test-input-file-opener open-file-input/output-port (test-file))))
 999
1000 ;;; Local Variables:
1001 ;;; mode: scheme
1002 ;;; eval: (put 'guard 'scheme-indent-function 1)
1003 ;;; End: