1;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*- 2;;;; 3;;;; Copyright (C) 2009-2012, 2013-2015, 2018 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 (test-suite guile-test) 23 #:use-module (srfi srfi-1) 24 #:use-module (srfi srfi-11) 25 #:use-module (ice-9 match) 26 #:use-module ((ice-9 binary-ports) #:select (get-bytevector-some!)) 27 #:use-module (rnrs io ports) 28 #:use-module (rnrs io simple) 29 #:use-module (rnrs exceptions) 30 #:use-module (rnrs bytevectors)) 31 32(define-syntax pass-if-condition 33 (syntax-rules () 34 ((_ name predicate body0 body ...) 35 (let ((cookie (list 'cookie))) 36 (pass-if name 37 (eq? cookie (guard (c ((predicate c) cookie)) 38 body0 body ...))))))) 39 40(define (test-file) 41 (data-file-name "ports-test.tmp")) 42 43;; A input/output port that swallows all output, and produces just 44;; spaces on input. Reading and writing beyond `failure-position' 45;; produces `system-error' exceptions. Used for testing exception 46;; behavior. 47(define* (make-failing-port #:optional (failure-position 0)) 48 (define (maybe-fail index errno) 49 (if (> index failure-position) 50 (scm-error 'system-error 51 'failing-port 52 "I/O beyond failure position" '() 53 (list errno)))) 54 (let ((read-index 0) 55 (write-index 0)) 56 (define (write-char chr) 57 (set! write-index (+ 1 write-index)) 58 (maybe-fail write-index ENOSPC)) 59 (make-soft-port 60 (vector write-char 61 (lambda (str) ;; write-string 62 (for-each write-char (string->list str))) 63 (lambda () #t) ;; flush-output 64 (lambda () ;; read-char 65 (set! read-index (+ read-index 1)) 66 (maybe-fail read-index EIO) 67 #\space) 68 (lambda () #t)) ;; close-port 69 "rw"))) 70 71(define (call-with-bytevector-output-port/transcoded transcoder receiver) 72 (call-with-bytevector-output-port 73 (lambda (bv-port) 74 (call-with-port (transcoded-port bv-port transcoder) 75 receiver)))) 76 77 78(with-test-prefix "8.2.5 End-of-File Object" 79 80 (pass-if "eof-object" 81 (and (eqv? (eof-object) (eof-object)) 82 (eq? (eof-object) (eof-object)))) 83 84 (pass-if "port-eof?" 85 (port-eof? (open-input-string "")))) 86 87 88(with-test-prefix "8.2.8 Binary Input" 89 90 (pass-if "get-u8" 91 (let ((port (open-input-string "A"))) 92 (and (= (char->integer #\A) (get-u8 port)) 93 (eof-object? (get-u8 port))))) 94 95 (pass-if "lookahead-u8" 96 (let ((port (open-input-string "A"))) 97 (and (= (char->integer #\A) (lookahead-u8 port)) 98 (= (char->integer #\A) (lookahead-u8 port)) 99 (= (char->integer #\A) (get-u8 port)) 100 (eof-object? (get-u8 port))))) 101 102 (pass-if "lookahead-u8 non-ASCII" 103 (let ((port (open-input-string "λ"))) 104 (and (= 206 (lookahead-u8 port)) 105 (= 206 (lookahead-u8 port)) 106 (= 206 (get-u8 port)) 107 (= 187 (lookahead-u8 port)) 108 (= 187 (lookahead-u8 port)) 109 (= 187 (get-u8 port)) 110 (eof-object? (lookahead-u8 port)) 111 (eof-object? (get-u8 port))))) 112 113 (pass-if "lookahead-u8: result is unsigned" 114 ;; Bug #31081. 115 (let ((port (open-bytevector-input-port #vu8(255)))) 116 (= (lookahead-u8 port) 255))) 117 118 (pass-if "get-bytevector-n [short]" 119 (let* ((port (open-input-string "GNU Guile")) 120 (bv (get-bytevector-n port 4))) 121 (and (bytevector? bv) 122 (equal? (bytevector->u8-list bv) 123 (map char->integer (string->list "GNU ")))))) 124 125 (pass-if "get-bytevector-n [long]" 126 (let* ((port (open-input-string "GNU Guile")) 127 (bv (get-bytevector-n port 256))) 128 (and (bytevector? bv) 129 (equal? (bytevector->u8-list bv) 130 (map char->integer (string->list "GNU Guile")))))) 131 132 (pass-if-exception "get-bytevector-n with closed port" 133 exception:wrong-type-arg 134 135 (let ((port (%make-void-port "r"))) 136 137 (close-port port) 138 (get-bytevector-n port 3))) 139 140 (let ((expected (make-bytevector 20 (char->integer #\a)))) 141 (pass-if-equal "http://bugs.gnu.org/17466" 142 ;; <http://bugs.gnu.org/17466> is about a memory corruption 143 ;; whereas bytevector shrunk in 'get-bytevector-n' would keep 144 ;; referring to the previous (larger) bytevector. 145 expected 146 (let loop ((count 50)) 147 (if (zero? count) 148 expected 149 (let ((bv (call-with-input-string "aaaaaaaaaaaaaaaaaaaa" 150 (lambda (port) 151 (get-bytevector-n port 4096))))) 152 ;; Cause the 4 KiB bytevector initially created by 153 ;; 'get-bytevector-n' to be reclaimed. 154 (make-bytevector 4096) 155 156 (if (equal? bv expected) 157 (loop (- count 1)) 158 bv)))))) 159 160 (pass-if "get-bytevector-n! [short]" 161 (let* ((port (open-input-string "GNU Guile")) 162 (bv (make-bytevector 4)) 163 (read (get-bytevector-n! port bv 0 4))) 164 (and (equal? read 4) 165 (equal? (bytevector->u8-list bv) 166 (map char->integer (string->list "GNU ")))))) 167 168 (pass-if "get-bytevector-n! [long]" 169 (let* ((str "GNU Guile") 170 (port (open-input-string str)) 171 (bv (make-bytevector 256)) 172 (read (get-bytevector-n! port bv 0 256))) 173 (and (equal? read (string-length str)) 174 (equal? (map (lambda (i) 175 (bytevector-u8-ref bv i)) 176 (iota read)) 177 (map char->integer (string->list str)))))) 178 179 (pass-if "get-bytevector-some [simple]" 180 (let* ((str "GNU Guile") 181 (port (open-input-string str)) 182 (bv (get-bytevector-some port))) 183 (and (bytevector? bv) 184 (equal? (bytevector->u8-list bv) 185 (map char->integer (string->list str)))))) 186 187 (pass-if "get-bytevector-some! [short]" 188 (let* ((port (open-input-string "GNU Guile")) 189 (bv (make-bytevector 4)) 190 (read (get-bytevector-some! port bv 0 4))) 191 (and (equal? read 4) 192 (equal? (bytevector->u8-list bv) 193 (map char->integer (string->list "GNU ")))))) 194 195 (pass-if "get-bytevector-some! [long]" 196 (let* ((str "GNU Guile") 197 (port (open-input-string str)) 198 (bv (make-bytevector 256)) 199 (read (get-bytevector-some! port bv 0 256))) 200 (and (equal? read (string-length str)) 201 (equal? (map (lambda (i) 202 (bytevector-u8-ref bv i)) 203 (iota read)) 204 (map char->integer (string->list str)))))) 205 206 (pass-if "get-bytevector-all" 207 (let* ((str "GNU Guile") 208 (index 0) 209 (port (make-soft-port 210 (vector #f #f #f 211 (lambda () 212 (if (>= index (string-length str)) 213 (eof-object) 214 (let ((c (string-ref str index))) 215 (set! index (+ index 1)) 216 c))) 217 (lambda () #t) 218 (let ((cont? #f)) 219 (lambda () 220 ;; Number of readily available octets: falls to 221 ;; zero after 4 octets have been read and then 222 ;; starts again. 223 (let ((a (if cont? 224 (- (string-length str) index) 225 (- 4 (modulo index 5))))) 226 (if (= 0 a) (set! cont? #t)) 227 a)))) 228 "r")) 229 (bv (get-bytevector-all port))) 230 (and (bytevector? bv) 231 (= index (string-length str)) 232 (= (bytevector-length bv) (string-length str)) 233 (equal? (bytevector->u8-list bv) 234 (map char->integer (string->list str))))))) 235 236 237(define (make-soft-output-port) 238 (let* ((bv (make-bytevector 1024)) 239 (read-index 0) 240 (write-index 0) 241 (write-char (lambda (chr) 242 (bytevector-u8-set! bv write-index 243 (char->integer chr)) 244 (set! write-index (+ 1 write-index))))) 245 (make-soft-port 246 (vector write-char 247 (lambda (str) ;; write-string 248 (for-each write-char (string->list str))) 249 (lambda () #t) ;; flush-output 250 (lambda () ;; read-char 251 (if (>= read-index (bytevector-length bv)) 252 (eof-object) 253 (let ((c (bytevector-u8-ref bv read-index))) 254 (set! read-index (+ read-index 1)) 255 (integer->char c)))) 256 (lambda () #t)) ;; close-port 257 "rw"))) 258 259(with-test-prefix "8.2.11 Binary Output" 260 261 (pass-if "put-u8" 262 (let ((port (make-soft-output-port))) 263 (put-u8 port 77) 264 (equal? (get-u8 port) 77))) 265 266 ;; Note: The `put-bytevector' tests below temporarily set the default 267 ;; port encoding to ISO-8859-1 so that the soft-port will let all the 268 ;; bytes through, unmodified. This is hacky, but we can't use "custom 269 ;; binary output ports" here because they're only tested later. 270 271 (pass-if "put-bytevector [2 args]" 272 (with-fluids ((%default-port-encoding "ISO-8859-1")) 273 (let ((port (make-soft-output-port)) 274 (bv (make-bytevector 256))) 275 (put-bytevector port bv) 276 (equal? (bytevector->u8-list bv) 277 (bytevector->u8-list 278 (get-bytevector-n port (bytevector-length bv))))))) 279 280 (pass-if "put-bytevector [3 args]" 281 (with-fluids ((%default-port-encoding "ISO-8859-1")) 282 (let ((port (make-soft-output-port)) 283 (bv (make-bytevector 256)) 284 (start 10)) 285 (put-bytevector port bv start) 286 (equal? (drop (bytevector->u8-list bv) start) 287 (bytevector->u8-list 288 (get-bytevector-n port (- (bytevector-length bv) start))))))) 289 290 (pass-if "put-bytevector [4 args]" 291 (with-fluids ((%default-port-encoding "ISO-8859-1")) 292 (let ((port (make-soft-output-port)) 293 (bv (make-bytevector 256)) 294 (start 10) 295 (count 77)) 296 (put-bytevector port bv start count) 297 (equal? (take (drop (bytevector->u8-list bv) start) count) 298 (bytevector->u8-list 299 (get-bytevector-n port count)))))) 300 301 (pass-if-exception "put-bytevector with closed port" 302 exception:wrong-type-arg 303 304 (let* ((bv (make-bytevector 4)) 305 (port (%make-void-port "w"))) 306 307 (close-port port) 308 (put-bytevector port bv))) 309 310 (pass-if "put-bytevector with UTF-16 string port" 311 (let* ((str "hello, world") 312 (bv (string->utf16 str))) 313 (equal? str 314 (call-with-output-string 315 (lambda (port) 316 (set-port-encoding! port "UTF-16BE") 317 (put-bytevector port bv)))))) 318 319 (pass-if "put-bytevector with wrong-encoding string port" 320 (let* ((str "hello, world") 321 (bv (string->utf16 str))) 322 (catch 'decoding-error 323 (lambda () 324 (with-fluids ((%default-port-conversion-strategy 'error)) 325 (call-with-output-string 326 (lambda (port) 327 (set-port-encoding! port "UTF-32") 328 (put-bytevector port bv))) 329 #f)) ; fail if we reach this point 330 (lambda (key subr message errno port) 331 (string? (strerror errno))))))) 332 333 334(define (test-input-file-opener open filename) 335 (let ((contents (string->utf8 "GNU λ"))) 336 ;; Create file 337 (call-with-output-file filename 338 (lambda (port) (put-bytevector port contents))) 339 340 (pass-if "opens binary input port with correct contents" 341 (with-fluids ((%default-port-encoding "UTF-8")) 342 (call-with-port (open-file-input-port filename) 343 (lambda (port) 344 (and (binary-port? port) 345 (input-port? port) 346 (bytevector=? contents (get-bytevector-all port)))))))) 347 348 (delete-file filename)) 349 350(with-test-prefix "8.2.7 Input Ports" 351 352 (with-test-prefix "open-file-input-port" 353 (test-input-file-opener open-file-input-port (test-file))) 354 355 ;; This section appears here so that it can use the binary input 356 ;; primitives. 357 358 (pass-if "open-bytevector-input-port [1 arg]" 359 (let* ((str "Hello Port!") 360 (bv (u8-list->bytevector (map char->integer 361 (string->list str)))) 362 (port (open-bytevector-input-port bv)) 363 (read-to-string 364 (lambda (port) 365 (let loop ((chr (read-char port)) 366 (result '())) 367 (if (eof-object? chr) 368 (apply string (reverse! result)) 369 (loop (read-char port) 370 (cons chr result))))))) 371 372 (equal? (read-to-string port) str))) 373 374 (pass-if "bytevector-input-port is binary" 375 (with-fluids ((%default-port-encoding "UTF-8")) 376 (binary-port? (open-bytevector-input-port #vu8(1 2 3))))) 377 378 (pass-if-equal "bytevector-input-port uses ISO-8859-1 (Guile extension)" 379 "©©" 380 (with-fluids ((%default-port-encoding "UTF-8")) 381 (get-string-all (open-bytevector-input-port #vu8(194 169 194 169))))) 382 383 (pass-if-exception "bytevector-input-port is read-only" 384 exception:wrong-type-arg 385 386 (let* ((str "Hello Port!") 387 (bv (u8-list->bytevector (map char->integer 388 (string->list str)))) 389 (port (open-bytevector-input-port bv #f))) 390 391 (write "hello" port))) 392 393 (pass-if "bytevector input port supports seeking" 394 (let* ((str "Hello Port!") 395 (bv (u8-list->bytevector (map char->integer 396 (string->list str)))) 397 (port (open-bytevector-input-port bv #f))) 398 399 (and (port-has-port-position? port) 400 (= 0 (port-position port)) 401 (port-has-set-port-position!? port) 402 (begin 403 (set-port-position! port 6) 404 (= 6 (port-position port))) 405 (bytevector=? (get-bytevector-all port) 406 (u8-list->bytevector 407 (map char->integer (string->list "Port!"))))))) 408 409 (pass-if "bytevector input port can seek to very end" 410 (let ((empty (open-bytevector-input-port '#vu8())) 411 (not-empty (open-bytevector-input-port '#vu8(1 2 3)))) 412 (and (begin (set-port-position! empty (port-position empty)) 413 (= 0 (port-position empty))) 414 (begin (get-bytevector-n not-empty 3) 415 (set-port-position! not-empty (port-position not-empty)) 416 (= 3 (port-position not-empty)))))) 417 418 (pass-if-exception "make-custom-binary-input-port [wrong-num-args]" 419 exception:wrong-num-args 420 421 ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully 422 ;; optional. 423 (make-custom-binary-input-port "port" (lambda args #t))) 424 425 (pass-if "make-custom-binary-input-port" 426 (let* ((source (make-bytevector 7777)) 427 (read! (let ((pos 0) 428 (len (bytevector-length source))) 429 (lambda (bv start count) 430 (let ((amount (min count (- len pos)))) 431 (if (> amount 0) 432 (bytevector-copy! source pos 433 bv start amount)) 434 (set! pos (+ pos amount)) 435 amount)))) 436 (port (make-custom-binary-input-port "the port" read! 437 #f #f #f))) 438 439 (and (binary-port? port) 440 (input-port? port) 441 (bytevector=? (get-bytevector-all port) source)))) 442 443 (pass-if-equal "make-custom-binary-input-port uses ISO-8859-1 (Guile extension)" 444 "©©" 445 (with-fluids ((%default-port-encoding "UTF-8")) 446 (let* ((source #vu8(194 169 194 169)) 447 (read! (let ((pos 0) 448 (len (bytevector-length source))) 449 (lambda (bv start count) 450 (let ((amount (min count (- len pos)))) 451 (if (> amount 0) 452 (bytevector-copy! source pos 453 bv start amount)) 454 (set! pos (+ pos amount)) 455 amount)))) 456 (port (make-custom-binary-input-port "the port" read! 457 #f #f #f))) 458 (get-string-all port)))) 459 460 (pass-if "custom binary input port does not support `port-position'" 461 (let* ((str "Hello Port!") 462 (source (open-bytevector-input-port 463 (u8-list->bytevector 464 (map char->integer (string->list str))))) 465 (read! (lambda (bv start count) 466 (let ((r (get-bytevector-n! source bv start count))) 467 (if (eof-object? r) 468 0 469 r)))) 470 (port (make-custom-binary-input-port "the port" read! 471 #f #f #f))) 472 (not (or (port-has-port-position? port) 473 (port-has-set-port-position!? port))))) 474 475 (pass-if-exception "custom binary input port 'read!' returns too much" 476 exception:out-of-range 477 ;; In Guile <= 2.0.9 this would segfault. 478 (let* ((read! (lambda (bv start count) 479 (+ count 4242))) 480 (port (make-custom-binary-input-port "the port" read! 481 #f #f #f))) 482 (get-bytevector-all port))) 483 484 (pass-if-equal "custom binary input port supports `port-position', \ 485not `set-port-position!'" 486 42 487 (let ((port (make-custom-binary-input-port "the port" (const 0) 488 (const 42) #f #f))) 489 (and (port-has-port-position? port) 490 (not (port-has-set-port-position!? port)) 491 (port-position port)))) 492 493 (pass-if "custom binary input port supports `port-position'" 494 (let* ((str "Hello Port!") 495 (source (open-bytevector-input-port 496 (u8-list->bytevector 497 (map char->integer (string->list str))))) 498 (read! (lambda (bv start count) 499 (let ((r (get-bytevector-n! source bv start count))) 500 (if (eof-object? r) 501 0 502 r)))) 503 (get-pos (lambda () 504 (port-position source))) 505 (set-pos! (lambda (pos) 506 (set-port-position! source pos))) 507 (port (make-custom-binary-input-port "the port" read! 508 get-pos set-pos! #f))) 509 510 (and (port-has-port-position? port) 511 (= 0 (port-position port)) 512 (port-has-set-port-position!? port) 513 (begin 514 (set-port-position! port 6) 515 (= 6 (port-position port))) 516 (bytevector=? (get-bytevector-all port) 517 (u8-list->bytevector 518 (map char->integer (string->list "Port!"))))))) 519 520 (pass-if-equal "custom binary input port position, long offset" 521 (expt 2 42) 522 ;; In Guile <= 2.2.4, 'seek' would throw to 'out-of-range'. 523 (let* ((port (make-custom-binary-input-port "the port" 524 (const 0) 525 (const (expt 2 42)) 526 #f #f))) 527 (port-position port))) 528 529 530 (pass-if-equal "custom binary input port buffered partial reads" 531 "Hello Port!" 532 ;; Check what happens when READ! returns less than COUNT bytes. 533 (let* ((src (string->utf8 "Hello Port!")) 534 (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc. 535 (offset 0) 536 (read! (lambda (bv start count) 537 (match chunks 538 ((count rest ...) 539 (bytevector-copy! src offset bv start count) 540 (set! chunks rest) 541 (set! offset (+ offset count)) 542 count) 543 (() 544 0)))) 545 (port (make-custom-binary-input-port "the port" 546 read! #f #f #f))) 547 (get-string-all port))) 548 549 (pass-if-equal "custom binary input port unbuffered & 'port-position'" 550 '(0 2 5 11) 551 ;; Check that the value returned by 'port-position' is correct, and 552 ;; that each 'port-position' call leads one call to the 553 ;; 'get-position' method. 554 (let* ((str "Hello Port!") 555 (output (make-bytevector (string-length str))) 556 (source (with-fluids ((%default-port-encoding "UTF-8")) 557 (open-string-input-port str))) 558 (read! (lambda (bv start count) 559 (let ((r (get-bytevector-n! source bv start count))) 560 (if (eof-object? r) 561 0 562 r)))) 563 (pos '()) 564 (get-pos (lambda () 565 (let ((p (port-position source))) 566 (set! pos (cons p pos)) 567 p))) 568 (port (make-custom-binary-input-port "the port" read! 569 get-pos #f #f))) 570 (setvbuf port 'none) 571 (and (= 0 (port-position port)) 572 (begin 573 (get-bytevector-n! port output 0 2) 574 (= 2 (port-position port))) 575 (begin 576 (get-bytevector-n! port output 2 3) 577 (= 5 (port-position port))) 578 (let ((bv (string->utf8 (get-string-all port)))) 579 (bytevector-copy! bv 0 output 5 (bytevector-length bv)) 580 (= (string-length str) (port-position port))) 581 (bytevector=? output (string->utf8 str)) 582 (reverse pos)))) 583 584 (pass-if-equal "custom binary input port unbuffered & 'read!' calls" 585 `((2 "He") (3 "llo") (42 " Port!")) 586 (let* ((str "Hello Port!") 587 (source (with-fluids ((%default-port-encoding "UTF-8")) 588 (open-string-input-port str))) 589 (reads '()) 590 (read! (lambda (bv start count) 591 (set! reads (cons count reads)) 592 (let ((r (get-bytevector-n! source bv start count))) 593 (if (eof-object? r) 594 0 595 r)))) 596 (port (make-custom-binary-input-port "the port" read! 597 #f #f #f))) 598 599 (setvbuf port 'none) 600 (let ((ret (list (get-bytevector-n port 2) 601 (get-bytevector-n port 3) 602 (get-bytevector-n port 42)))) 603 (zip (reverse reads) 604 (map (lambda (obj) 605 (if (bytevector? obj) 606 (utf8->string obj) 607 obj)) 608 ret))))) 609 610 (pass-if-equal "custom binary input port unbuffered & 'get-string-all'" 611 (make-string 1000 #\a) 612 ;; In Guile 2.0.11 this test would lead to a buffer overrun followed 613 ;; by an assertion failure. See <http://bugs.gnu.org/19621>. 614 (let* ((input (with-fluids ((%default-port-encoding #f)) 615 (open-input-string (make-string 1000 #\a)))) 616 (read! (lambda (bv index count) 617 (let ((n (get-bytevector-n! input bv index 618 count))) 619 (if (eof-object? n) 0 n)))) 620 (port (make-custom-binary-input-port "foo" read! 621 #f #f #f))) 622 (setvbuf port 'none) 623 (get-string-all port))) 624 625 (pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'" 626 (make-string 1000 #\λ) 627 ;; In Guile 2.0.11 this test would lead to a buffer overrun followed 628 ;; by an assertion failure. See <http://bugs.gnu.org/19621>. 629 (let* ((input (with-fluids ((%default-port-encoding "UTF-8")) 630 (open-input-string (make-string 1000 #\λ)))) 631 (read! (lambda (bv index count) 632 (let ((n (get-bytevector-n! input bv index 633 count))) 634 (if (eof-object? n) 0 n)))) 635 (port (make-custom-binary-input-port "foo" read! 636 #f #f #f))) 637 (setvbuf port 'none) 638 (set-port-encoding! port "UTF-8") 639 (get-string-all port))) 640 641 (pass-if-equal "custom binary input port, unbuffered then buffered" 642 `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…") 643 (777 ,(eof-object))) 644 (let* ((str "Lorem ipsum dolor sit amet, consectetur…") 645 (source (with-fluids ((%default-port-encoding "UTF-8")) 646 (open-string-input-port str))) 647 (reads '()) 648 (read! (lambda (bv start count) 649 (set! reads (cons count reads)) 650 (let ((r (get-bytevector-n! source bv start count))) 651 (if (eof-object? r) 652 0 653 r)))) 654 (port (make-custom-binary-input-port "the port" read! 655 #f #f #f))) 656 657 (setvbuf port 'none) 658 (let ((ret (list (get-bytevector-n port 6) 659 (get-bytevector-n port 12) 660 (begin 661 (setvbuf port 'block 777) 662 (get-bytevector-n port 42)) 663 (get-bytevector-n port 42)))) 664 (zip (reverse reads) 665 (map (lambda (obj) 666 (if (bytevector? obj) 667 (utf8->string obj) 668 obj)) 669 ret))))) 670 671 (pass-if-equal "custom binary input port, buffered then unbuffered" 672 `((18 673 42 14 ; scm_c_read tries to fill the 42-byte buffer 674 42) 675 ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object))) 676 (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…") 677 (source (with-fluids ((%default-port-encoding "UTF-8")) 678 (open-string-input-port str))) 679 (reads '()) 680 (read! (lambda (bv start count) 681 (set! reads (cons count reads)) 682 (let ((r (get-bytevector-n! source bv start count))) 683 (if (eof-object? r) 684 0 685 r)))) 686 (port (make-custom-binary-input-port "the port" read! 687 #f #f #f))) 688 689 (setvbuf port 'block 18) 690 (let ((ret (list (get-bytevector-n port 6) 691 (get-bytevector-n port 12) 692 (begin 693 (setvbuf port 'none) 694 (get-bytevector-n port 42)) 695 (get-bytevector-n port 42)))) 696 (list (reverse reads) 697 (map (lambda (obj) 698 (if (bytevector? obj) 699 (utf8->string obj) 700 obj)) 701 ret))))) 702 703 (pass-if "custom binary input port `close-proc' is called" 704 (let* ((closed? #f) 705 (read! (lambda (bv start count) 0)) 706 (get-pos (lambda () 0)) 707 (set-pos! (lambda (pos) #f)) 708 (close! (lambda () (set! closed? #t))) 709 (port (make-custom-binary-input-port "the port" read! 710 get-pos set-pos! 711 close!))) 712 713 (close-port port) 714 (gc) ; Test for marking a closed port. 715 closed?)) 716 717 (pass-if "standard-input-port is binary" 718 (with-fluids ((%default-port-encoding "UTF-8")) 719 (binary-port? (standard-input-port))))) 720 721 722(define (test-output-file-opener open filename) 723 (with-fluids ((%default-port-encoding "UTF-8")) 724 (pass-if "opens binary output port" 725 (call-with-port (open filename) 726 (lambda (port) 727 (put-bytevector port '#vu8(1 2 3)) 728 (and (binary-port? port) 729 (output-port? port)))))) 730 731 (pass-if-condition "exception: already-exists" 732 i/o-file-already-exists-error? 733 (open filename)) 734 735 (pass-if "no-fail no-truncate" 736 (and 737 (call-with-port (open filename (file-options no-fail no-truncate)) 738 (lambda (port) 739 (= 0 (port-position port)))) 740 (= 3 (stat:size (stat filename))))) 741 742 (pass-if "no-fail" 743 (and 744 (call-with-port (open filename (file-options no-fail)) 745 binary-port?) 746 (= 0 (stat:size (stat filename))))) 747 748 (pass-if "buffer-mode none" 749 (call-with-port (open filename (file-options no-fail) 750 (buffer-mode none)) 751 (lambda (port) 752 (eq? (output-port-buffer-mode port) 'none)))) 753 754 (pass-if "buffer-mode line" 755 (call-with-port (open filename (file-options no-fail) 756 (buffer-mode line)) 757 (lambda (port) 758 (eq? (output-port-buffer-mode port) 'line)))) 759 760 (pass-if "buffer-mode block" 761 (call-with-port (open filename (file-options no-fail) 762 (buffer-mode block)) 763 (lambda (port) 764 (eq? (output-port-buffer-mode port) 'block)))) 765 766 (delete-file filename) 767 768 (pass-if-condition "exception: does-not-exist" 769 i/o-file-does-not-exist-error? 770 (open filename (file-options no-create)))) 771 772(with-test-prefix "8.2.10 Output ports" 773 774 (with-test-prefix "open-file-output-port" 775 (test-output-file-opener open-file-output-port (test-file))) 776 777 (pass-if "open-string-output-port" 778 (call-with-values open-string-output-port 779 (lambda (port proc) 780 (and (port? port) (thunk? proc))))) 781 782 (pass-if-equal "calling string output port truncates port" 783 '("hello" "" "world") 784 (call-with-values open-string-output-port 785 (lambda (port proc) 786 (display "hello" port) 787 (let* ((s1 (proc)) 788 (s2 (proc))) 789 (display "world" port) 790 (list s1 s2 (proc)))))) 791 792 (pass-if "open-bytevector-output-port" 793 (let-values (((port get-content) 794 (open-bytevector-output-port #f))) 795 (let ((source (make-bytevector 7777))) 796 (put-bytevector port source) 797 (and (bytevector=? (get-content) source) 798 (bytevector=? (get-content) (make-bytevector 0)))))) 799 800 (pass-if "bytevector-output-port is binary" 801 (binary-port? (open-bytevector-output-port))) 802 803 (pass-if-equal "bytevector-output-port uses ISO-8859-1 (Guile extension)" 804 #vu8(194 169 194 169) 805 (with-fluids ((%default-port-encoding "UTF-8")) 806 (let-values (((port get-content) 807 (open-bytevector-output-port))) 808 (put-string port "©©") 809 (get-content)))) 810 811 (pass-if "open-bytevector-output-port [extract after close]" 812 (let-values (((port get-content) 813 (open-bytevector-output-port))) 814 (let ((source (make-bytevector 12345 #xFE))) 815 (put-bytevector port source) 816 (close-port port) 817 (bytevector=? (get-content) source)))) 818 819 (pass-if "open-bytevector-output-port [put-u8]" 820 (let-values (((port get-content) 821 (open-bytevector-output-port))) 822 (put-u8 port 77) 823 (and (bytevector=? (get-content) (make-bytevector 1 77)) 824 (bytevector=? (get-content) (make-bytevector 0))))) 825 826 (pass-if "open-bytevector-output-port [display]" 827 (let-values (((port get-content) 828 (open-bytevector-output-port))) 829 (display "hello" port) 830 (and (bytevector=? (get-content) (string->utf8 "hello")) 831 (bytevector=? (get-content) (make-bytevector 0))))) 832 833 (pass-if "bytevector output port supports `port-position'" 834 (let-values (((port get-content) 835 (open-bytevector-output-port))) 836 (let ((source (make-bytevector 7777)) 837 (overwrite (make-bytevector 33))) 838 (and (port-has-port-position? port) 839 (port-has-set-port-position!? port) 840 (begin 841 (put-bytevector port source) 842 (= (bytevector-length source) 843 (port-position port))) 844 (begin 845 (set-port-position! port 10) 846 (= 10 (port-position port))) 847 (begin 848 (put-bytevector port overwrite) 849 (bytevector-copy! overwrite 0 source 10 850 (bytevector-length overwrite)) 851 (= (port-position port) 852 (+ 10 (bytevector-length overwrite)))) 853 (bytevector=? (get-content) source) 854 (bytevector=? (get-content) (make-bytevector 0)))))) 855 856 (pass-if "make-custom-binary-output-port" 857 (let ((port (make-custom-binary-output-port "cbop" 858 (lambda (x y z) 0) 859 #f #f #f))) 860 (and (output-port? port) 861 (binary-port? port) 862 (not (port-has-port-position? port)) 863 (not (port-has-set-port-position!? port))))) 864 865 (pass-if "make-custom-binary-output-port [partial writes]" 866 (let* ((source (uint-list->bytevector (iota 333) 867 (native-endianness) 2)) 868 (sink (make-bytevector (bytevector-length source))) 869 (sink-pos 0) 870 (eof? #f) 871 (write! (lambda (bv start count) 872 (if (= 0 count) 873 (begin 874 (set! eof? #t) 875 0) 876 (let ((u8 (bytevector-u8-ref bv start))) 877 ;; Get one byte at a time. 878 (bytevector-u8-set! sink sink-pos u8) 879 (set! sink-pos (+ 1 sink-pos)) 880 1)))) 881 (port (make-custom-binary-output-port "cbop" write! 882 #f #f #f))) 883 (put-bytevector port source) 884 (force-output port) 885 (and (= sink-pos (bytevector-length source)) 886 (not eof?) 887 (bytevector=? sink source)))) 888 889 (pass-if "make-custom-binary-output-port [full writes]" 890 (let* ((source (uint-list->bytevector (iota 333) 891 (native-endianness) 2)) 892 (sink (make-bytevector (bytevector-length source))) 893 (sink-pos 0) 894 (eof? #f) 895 (write! (lambda (bv start count) 896 (if (= 0 count) 897 (begin 898 (set! eof? #t) 899 0) 900 (begin 901 (bytevector-copy! bv start 902 sink sink-pos 903 count) 904 (set! sink-pos (+ sink-pos count)) 905 count)))) 906 (port (make-custom-binary-output-port "cbop" write! 907 #f #f #f))) 908 (put-bytevector port source) 909 (force-output port) 910 (and (= sink-pos (bytevector-length source)) 911 (not eof?) 912 (bytevector=? sink source)))) 913 914 (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)" 915 '(194 169 194 169) 916 (with-fluids ((%default-port-encoding "UTF-8")) 917 (let* ((sink '()) 918 (write! (lambda (bv start count) 919 (if (= 0 count) ; EOF 920 0 921 (let ((u8 (bytevector-u8-ref bv start))) 922 ;; Get one byte at a time. 923 (set! sink (cons u8 sink)) 924 1)))) 925 (port (make-custom-binary-output-port "cbop" write! 926 #f #f #f))) 927 (put-string port "©©") 928 (force-output port) 929 (reverse sink)))) 930 931 (pass-if "standard-output-port is binary" 932 (with-fluids ((%default-port-encoding "UTF-8")) 933 (binary-port? (standard-output-port)))) 934 935 (pass-if "standard-error-port is binary" 936 (with-fluids ((%default-port-encoding "UTF-8")) 937 (binary-port? (standard-error-port))))) 938 939 940(with-test-prefix "8.2.6 Input and output ports" 941 942 (define (check-transcoded-port-mode make-port pred) 943 (let ((p (make-port "/dev/null" (file-options no-fail)))) 944 (dynamic-wind 945 (lambda () #t) 946 (lambda () 947 (set! p (transcoded-port p (native-transcoder))) 948 (pred p)) 949 (lambda () (close-port p))))) 950 951 (pass-if "transcoded-port preserves input mode" 952 (check-transcoded-port-mode open-file-input-port 953 (lambda (p) 954 (and (input-port? p) 955 (not (output-port? p)))))) 956 957 (pass-if "transcoded-port preserves output mode" 958 (check-transcoded-port-mode open-file-output-port 959 (lambda (p) 960 (and (not (input-port? p)) 961 (output-port? p))))) 962 963 (pass-if "transcoded-port preserves input/output mode" 964 (check-transcoded-port-mode open-file-input/output-port 965 (lambda (p) 966 (and (input-port? p) (output-port? p))))) 967 968 (pass-if "transcoded-port [output]" 969 (let ((s "Hello\nÄÖÜ")) 970 (bytevector=? 971 (string->utf8 s) 972 (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec)) 973 (lambda (utf8-port) 974 (put-string utf8-port s)))))) 975 976 (pass-if "transcoded-port [input]" 977 (let ((s "Hello\nÄÖÜ")) 978 (string=? 979 s 980 (get-string-all 981 (transcoded-port (open-bytevector-input-port (string->utf8 s)) 982 (make-transcoder (utf-8-codec))))))) 983 984 (pass-if "transcoded-port [input line]" 985 (string=? "ÄÖÜ" 986 (get-line (transcoded-port 987 (open-bytevector-input-port (string->utf8 "ÄÖÜ\nFooBar")) 988 (make-transcoder (utf-8-codec)))))) 989 990 (pass-if "transcoded-port [error handling mode = raise]" 991 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style) 992 (error-handling-mode raise))) 993 (b (open-bytevector-input-port #vu8(255 2 1))) 994 (tp (transcoded-port b t))) 995 (guard (c ((i/o-decoding-error? c) 996 (eq? (i/o-error-port c) tp))) 997 (get-line tp) 998 #f))) ; fail if we reach this point 999 1000 (pass-if "transcoded-port [error handling mode = replace]" 1001 (let* ((t (make-transcoder (utf-8-codec) (native-eol-style) 1002 (error-handling-mode replace))) 1003 (b (open-bytevector-input-port #vu8(255 1 2 3 103 110 117))) 1004 (tp (transcoded-port b t))) 1005 (string-suffix? "gnu" (get-line tp)))) 1006 1007 (pass-if "transcoded-port, output [error handling mode = raise]" 1008 (let-values (((p get) 1009 (open-bytevector-output-port))) 1010 (let* ((t (make-transcoder (latin-1-codec) (native-eol-style) 1011 (error-handling-mode raise))) 1012 (tp (transcoded-port p t))) 1013 (setvbuf tp 'none) 1014 (guard (c ((i/o-encoding-error? c) 1015 (and (eq? (i/o-error-port c) tp) 1016 (char=? (i/o-encoding-error-char c) #\λ) 1017 (bytevector=? (get) (string->utf8 "The letter "))))) 1018 (put-string tp "The letter λ cannot be represented in Latin-1.") 1019 #f)))) 1020 1021 (pass-if "port-transcoder [transcoded port]" 1022 (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo")) 1023 (make-transcoder (utf-8-codec)))) 1024 (t (port-transcoder p))) 1025 (and t 1026 (transcoder-codec t) 1027 (eq? (native-eol-style) 1028 (transcoder-eol-style t)) 1029 (eq? (error-handling-mode replace) 1030 (transcoder-error-handling-mode t)))))) 1031 1032(with-test-prefix "8.2.9 Textual input" 1033 1034 (pass-if "get-string-n [short]" 1035 (let ((port (open-input-string "GNU Guile"))) 1036 (string=? "GNU " (get-string-n port 4)))) 1037 (pass-if "get-string-n [long]" 1038 (let ((port (open-input-string "GNU Guile"))) 1039 (string=? "GNU Guile" (get-string-n port 256)))) 1040 (pass-if "get-string-n [eof]" 1041 (let ((port (open-input-string ""))) 1042 (eof-object? (get-string-n port 4)))) 1043 1044 (pass-if "get-string-n! [short]" 1045 (let ((port (open-input-string "GNU Guile")) 1046 (s (string-copy "Isn't XXX great?"))) 1047 (and (= 3 (get-string-n! port s 6 3)) 1048 (string=? s "Isn't GNU great?")))) 1049 1050 (with-test-prefix "read error" 1051 (pass-if-condition "get-char" i/o-read-error? 1052 (get-char (make-failing-port))) 1053 (pass-if-condition "lookahead-char" i/o-read-error? 1054 (lookahead-char (make-failing-port))) 1055 ;; FIXME: these are not yet exception-correct 1056 #| 1057 (pass-if-condition "get-string-n" i/o-read-error? 1058 (get-string-n (make-failing-port) 5)) 1059 (pass-if-condition "get-string-n!" i/o-read-error? 1060 (get-string-n! (make-failing-port) (make-string 5) 0 5)) 1061 |# 1062 (pass-if-condition "get-string-all" i/o-read-error? 1063 (get-string-all (make-failing-port 100))) 1064 (pass-if-condition "get-line" i/o-read-error? 1065 (get-line (make-failing-port))) 1066 (pass-if-condition "get-datum" i/o-read-error? 1067 (get-datum (make-failing-port))))) 1068 1069(define (encoding-error-predicate char) 1070 (lambda (c) 1071 (and (i/o-encoding-error? c) 1072 (char=? char (i/o-encoding-error-char c))))) 1073 1074(with-test-prefix "8.2.12 Textual Output" 1075 1076 (with-test-prefix "write error" 1077 (pass-if-condition "put-char" i/o-write-error? 1078 (put-char (make-failing-port) #\G)) 1079 (pass-if-condition "put-string" i/o-write-error? 1080 (put-string (make-failing-port) "Hello World!")) 1081 (pass-if-condition "put-datum" i/o-write-error? 1082 (put-datum (make-failing-port) '(hello world!)))) 1083 (with-test-prefix "encoding error" 1084 (pass-if-condition "put-char" (encoding-error-predicate #\λ) 1085 (call-with-bytevector-output-port/transcoded 1086 (make-transcoder (latin-1-codec) 1087 (native-eol-style) 1088 (error-handling-mode raise)) 1089 (lambda (port) 1090 (put-char port #\λ)))) 1091 (pass-if-condition "put-string" (encoding-error-predicate #\λ) 1092 (call-with-bytevector-output-port/transcoded 1093 (make-transcoder (latin-1-codec) 1094 (native-eol-style) 1095 (error-handling-mode raise)) 1096 (lambda (port) 1097 (put-string port "FooλBar")))))) 1098 1099(with-test-prefix "8.3 Simple I/O" 1100 (with-test-prefix "read error" 1101 (pass-if-condition "read-char" i/o-read-error? 1102 (read-char (make-failing-port))) 1103 (pass-if-condition "peek-char" i/o-read-error? 1104 (peek-char (make-failing-port))) 1105 (pass-if-condition "read" i/o-read-error? 1106 (read (make-failing-port)))) 1107 (with-test-prefix "write error" 1108 (pass-if-condition "display" i/o-write-error? 1109 (display "Hi there!" (make-failing-port))) 1110 (pass-if-condition "write" i/o-write-error? 1111 (write '(hi there!) (make-failing-port))) 1112 (pass-if-condition "write-char" i/o-write-error? 1113 (write-char #\G (make-failing-port))) 1114 (pass-if-condition "newline" i/o-write-error? 1115 (newline (make-failing-port)))) 1116 (let ((filename (test-file))) 1117 ;; ensure the test file exists 1118 (call-with-output-file filename 1119 (lambda (port) (write "foo" port))) 1120 (pass-if "call-with-input-file [port is textual]" 1121 (call-with-input-file filename textual-port?)) 1122 (pass-if-condition "call-with-input-file [exception: not-found]" 1123 i/o-file-does-not-exist-error? 1124 (call-with-input-file ",this-is-highly-unlikely-to-exist!" 1125 values)) 1126 (pass-if-condition "call-with-output-file [exception: already-exists]" 1127 i/o-file-already-exists-error? 1128 (call-with-output-file filename 1129 values)) 1130 (delete-file filename))) 1131 1132;; Used for a lot of the make-custom-input/output tests to stub out 1133;; the read/write section for whatever part we're ignoring 1134(define dummy-write! (const 0)) 1135(define dummy-read! (const 0)) 1136 1137(with-test-prefix "8.2.13 Input/output ports" 1138 (with-test-prefix "open-file-input/output-port [output]" 1139 (test-output-file-opener open-file-input/output-port (test-file))) 1140 (with-test-prefix "open-file-input/output-port [input]" 1141 (test-input-file-opener open-file-input/output-port (test-file))) 1142 1143 ;; Custom binary input/output tests. Most of these are simple 1144 ;; ports of the custom-binary-input-port tests or custom-binary-ouput-port 1145 ;; tests, simply ported to use a custom-binary-input/output port. 1146 ;; The copy-pasta is strong here; a diet lighter in spaghetti may wish 1147 ;; to make the previous tests more reusable. 1148 (pass-if "make-custom-binary-input/output-port" 1149 (let* ((source (make-bytevector 7777)) 1150 (read! (let ((pos 0) 1151 (len (bytevector-length source))) 1152 (lambda (bv start count) 1153 (let ((amount (min count (- len pos)))) 1154 (if (> amount 0) 1155 (bytevector-copy! source pos 1156 bv start amount)) 1157 (set! pos (+ pos amount)) 1158 amount)))) 1159 (write! (lambda (x y z) 0)) 1160 (port (make-custom-binary-input/output-port 1161 "the port" read! write! 1162 #f #f #f))) 1163 (and (binary-port? port) 1164 (input-port? port) 1165 (output-port? port) 1166 (bytevector=? (get-bytevector-all port) source) 1167 (not (port-has-port-position? port)) 1168 (not (port-has-set-port-position!? port))))) 1169 1170 (pass-if-equal "make-custom-binary-input/output-port uses ISO-8859-1 (Guile \ 1171extension) [input]" 1172 "©©" 1173 (with-fluids ((%default-port-encoding "UTF-8")) 1174 (let* ((source #vu8(194 169 194 169)) 1175 (read! (let ((pos 0) 1176 (len (bytevector-length source))) 1177 (lambda (bv start count) 1178 (let ((amount (min count (- len pos)))) 1179 (if (> amount 0) 1180 (bytevector-copy! source pos 1181 bv start amount)) 1182 (set! pos (+ pos amount)) 1183 amount)))) 1184 (port (make-custom-binary-input/output-port 1185 "the port" read! dummy-write! 1186 #f #f #f))) 1187 (get-string-all port)))) 1188 1189 (pass-if "custom binary input/output port does not support `port-position'" 1190 (let* ((str "Hello Port!") 1191 (source (open-bytevector-input-port 1192 (u8-list->bytevector 1193 (map char->integer (string->list str))))) 1194 (read! (lambda (bv start count) 1195 (let ((r (get-bytevector-n! source bv start count))) 1196 (if (eof-object? r) 1197 0 1198 r)))) 1199 (port (make-custom-binary-input/output-port 1200 "the port" read! dummy-write! 1201 #f #f #f))) 1202 (not (or (port-has-port-position? port) 1203 (port-has-set-port-position!? port))))) 1204 1205 (pass-if-exception "custom binary input/output port 'read!' returns too much" 1206 exception:out-of-range 1207 ;; In Guile <= 2.0.9 this would segfault. 1208 (let* ((read! (lambda (bv start count) 1209 (+ count 4242))) 1210 (port (make-custom-binary-input/output-port 1211 "the port" read! dummy-write! 1212 #f #f #f))) 1213 (get-bytevector-all port))) 1214 1215 (pass-if-equal "custom binary input/output port supports `port-position', \ 1216not `set-port-position!'" 1217 42 1218 (let ((port (make-custom-binary-input/output-port 1219 "the port" (const 0) dummy-write! 1220 (const 42) #f #f))) 1221 (and (port-has-port-position? port) 1222 (not (port-has-set-port-position!? port)) 1223 (port-position port)))) 1224 1225 (pass-if "custom binary input/output port supports `port-position'" 1226 (let* ((str "Hello Port!") 1227 (source (open-bytevector-input-port 1228 (u8-list->bytevector 1229 (map char->integer (string->list str))))) 1230 (read! (lambda (bv start count) 1231 (let ((r (get-bytevector-n! source bv start count))) 1232 (if (eof-object? r) 1233 0 1234 r)))) 1235 (get-pos (lambda () 1236 (port-position source))) 1237 (set-pos! (lambda (pos) 1238 (set-port-position! source pos))) 1239 (port (make-custom-binary-input/output-port 1240 "the port" read! dummy-write! 1241 get-pos set-pos! #f))) 1242 1243 (and (port-has-port-position? port) 1244 (= 0 (port-position port)) 1245 (port-has-set-port-position!? port) 1246 (begin 1247 (set-port-position! port 6) 1248 (= 6 (port-position port))) 1249 (bytevector=? (get-bytevector-all port) 1250 (u8-list->bytevector 1251 (map char->integer (string->list "Port!"))))))) 1252 1253 (pass-if-equal "custom binary input/output port buffered partial reads" 1254 "Hello Port!" 1255 ;; Check what happens when READ! returns less than COUNT bytes. 1256 (let* ((src (string->utf8 "Hello Port!")) 1257 (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc. 1258 (offset 0) 1259 (read! (lambda (bv start count) 1260 (match chunks 1261 ((count rest ...) 1262 (bytevector-copy! src offset bv start count) 1263 (set! chunks rest) 1264 (set! offset (+ offset count)) 1265 count) 1266 (() 1267 0)))) 1268 (port (make-custom-binary-input/output-port 1269 "the port" read! dummy-write! 1270 #f #f #f))) 1271 (get-string-all port))) 1272 1273 (pass-if-equal "custom binary input/output port unbuffered & 'port-position'" 1274 '(0 2 5 11) 1275 ;; Check that the value returned by 'port-position' is correct, and 1276 ;; that each 'port-position' call leads one call to the 1277 ;; 'get-position' method. 1278 (let* ((str "Hello Port!") 1279 (output (make-bytevector (string-length str))) 1280 (source (with-fluids ((%default-port-encoding "UTF-8")) 1281 (open-string-input-port str))) 1282 (read! (lambda (bv start count) 1283 (let ((r (get-bytevector-n! source bv start count))) 1284 (if (eof-object? r) 1285 0 1286 r)))) 1287 (pos '()) 1288 (get-pos (lambda () 1289 (let ((p (port-position source))) 1290 (set! pos (cons p pos)) 1291 p))) 1292 (port (make-custom-binary-input/output-port 1293 "the port" read! dummy-write! 1294 get-pos #f #f))) 1295 (setvbuf port 'none) 1296 (and (= 0 (port-position port)) 1297 (begin 1298 (get-bytevector-n! port output 0 2) 1299 (= 2 (port-position port))) 1300 (begin 1301 (get-bytevector-n! port output 2 3) 1302 (= 5 (port-position port))) 1303 (let ((bv (string->utf8 (get-string-all port)))) 1304 (bytevector-copy! bv 0 output 5 (bytevector-length bv)) 1305 (= (string-length str) (port-position port))) 1306 (bytevector=? output (string->utf8 str)) 1307 (reverse pos)))) 1308 1309 (pass-if-equal "custom binary input/output port unbuffered & 'read!' calls" 1310 `((2 "He") (3 "llo") (42 " Port!")) 1311 (let* ((str "Hello Port!") 1312 (source (with-fluids ((%default-port-encoding "UTF-8")) 1313 (open-string-input-port str))) 1314 (reads '()) 1315 (read! (lambda (bv start count) 1316 (set! reads (cons count reads)) 1317 (let ((r (get-bytevector-n! source bv start count))) 1318 (if (eof-object? r) 1319 0 1320 r)))) 1321 (port (make-custom-binary-input/output-port 1322 "the port" read! dummy-write! 1323 #f #f #f))) 1324 1325 (setvbuf port 'none) 1326 (let ((ret (list (get-bytevector-n port 2) 1327 (get-bytevector-n port 3) 1328 (get-bytevector-n port 42)))) 1329 (zip (reverse reads) 1330 (map (lambda (obj) 1331 (if (bytevector? obj) 1332 (utf8->string obj) 1333 obj)) 1334 ret))))) 1335 1336 (pass-if-equal "custom binary input/output port unbuffered & 'get-string-all'" 1337 (make-string 1000 #\a) 1338 ;; In Guile 2.0.11 this test would lead to a buffer overrun followed 1339 ;; by an assertion failure. See <http://bugs.gnu.org/19621>. 1340 (let* ((input (with-fluids ((%default-port-encoding #f)) 1341 (open-input-string (make-string 1000 #\a)))) 1342 (read! (lambda (bv index count) 1343 (let ((n (get-bytevector-n! input bv index 1344 count))) 1345 (if (eof-object? n) 0 n)))) 1346 (port (make-custom-binary-input/output-port 1347 "foo" read! dummy-write! 1348 #f #f #f))) 1349 (setvbuf port 'none) 1350 (get-string-all port))) 1351 1352 (pass-if-equal "custom binary input/output port unbuffered UTF-8 & \ 1353'get-string-all'" 1354 (make-string 1000 #\λ) 1355 ;; In Guile 2.0.11 this test would lead to a buffer overrun followed 1356 ;; by an assertion failure. See <http://bugs.gnu.org/19621>. 1357 (let* ((input (with-fluids ((%default-port-encoding "UTF-8")) 1358 (open-input-string (make-string 1000 #\λ)))) 1359 (read! (lambda (bv index count) 1360 (let ((n (get-bytevector-n! input bv index 1361 count))) 1362 (if (eof-object? n) 0 n)))) 1363 (port (make-custom-binary-input/output-port 1364 "foo" read! dummy-write! 1365 #f #f #f))) 1366 (setvbuf port 'none) 1367 (set-port-encoding! port "UTF-8") 1368 (get-string-all port))) 1369 1370 (pass-if-equal "custom binary input/output port, unbuffered then buffered" 1371 `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…") 1372 (777 ,(eof-object))) 1373 (let* ((str "Lorem ipsum dolor sit amet, consectetur…") 1374 (source (with-fluids ((%default-port-encoding "UTF-8")) 1375 (open-string-input-port str))) 1376 (reads '()) 1377 (read! (lambda (bv start count) 1378 (set! reads (cons count reads)) 1379 (let ((r (get-bytevector-n! source bv start count))) 1380 (if (eof-object? r) 1381 0 1382 r)))) 1383 (port (make-custom-binary-input/output-port 1384 "the port" read! dummy-write! 1385 #f #f #f))) 1386 1387 (setvbuf port 'none) 1388 (let ((ret (list (get-bytevector-n port 6) 1389 (get-bytevector-n port 12) 1390 (begin 1391 (setvbuf port 'block 777) 1392 (get-bytevector-n port 42)) 1393 (get-bytevector-n port 42)))) 1394 (zip (reverse reads) 1395 (map (lambda (obj) 1396 (if (bytevector? obj) 1397 (utf8->string obj) 1398 obj)) 1399 ret))))) 1400 1401 (pass-if-equal "custom binary input/output port, buffered then unbuffered" 1402 `((18 1403 42 14 ; scm_c_read tries to fill the 42-byte buffer 1404 42) 1405 ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object))) 1406 (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…") 1407 (source (with-fluids ((%default-port-encoding "UTF-8")) 1408 (open-string-input-port str))) 1409 (reads '()) 1410 (read! (lambda (bv start count) 1411 (set! reads (cons count reads)) 1412 (let ((r (get-bytevector-n! source bv start count))) 1413 (if (eof-object? r) 1414 0 1415 r)))) 1416 (port (make-custom-binary-input/output-port 1417 "the port" read! dummy-write! 1418 #f #f #f))) 1419 1420 (setvbuf port 'block 18) 1421 (let ((ret (list (get-bytevector-n port 6) 1422 (get-bytevector-n port 12) 1423 (begin 1424 (setvbuf port 'none) 1425 (get-bytevector-n port 42)) 1426 (get-bytevector-n port 42)))) 1427 (list (reverse reads) 1428 (map (lambda (obj) 1429 (if (bytevector? obj) 1430 (utf8->string obj) 1431 obj)) 1432 ret))))) 1433 1434 (pass-if "custom binary input/output port `close-proc' is called" 1435 (let* ((closed? #f) 1436 (read! (lambda (bv start count) 0)) 1437 (get-pos (lambda () 0)) 1438 (set-pos! (lambda (pos) #f)) 1439 (close! (lambda () (set! closed? #t))) 1440 (port (make-custom-binary-input/output-port 1441 "the port" read! dummy-write! 1442 get-pos set-pos! close!))) 1443 1444 (close-port port) 1445 (gc) ; Test for marking a closed port. 1446 closed?)) 1447 1448 (pass-if "make-custom-binary-input/output-port [partial writes]" 1449 (let* ((source (uint-list->bytevector (iota 333) 1450 (native-endianness) 2)) 1451 (sink (make-bytevector (bytevector-length source))) 1452 (sink-pos 0) 1453 (eof? #f) 1454 (write! (lambda (bv start count) 1455 (if (= 0 count) 1456 (begin 1457 (set! eof? #t) 1458 0) 1459 (let ((u8 (bytevector-u8-ref bv start))) 1460 ;; Get one byte at a time. 1461 (bytevector-u8-set! sink sink-pos u8) 1462 (set! sink-pos (+ 1 sink-pos)) 1463 1)))) 1464 (port (make-custom-binary-input/output-port 1465 "cbop" dummy-read! write! 1466 #f #f #f))) 1467 (put-bytevector port source) 1468 (force-output port) 1469 (and (= sink-pos (bytevector-length source)) 1470 (not eof?) 1471 (bytevector=? sink source)))) 1472 1473 (pass-if "make-custom-binary-input/output-port [full writes]" 1474 (let* ((source (uint-list->bytevector (iota 333) 1475 (native-endianness) 2)) 1476 (sink (make-bytevector (bytevector-length source))) 1477 (sink-pos 0) 1478 (eof? #f) 1479 (write! (lambda (bv start count) 1480 (if (= 0 count) 1481 (begin 1482 (set! eof? #t) 1483 0) 1484 (begin 1485 (bytevector-copy! bv start 1486 sink sink-pos 1487 count) 1488 (set! sink-pos (+ sink-pos count)) 1489 count)))) 1490 (port (make-custom-binary-input/output-port 1491 "cbop" dummy-read! write! 1492 #f #f #f))) 1493 (put-bytevector port source) 1494 (force-output port) 1495 (and (= sink-pos (bytevector-length source)) 1496 (not eof?) 1497 (bytevector=? sink source)))) 1498 1499 (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)\ 1500 [output]" 1501 '(194 169 194 169) 1502 (with-fluids ((%default-port-encoding "UTF-8")) 1503 (let* ((sink '()) 1504 (write! (lambda (bv start count) 1505 (if (= 0 count) ; EOF 1506 0 1507 (let ((u8 (bytevector-u8-ref bv start))) 1508 ;; Get one byte at a time. 1509 (set! sink (cons u8 sink)) 1510 1)))) 1511 (port (make-custom-binary-input/output-port 1512 "cbop" dummy-read! write! 1513 #f #f #f))) 1514 (put-string port "©©") 1515 (force-output port) 1516 (reverse sink)))) 1517 ) 1518 1519(define exception:encoding-error 1520 '(encoding-error . "")) 1521 1522(define exception:decoding-error 1523 '(decoding-error . "")) 1524 1525 1526(with-test-prefix "ascii string" 1527 (let ((s "Hello, World!")) 1528 ;; For ASCII, all of these encodings should be the same. 1529 1530 (pass-if "to ascii bytevector" 1531 (equal? (string->bytevector s (make-transcoder "ASCII")) 1532 #vu8(72 101 108 108 111 44 32 87 111 114 108 100 33))) 1533 1534 (pass-if "to ascii bytevector (length check)" 1535 (equal? (string-length s) 1536 (bytevector-length 1537 (string->bytevector s (make-transcoder "ascii"))))) 1538 1539 (pass-if "from ascii bytevector" 1540 (equal? s 1541 (bytevector->string 1542 (string->bytevector s (make-transcoder "ascii")) 1543 (make-transcoder "ascii")))) 1544 1545 (pass-if "to utf-8 bytevector" 1546 (equal? (string->bytevector s (make-transcoder "ASCII")) 1547 (string->bytevector s (make-transcoder "utf-8")))) 1548 1549 (pass-if "to UTF-8 bytevector (testing encoding case sensitivity)" 1550 (equal? (string->bytevector s (make-transcoder "ascii")) 1551 (string->bytevector s (make-transcoder "UTF-8")))) 1552 1553 (pass-if "from utf-8 bytevector" 1554 (equal? s 1555 (bytevector->string 1556 (string->bytevector s (make-transcoder "utf-8")) 1557 (make-transcoder "utf-8")))) 1558 1559 (pass-if "to latin1 bytevector" 1560 (equal? (string->bytevector s (make-transcoder "ASCII")) 1561 (string->bytevector s (make-transcoder "latin1")))) 1562 1563 (pass-if "from latin1 bytevector" 1564 (equal? s 1565 (bytevector->string 1566 (string->bytevector s (make-transcoder "utf-8")) 1567 (make-transcoder "utf-8")))))) 1568 1569(with-test-prefix "narrow non-ascii string" 1570 (let ((s "été")) 1571 (pass-if "to latin1 bytevector" 1572 (equal? (string->bytevector s (make-transcoder "latin1")) 1573 #vu8(233 116 233))) 1574 1575 (pass-if "to latin1 bytevector (length check)" 1576 (equal? (string-length s) 1577 (bytevector-length 1578 (string->bytevector s (make-transcoder "latin1"))))) 1579 1580 (pass-if "from latin1 bytevector" 1581 (equal? s 1582 (bytevector->string 1583 (string->bytevector s (make-transcoder "latin1")) 1584 (make-transcoder "latin1")))) 1585 1586 (pass-if "to utf-8 bytevector" 1587 (equal? (string->bytevector s (make-transcoder "utf-8")) 1588 #vu8(195 169 116 195 169))) 1589 1590 (pass-if "from utf-8 bytevector" 1591 (equal? s 1592 (bytevector->string 1593 (string->bytevector s (make-transcoder "utf-8")) 1594 (make-transcoder "utf-8")))) 1595 1596 (pass-if-exception "encode latin1 as ascii" exception:encoding-error 1597 (string->bytevector s (make-transcoder "ascii" 1598 (native-eol-style) 1599 (error-handling-mode raise)))) 1600 1601 (pass-if-exception "misparse latin1 as utf8" exception:decoding-error 1602 (bytevector->string 1603 (string->bytevector s (make-transcoder "latin1")) 1604 (make-transcoder "utf-8" 1605 (native-eol-style) 1606 (error-handling-mode raise)))) 1607 1608 (pass-if "misparse latin1 as utf8 with substitutions" 1609 (equal? (bytevector->string 1610 (string->bytevector s (make-transcoder "latin1")) 1611 (make-transcoder "utf-8" (native-eol-style) 1612 (error-handling-mode replace))) 1613 "\uFFFDt\uFFFD")) 1614 1615 (pass-if-exception "misparse latin1 as ascii" exception:decoding-error 1616 (bytevector->string (string->bytevector s (make-transcoder "latin1")) 1617 (make-transcoder "ascii" 1618 (native-eol-style) 1619 (error-handling-mode raise)))))) 1620 1621 1622(with-test-prefix "wide non-ascii string" 1623 (let ((s "ΧΑΟΣ")) 1624 (pass-if "to utf-8 bytevector" 1625 (equal? (string->bytevector s (make-transcoder "utf-8")) 1626 #vu8(206 167 206 145 206 159 206 163) )) 1627 1628 (pass-if "from utf-8 bytevector" 1629 (equal? s 1630 (bytevector->string 1631 (string->bytevector s (make-transcoder "utf-8")) 1632 (make-transcoder "utf-8")))) 1633 1634 (pass-if-exception "encode as ascii" exception:encoding-error 1635 (string->bytevector s (make-transcoder "ascii" 1636 (native-eol-style) 1637 (error-handling-mode raise)))) 1638 1639 (pass-if-exception "encode as latin1" exception:encoding-error 1640 (string->bytevector s (make-transcoder "latin1" 1641 (native-eol-style) 1642 (error-handling-mode raise)))) 1643 1644 (pass-if "encode as ascii with substitutions" 1645 (equal? (make-string (string-length s) #\?) 1646 (bytevector->string 1647 (string->bytevector s (make-transcoder 1648 "ascii" 1649 (native-eol-style) 1650 (error-handling-mode replace))) 1651 (make-transcoder "ascii")))))) 1652 1653;;; Local Variables: 1654;;; mode: scheme 1655;;; eval: (put 'guard 'scheme-indent-function 1) 1656;;; End: 1657