test-suite/tests/r6rs-ports.test

   1 ;;;; r6rs-ports.test --- R6RS I/O port tests.   -*- coding: utf-8; -*-
   2 ;;;;
   3 ;;;; Copyright (C) 2009, 2010 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 (srfi srfi-1)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (rnrs io ports)
  25   #:use-module (rnrs bytevectors))
  26
  27 ;;; All these tests assume Guile 1.8's port system, where characters are
  28 ;;; treated as octets.
  29
  30 ;; Set the default encoding of future ports to be Latin-1.
  31 (fluid-set! %default-port-encoding #f)
  32
  33 \f
  34 (with-test-prefix "7.2.5 End-of-File Object"
  35
  36   (pass-if "eof-object"
  37     (and (eqv? (eof-object) (eof-object))
  38          (eq?  (eof-object) (eof-object)))))
  39
  40 \f
  41 (with-test-prefix "7.2.8 Binary Input"
  42
  43   (pass-if "get-u8"
  44     (let ((port (open-input-string "A")))
  45       (and (= (char->integer #\A) (get-u8 port))
  46            (eof-object? (get-u8 port)))))
  47
  48   (pass-if "lookahead-u8"
  49     (let ((port (open-input-string "A")))
  50       (and (= (char->integer #\A) (lookahead-u8 port))
  51            (= (char->integer #\A) (lookahead-u8 port))
  52            (= (char->integer #\A) (get-u8 port))
  53            (eof-object? (get-u8 port)))))
  54
  55   (pass-if "lookahead-u8 non-ASCII"
  56     (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
  57                   (open-input-string "λ"))))
  58       (and (= 206 (lookahead-u8 port))
  59            (= 206 (lookahead-u8 port))
  60            (= 206 (get-u8 port))
  61            (= 187 (lookahead-u8 port))
  62            (= 187 (lookahead-u8 port))
  63            (= 187 (get-u8 port))
  64            (eof-object? (lookahead-u8 port))
  65            (eof-object? (get-u8 port)))))
  66
  67   (pass-if "lookahead-u8: result is unsigned"
  68     ;; Bug #31081.
  69     (let ((port (open-bytevector-input-port #vu8(255))))
  70       (= (lookahead-u8 port) 255)))
  71
  72   (pass-if "get-bytevector-n [short]"
  73     (let* ((port (open-input-string "GNU Guile"))
  74            (bv (get-bytevector-n port 4)))
  75       (and (bytevector? bv)
  76            (equal? (bytevector->u8-list bv)
  77                    (map char->integer (string->list "GNU "))))))
  78
  79   (pass-if "get-bytevector-n [long]"
  80     (let* ((port (open-input-string "GNU Guile"))
  81            (bv (get-bytevector-n port 256)))
  82       (and (bytevector? bv)
  83            (equal? (bytevector->u8-list bv)
  84                    (map char->integer (string->list "GNU Guile"))))))
  85
  86   (pass-if-exception "get-bytevector-n with closed port"
  87     exception:wrong-type-arg
  88
  89     (let ((port (%make-void-port "r")))
  90
  91       (close-port port)
  92       (get-bytevector-n port 3)))
  93
  94   (pass-if "get-bytevector-n! [short]"
  95     (let* ((port (open-input-string "GNU Guile"))
  96            (bv   (make-bytevector 4))
  97            (read (get-bytevector-n! port bv 0 4)))
  98       (and (equal? read 4)
  99            (equal? (bytevector->u8-list bv)
 100                    (map char->integer (string->list "GNU "))))))
 101
 102   (pass-if "get-bytevector-n! [long]"
 103     (let* ((str  "GNU Guile")
 104            (port (open-input-string str))
 105            (bv   (make-bytevector 256))
 106            (read (get-bytevector-n! port bv 0 256)))
 107       (and (equal? read (string-length str))
 108            (equal? (map (lambda (i)
 109                           (bytevector-u8-ref bv i))
 110                         (iota read))
 111                    (map char->integer (string->list str))))))
 112
 113   (pass-if "get-bytevector-some [simple]"
 114     (let* ((str  "GNU Guile")
 115            (port (open-input-string str))
 116            (bv   (get-bytevector-some port)))
 117       (and (bytevector? bv)
 118            (equal? (bytevector->u8-list bv)
 119                    (map char->integer (string->list str))))))
 120
 121   (pass-if "get-bytevector-some [only-some]"
 122     (let* ((str   "GNU Guile")
 123            (index 0)
 124            (port  (make-soft-port
 125                    (vector #f #f #f
 126                            (lambda ()
 127                              (if (>= index (string-length str))
 128                                  (eof-object)
 129                                  (let ((c (string-ref str index)))
 130                                    (set! index (+ index 1))
 131                                    c)))
 132                            (lambda () #t)
 133                            (lambda ()
 134                              ;; Number of readily available octets: falls to
 135                              ;; zero after 4 octets have been read.
 136                              (- 4 (modulo index 5))))
 137                    "r"))
 138            (bv    (get-bytevector-some port)))
 139       (and (bytevector? bv)
 140            (= index 4)
 141            (= (bytevector-length bv) index)
 142            (equal? (bytevector->u8-list bv)
 143                    (map char->integer (string->list "GNU "))))))
 144
 145   (pass-if "get-bytevector-all"
 146     (let* ((str   "GNU Guile")
 147            (index 0)
 148            (port  (make-soft-port
 149                    (vector #f #f #f
 150                            (lambda ()
 151                              (if (>= index (string-length str))
 152                                  (eof-object)
 153                                  (let ((c (string-ref str index)))
 154                                    (set! index (+ index 1))
 155                                    c)))
 156                            (lambda () #t)
 157                            (let ((cont? #f))
 158                              (lambda ()
 159                                ;; Number of readily available octets: falls to
 160                                ;; zero after 4 octets have been read and then
 161                                ;; starts again.
 162                                (let ((a (if cont?
 163                                             (- (string-length str) index)
 164                                             (- 4 (modulo index 5)))))
 165                                  (if (= 0 a) (set! cont? #t))
 166                                  a))))
 167                    "r"))
 168            (bv    (get-bytevector-all port)))
 169       (and (bytevector? bv)
 170            (= index (string-length str))
 171            (= (bytevector-length bv) (string-length str))
 172            (equal? (bytevector->u8-list bv)
 173                    (map char->integer (string->list str)))))))
 174
 175 \f
 176 (define (make-soft-output-port)
 177   (let* ((bv (make-bytevector 1024))
 178          (read-index  0)
 179          (write-index 0)
 180          (write-char (lambda (chr)
 181                        (bytevector-u8-set! bv write-index
 182                                            (char->integer chr))
 183                        (set! write-index (+ 1 write-index)))))
 184     (make-soft-port
 185      (vector write-char
 186              (lambda (str)   ;; write-string
 187                (for-each write-char (string->list str)))
 188              (lambda () #t)  ;; flush-output
 189              (lambda ()      ;; read-char
 190                (if (>= read-index (bytevector-length bv))
 191                    (eof-object)
 192                    (let ((c (bytevector-u8-ref bv read-index)))
 193                      (set! read-index (+ read-index 1))
 194                      (integer->char c))))
 195              (lambda () #t)) ;; close-port
 196      "rw")))
 197
 198 (with-test-prefix "7.2.11 Binary Output"
 199
 200   (pass-if "put-u8"
 201     (let ((port (make-soft-output-port)))
 202       (put-u8 port 77)
 203       (equal? (get-u8 port) 77)))
 204
 205   ;; Note: The `put-bytevector' tests below require a Latin-1 locale so
 206   ;; that the `scm_from_locale_stringn' call in `sf_write' will let all
 207   ;; the bytes through, unmodified.  This is hacky, but we can't use
 208   ;; "custom binary output ports" here because they're only tested
 209   ;; later.
 210
 211   (pass-if "put-bytevector [2 args]"
 212     (with-latin1-locale
 213      (let ((port (make-soft-output-port))
 214            (bv   (make-bytevector 256)))
 215        (put-bytevector port bv)
 216        (equal? (bytevector->u8-list bv)
 217                (bytevector->u8-list
 218                 (get-bytevector-n port (bytevector-length bv)))))))
 219
 220   (pass-if "put-bytevector [3 args]"
 221     (with-latin1-locale
 222      (let ((port  (make-soft-output-port))
 223            (bv    (make-bytevector 256))
 224            (start 10))
 225        (put-bytevector port bv start)
 226        (equal? (drop (bytevector->u8-list bv) start)
 227                (bytevector->u8-list
 228                 (get-bytevector-n port (- (bytevector-length bv) start)))))))
 229
 230   (pass-if "put-bytevector [4 args]"
 231     (with-latin1-locale
 232      (let ((port  (make-soft-output-port))
 233            (bv    (make-bytevector 256))
 234            (start 10)
 235            (count 77))
 236        (put-bytevector port bv start count)
 237        (equal? (take (drop (bytevector->u8-list bv) start) count)
 238                (bytevector->u8-list
 239                 (get-bytevector-n port count))))))
 240
 241   (pass-if-exception "put-bytevector with closed port"
 242     exception:wrong-type-arg
 243
 244     (let* ((bv   (make-bytevector 4))
 245            (port (%make-void-port "w")))
 246
 247       (close-port port)
 248       (put-bytevector port bv)))
 249
 250   (pass-if "put-bytevector with UTF-16 string port"
 251     (let* ((str "hello, world")
 252            (bv  (string->utf16 str)))
 253       (equal? str
 254               (with-fluids ((%default-port-encoding "UTF-16BE"))
 255                 (call-with-output-string
 256                   (lambda (port)
 257                     (put-bytevector port bv)))))))
 258
 259   (pass-if "put-bytevector with wrong-encoding string port"
 260     (let* ((str "hello, world")
 261            (bv  (string->utf16 str)))
 262       (catch 'encoding-error
 263         (lambda ()
 264           (with-fluids ((%default-port-encoding "UTF-32"))
 265             (call-with-output-string
 266               (lambda (port)
 267                 (put-bytevector port bv)))))
 268         (lambda (key subr message errno from to faulty-bv)
 269           (and (bytevector=? faulty-bv bv)
 270                (string=? to "UTF-32")
 271                (string? (strerror errno))))))))
 272
 273 \f
 274 (with-test-prefix "7.2.7 Input Ports"
 275
 276   ;; This section appears here so that it can use the binary input
 277   ;; primitives.
 278
 279   (pass-if "open-bytevector-input-port [1 arg]"
 280     (let* ((str "Hello Port!")
 281            (bv (u8-list->bytevector (map char->integer
 282                                          (string->list str))))
 283            (port (open-bytevector-input-port bv))
 284            (read-to-string
 285             (lambda (port)
 286               (let loop ((chr (read-char port))
 287                          (result '()))
 288                 (if (eof-object? chr)
 289                     (apply string (reverse! result))
 290                     (loop (read-char port)
 291                           (cons chr result)))))))
 292
 293       (equal? (read-to-string port) str)))
 294
 295   (pass-if-exception "bytevector-input-port is read-only"
 296     exception:wrong-type-arg
 297
 298     (let* ((str "Hello Port!")
 299            (bv (u8-list->bytevector (map char->integer
 300                                          (string->list str))))
 301            (port (open-bytevector-input-port bv #f)))
 302
 303       (write "hello" port)))
 304
 305   (pass-if "bytevector input port supports seeking"
 306     (let* ((str "Hello Port!")
 307            (bv (u8-list->bytevector (map char->integer
 308                                          (string->list str))))
 309            (port (open-bytevector-input-port bv #f)))
 310
 311       (and (port-has-port-position? port)
 312            (= 0 (port-position port))
 313            (port-has-set-port-position!? port)
 314            (begin
 315              (set-port-position! port 6)
 316              (= 6 (port-position port)))
 317            (bytevector=? (get-bytevector-all port)
 318                          (u8-list->bytevector
 319                           (map char->integer (string->list "Port!")))))))
 320
 321   (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
 322     exception:wrong-num-args
 323
 324     ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
 325     ;; optional.
 326     (make-custom-binary-input-port "port" (lambda args #t)))
 327
 328   (pass-if "make-custom-binary-input-port"
 329     (let* ((source (make-bytevector 7777))
 330            (read! (let ((pos 0)
 331                         (len (bytevector-length source)))
 332                     (lambda (bv start count)
 333                       (let ((amount (min count (- len pos))))
 334                         (if (> amount 0)
 335                             (bytevector-copy! source pos
 336                                               bv start amount))
 337                         (set! pos (+ pos amount))
 338                         amount))))
 339            (port (make-custom-binary-input-port "the port" read!
 340                                                 #f #f #f)))
 341
 342       (bytevector=? (get-bytevector-all port) source)))
 343
 344   (pass-if "custom binary input port does not support `port-position'"
 345     (let* ((str "Hello Port!")
 346            (source (open-bytevector-input-port
 347                     (u8-list->bytevector
 348                      (map char->integer (string->list str)))))
 349            (read! (lambda (bv start count)
 350                     (let ((r (get-bytevector-n! source bv start count)))
 351                       (if (eof-object? r)
 352                           0
 353                           r))))
 354            (port (make-custom-binary-input-port "the port" read!
 355                                                 #f #f #f)))
 356       (not (or (port-has-port-position? port)
 357                (port-has-set-port-position!? port)))))
 358
 359   (pass-if "custom binary input port supports `port-position'"
 360     (let* ((str "Hello Port!")
 361            (source (open-bytevector-input-port
 362                     (u8-list->bytevector
 363                      (map char->integer (string->list str)))))
 364            (read! (lambda (bv start count)
 365                     (let ((r (get-bytevector-n! source bv start count)))
 366                       (if (eof-object? r)
 367                           0
 368                           r))))
 369            (get-pos (lambda ()
 370                       (port-position source)))
 371            (set-pos! (lambda (pos)
 372                        (set-port-position! source pos)))
 373            (port (make-custom-binary-input-port "the port" read!
 374                                                 get-pos set-pos! #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 "custom binary input port `close-proc' is called"
 387     (let* ((closed?  #f)
 388            (read!    (lambda (bv start count) 0))
 389            (get-pos  (lambda () 0))
 390            (set-pos! (lambda (pos) #f))
 391            (close!   (lambda () (set! closed? #t)))
 392            (port     (make-custom-binary-input-port "the port" read!
 393                                                     get-pos set-pos!
 394                                                     close!)))
 395
 396       (close-port port)
 397       (gc) ; Test for marking a closed port.
 398       closed?)))
 399
 400 \f
 401 (with-test-prefix "8.2.10 Output ports"
 402
 403   (pass-if "open-bytevector-output-port"
 404     (let-values (((port get-content)
 405                   (open-bytevector-output-port #f)))
 406       (let ((source (make-bytevector 7777)))
 407         (put-bytevector port source)
 408         (and (bytevector=? (get-content) source)
 409              (bytevector=? (get-content) (make-bytevector 0))))))
 410
 411   (pass-if "open-bytevector-output-port [extract after close]"
 412     (let-values (((port get-content)
 413                   (open-bytevector-output-port)))
 414       (let ((source (make-bytevector 12345 #xFE)))
 415         (put-bytevector port source)
 416         (close-port port)
 417         (bytevector=? (get-content) source))))
 418
 419   (pass-if "open-bytevector-output-port [put-u8]"
 420     (let-values (((port get-content)
 421                   (open-bytevector-output-port)))
 422       (put-u8 port 77)
 423       (and (bytevector=? (get-content) (make-bytevector 1 77))
 424            (bytevector=? (get-content) (make-bytevector 0)))))
 425
 426   (pass-if "open-bytevector-output-port [display]"
 427     (let-values (((port get-content)
 428                   (open-bytevector-output-port)))
 429       (display "hello" port)
 430       (and (bytevector=? (get-content) (string->utf8 "hello"))
 431            (bytevector=? (get-content) (make-bytevector 0)))))
 432
 433   (pass-if "bytevector output port supports `port-position'"
 434     (let-values (((port get-content)
 435                   (open-bytevector-output-port)))
 436       (let ((source (make-bytevector 7777))
 437             (overwrite (make-bytevector 33)))
 438         (and (port-has-port-position? port)
 439              (port-has-set-port-position!? port)
 440              (begin
 441                (put-bytevector port source)
 442                (= (bytevector-length source)
 443                   (port-position port)))
 444              (begin
 445                (set-port-position! port 10)
 446                (= 10 (port-position port)))
 447              (begin
 448                (put-bytevector port overwrite)
 449                (bytevector-copy! overwrite 0 source 10
 450                                  (bytevector-length overwrite))
 451                (= (port-position port)
 452                   (+ 10 (bytevector-length overwrite))))
 453              (bytevector=? (get-content) source)
 454              (bytevector=? (get-content) (make-bytevector 0))))))
 455
 456   (pass-if "make-custom-binary-output"
 457     (let ((port (make-custom-binary-output-port "cbop"
 458                                                 (lambda (x y z) 0)
 459                                                 #f #f #f)))
 460       (and (output-port? port)
 461            (binary-port? port)
 462            (not (port-has-port-position? port))
 463            (not (port-has-set-port-position!? port)))))
 464
 465   (pass-if "make-custom-binary-output-port [partial writes]"
 466     (let* ((source   (uint-list->bytevector (iota 333)
 467                                             (native-endianness) 2))
 468            (sink     (make-bytevector (bytevector-length source)))
 469            (sink-pos 0)
 470            (eof?     #f)
 471            (write!   (lambda (bv start count)
 472                        (if (= 0 count)
 473                            (begin
 474                              (set! eof? #t)
 475                              0)
 476                            (let ((u8 (bytevector-u8-ref bv start)))
 477                              ;; Get one byte at a time.
 478                              (bytevector-u8-set! sink sink-pos u8)
 479                              (set! sink-pos (+ 1 sink-pos))
 480                              1))))
 481            (port     (make-custom-binary-output-port "cbop" write!
 482                                                      #f #f #f)))
 483       (put-bytevector port source)
 484       (and (= sink-pos (bytevector-length source))
 485            (not eof?)
 486            (bytevector=? sink source))))
 487
 488   (pass-if "make-custom-binary-output-port [full writes]"
 489     (let* ((source   (uint-list->bytevector (iota 333)
 490                                             (native-endianness) 2))
 491            (sink     (make-bytevector (bytevector-length source)))
 492            (sink-pos 0)
 493            (eof?     #f)
 494            (write!   (lambda (bv start count)
 495                        (if (= 0 count)
 496                            (begin
 497                              (set! eof? #t)
 498                              0)
 499                            (begin
 500                              (bytevector-copy! bv start
 501                                                sink sink-pos
 502                                                count)
 503                              (set! sink-pos (+ sink-pos count))
 504                              count))))
 505            (port     (make-custom-binary-output-port "cbop" write!
 506                                                      #f #f #f)))
 507       (put-bytevector port source)
 508       (and (= sink-pos (bytevector-length source))
 509            (not eof?)
 510            (bytevector=? sink source)))))
 511
 512 \f
 513 (with-test-prefix "8.2.6  Input and output ports"
 514
 515   (pass-if "transcoded-port [output]"
 516     (let ((s "Hello\nÄÖÜ"))
 517       (bytevector=?
 518        (string->utf8 s)
 519        (call-with-bytevector-output-port
 520          (lambda (bv-port)
 521            (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
 522              (lambda (utf8-port)
 523                (put-string utf8-port s))))))))
 524
 525   (pass-if "transcoded-port [input]"
 526     (let ((s "Hello\nÄÖÜ"))
 527       (string=?
 528        s
 529        (get-string-all
 530         (transcoded-port (open-bytevector-input-port (string->utf8 s))
 531                          (make-transcoder (utf-8-codec)))))))
 532
 533   (pass-if "transcoded-port [input line]"
 534     (string=? "ÄÖÜ"
 535               (get-line (transcoded-port
 536                          (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar"))
 537                          (make-transcoder (utf-8-codec))))))
 538
 539   (pass-if "transcoded-port [error handling mode = raise]"
 540     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 541                                 (error-handling-mode raise)))
 542            (b  (open-bytevector-input-port #vu8(255 2 1)))
 543            (tp (transcoded-port b t)))
 544       ;; FIXME: Should be (guard (c ((i/o-decoding-error? c) #t)) ...).
 545       (catch 'encoding-error
 546         (lambda ()
 547           (get-line tp)
 548           #f)
 549         (lambda _
 550           #t))))
 551
 552   (pass-if "transcoded-port [error handling mode = replace]"
 553     (let* ((t  (make-transcoder (utf-8-codec) (native-eol-style)
 554                                 (error-handling-mode replace)))
 555            (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
 556            (tp (transcoded-port b t)))
 557       (string-suffix? "gnu" (get-line tp)))))
 558
 559 ;;; Local Variables:
 560 ;;; mode: scheme
 561 ;;; End: