test-suite/tests/r6rs-ports.test

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