test-suite/tests/r6rs-ports.test

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