tests/io-ports.test

   1 ;;; R6RS I/O Ports.
   2 ;;;
   3 ;;; Copyright 2007  Ludovic Courtès <ludovic.courtes@laas.fr>
   4 ;;;
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 2 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; This program 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
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  19
  20 (define-module (test-i/o-ports)
  21   :use-module (test-suite lib)
  22   :use-module (srfi srfi-1)
  23   :use-module (srfi srfi-11)
  24   :use-module (r6rs i/o ports)
  25   :use-module (r6rs 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 "get-bytevector-n! [short]"
  67     (let* ((port (open-input-string "GNU Guile"))
  68            (bv   (make-bytevector 4))
  69            (read (get-bytevector-n! port bv 0 4)))
  70       (and (equal? read 4)
  71            (equal? (bytevector->u8-list bv)
  72                    (map char->integer (string->list "GNU "))))))
  73
  74   (pass-if "get-bytevector-n! [long]"
  75     (let* ((str  "GNU Guile")
  76            (port (open-input-string str))
  77            (bv   (make-bytevector 256))
  78            (read (get-bytevector-n! port bv 0 256)))
  79       (and (equal? read (string-length str))
  80            (equal? (map (lambda (i)
  81                           (bytevector-u8-ref bv i))
  82                         (iota read))
  83                    (map char->integer (string->list str))))))
  84
  85   (pass-if "get-bytevector-some [simple]"
  86     (let* ((str  "GNU Guile")
  87            (port (open-input-string str))
  88            (bv   (get-bytevector-some port)))
  89       (and (bytevector? bv)
  90            (equal? (bytevector->u8-list bv)
  91                    (map char->integer (string->list str))))))
  92
  93   (pass-if "get-bytevector-some [only-some]"
  94     (let* ((str   "GNU Guile")
  95            (index 0)
  96            (port  (make-soft-port
  97                    (vector #f #f #f
  98                            (lambda ()
  99                              (if (>= index (string-length str))
 100                                  (eof-object)
 101                                  (let ((c (string-ref str index)))
 102                                    (set! index (+ index 1))
 103                                    c)))
 104                            (lambda () #t)
 105                            (lambda ()
 106                              ;; Number of readily available octets: falls to
 107                              ;; zero after 4 octets have been read.
 108                              (- 4 (modulo index 5))))
 109                    "r"))
 110            (bv    (get-bytevector-some port)))
 111       (and (bytevector? bv)
 112            (= index 4)
 113            (= (bytevector-length bv) index)
 114            (equal? (bytevector->u8-list bv)
 115                    (map char->integer (string->list "GNU "))))))
 116
 117   (pass-if "get-bytevector-all"
 118     (let* ((str   "GNU Guile")
 119            (index 0)
 120            (port  (make-soft-port
 121                    (vector #f #f #f
 122                            (lambda ()
 123                              (if (>= index (string-length str))
 124                                  (eof-object)
 125                                  (let ((c (string-ref str index)))
 126                                    (set! index (+ index 1))
 127                                    c)))
 128                            (lambda () #t)
 129                            (let ((cont? #f))
 130                              (lambda ()
 131                                ;; Number of readily available octets: falls to
 132                                ;; zero after 4 octets have been read and then
 133                                ;; starts again.
 134                                (let ((a (if cont?
 135                                             (- (string-length str) index)
 136                                             (- 4 (modulo index 5)))))
 137                                  (if (= 0 a) (set! cont? #t))
 138                                  a))))
 139                    "r"))
 140            (bv    (get-bytevector-all port)))
 141       (and (bytevector? bv)
 142            (= index (string-length str))
 143            (= (bytevector-length bv) (string-length str))
 144            (equal? (bytevector->u8-list bv)
 145                    (map char->integer (string->list str)))))))
 146
 147 \f
 148 (define (make-soft-output-port)
 149   (let* ((bv (make-bytevector 1024))
 150          (read-index  0)
 151          (write-index 0)
 152          (write-char (lambda (chr)
 153                        (bytevector-u8-set! bv write-index
 154                                            (char->integer chr))
 155                        (set! write-index (+ 1 write-index)))))
 156     (make-soft-port
 157      (vector write-char
 158              (lambda (str)   ;; write-string
 159                (for-each write-char (string->list str)))
 160              (lambda () #t)  ;; flush-output
 161              (lambda ()      ;; read-char
 162                (if (>= read-index (bytevector-length bv))
 163                    (eof-object)
 164                    (let ((c (bytevector-u8-ref bv read-index)))
 165                      (set! read-index (+ read-index 1))
 166                      (integer->char c))))
 167              (lambda () #t)) ;; close-port
 168      "rw")))
 169
 170 (with-test-prefix "7.2.11 Binary Output"
 171
 172   (pass-if "put-u8"
 173     (let ((port (make-soft-output-port)))
 174       (put-u8 port 77)
 175       (equal? (get-u8 port) 77)))
 176
 177   (pass-if "put-bytevector [2 args]"
 178     (let ((port (make-soft-output-port))
 179           (bv   (make-bytevector 256)))
 180       (put-bytevector port bv)
 181       (equal? (bytevector->u8-list bv)
 182               (bytevector->u8-list
 183                (get-bytevector-n port (bytevector-length bv))))))
 184
 185   (pass-if "put-bytevector [3 args]"
 186     (let ((port  (make-soft-output-port))
 187           (bv    (make-bytevector 256))
 188           (start 10))
 189       (put-bytevector port bv start)
 190       (equal? (drop (bytevector->u8-list bv) start)
 191               (bytevector->u8-list
 192                (get-bytevector-n port (- (bytevector-length bv) start))))))
 193
 194   (pass-if "put-bytevector [4 args]"
 195     (let ((port  (make-soft-output-port))
 196           (bv    (make-bytevector 256))
 197           (start 10)
 198           (count 77))
 199       (put-bytevector port bv start count)
 200       (equal? (take (drop (bytevector->u8-list bv) start) count)
 201               (bytevector->u8-list
 202                (get-bytevector-n port count)))))
 203
 204   (pass-if "open-bytevector-output-port"
 205     (let-values (((port get-content)
 206                   (open-bytevector-output-port)))
 207       (let ((source (make-bytevector 7777)))
 208         (put-bytevector port source)
 209         (and (bytevector=? (get-content) source)
 210              (bytevector=? (get-content) (make-bytevector 0))))))
 211
 212   (pass-if "bytevector output port supports `port-position'"
 213     (let-values (((port get-content)
 214                   (open-bytevector-output-port)))
 215       (let ((source (make-bytevector 7777))
 216             (overwrite (make-bytevector 33)))
 217         (and (port-has-port-position? port)
 218              (port-has-set-port-position!? port)
 219              (begin
 220                (put-bytevector port source)
 221                (= (bytevector-length source)
 222                   (port-position port)))
 223              (begin
 224                (set-port-position! port 10)
 225                (= 10 (port-position port)))
 226              (begin
 227                (put-bytevector port overwrite)
 228                (bytevector-copy! overwrite 0 source 10
 229                                  (bytevector-length overwrite))
 230                (= (port-position port)
 231                   (+ 10 (bytevector-length overwrite))))
 232              (bytevector=? (get-content) source)
 233              (bytevector=? (get-content) (make-bytevector 0)))))))
 234
 235 \f
 236 (with-test-prefix "7.2.7 Input Ports"
 237
 238   ;; This section appears here so that it can use the binary input
 239   ;; primitives.
 240
 241   (pass-if "open-bytevector-input-port [1 arg]"
 242     (let* ((str "Hello Port!")
 243            (bv (u8-list->bytevector (map char->integer
 244                                          (string->list str))))
 245            (port (open-bytevector-input-port bv))
 246            (read-to-string
 247             (lambda (port)
 248               (let loop ((chr (read-char port))
 249                          (result '()))
 250                 (if (eof-object? chr)
 251                     (apply string (reverse! result))
 252                     (loop (read-char port)
 253                           (cons chr result)))))))
 254
 255       (equal? (read-to-string port) str)))
 256
 257   (pass-if-exception "bytevector-input-port is read-only"
 258     exception:wrong-type-arg
 259
 260     (let* ((str "Hello Port!")
 261            (bv (u8-list->bytevector (map char->integer
 262                                          (string->list str))))
 263            (port (open-bytevector-input-port bv)))
 264
 265       (write "hello" port)))
 266
 267   (pass-if "bytevector input port supports seeking"
 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
 273       (and (port-has-port-position? port)
 274            (= 0 (port-position port))
 275            (port-has-set-port-position!? port)
 276            (begin
 277              (set-port-position! port 6)
 278              (= 6 (port-position port)))
 279            (bytevector=? (get-bytevector-all port)
 280                          (u8-list->bytevector
 281                           (map char->integer (string->list "Port!")))))))
 282
 283   (pass-if "make-custom-binary-input-port"
 284     (let* ((source (make-bytevector 7777))
 285            (read! (let ((pos 0)
 286                         (len (bytevector-length source)))
 287                     (lambda (bv start count)
 288                       (let ((amount (min count (- len pos))))
 289                         (if (> amount 0)
 290                             (bytevector-copy! source pos
 291                                               bv start amount))
 292                         (set! pos (+ pos amount))
 293                         amount))))
 294            (port (make-custom-binary-input-port "the port" read!)))
 295
 296       (bytevector=? (get-bytevector-all port) source)))
 297
 298   (pass-if "custom binary input port does not support `port-position'"
 299     (let* ((str "Hello Port!")
 300            (source (open-bytevector-input-port
 301                     (u8-list->bytevector
 302                      (map char->integer (string->list str)))))
 303            (read! (lambda (bv start count)
 304                     (let ((r (get-bytevector-n! source bv start count)))
 305                       (if (eof-object? r)
 306                           0
 307                           r))))
 308            (port (make-custom-binary-input-port "the port" read!)))
 309       (not (or (port-has-port-position? port)
 310                (port-has-set-port-position!? port)))))
 311
 312   (pass-if "custom binary input port supports `port-position'"
 313     (let* ((str "Hello Port!")
 314            (source (open-bytevector-input-port
 315                     (u8-list->bytevector
 316                      (map char->integer (string->list str)))))
 317            (read! (lambda (bv start count)
 318                     (let ((r (get-bytevector-n! source bv start count)))
 319                       (if (eof-object? r)
 320                           0
 321                           r))))
 322            (get-pos (lambda ()
 323                       (port-position source)))
 324            (set-pos! (lambda (pos)
 325                        (set-port-position! source pos)))
 326            (port (make-custom-binary-input-port "the port" read!
 327                                                 get-pos set-pos!)))
 328
 329       (and (port-has-port-position? port)
 330            (= 0 (port-position port))
 331            (port-has-set-port-position!? port)
 332            (begin
 333              (set-port-position! port 6)
 334              (= 6 (port-position port)))
 335            (bytevector=? (get-bytevector-all port)
 336                          (u8-list->bytevector
 337                           (map char->integer (string->list "Port!"))))))))
 338
 339
 340 ;;; Local Variables:
 341 ;;; coding: latin-1
 342 ;;; mode: scheme
 343 ;;; End:
 344
 345 ;;; arch-tag: fc4f49fa-18a5-4a0c-bee8-ef7554f9cf1d