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