test-suite/tests/r6rs-ports.test

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