test-suite/tests/r6rs-ports.test

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