1;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*- 2;;;; Jim Blandy <jimb@red-bean.com> --- May 1999 3;;;; 4;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, 5;;;; 2011, 2012, 2013, 2014, 2015, 2017, 2019, 2020, 2021 Free Software Foundation, Inc. 6;;;; 7;;;; This library is free software; you can redistribute it and/or 8;;;; modify it under the terms of the GNU Lesser General Public 9;;;; License as published by the Free Software Foundation; either 10;;;; version 3 of the License, or (at your option) any later version. 11;;;; 12;;;; This library is distributed in the hope that it will be useful, 13;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15;;;; Lesser General Public License for more details. 16;;;; 17;;;; You should have received a copy of the GNU Lesser General Public 18;;;; License along with this library; if not, write to the Free Software 19;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 20 21(define-module (test-suite test-ports) 22 #:use-module (test-suite lib) 23 #:use-module (test-suite guile-test) 24 #:use-module (ice-9 popen) 25 #:use-module (ice-9 rdelim) 26 #:use-module (ice-9 threads) 27 #:use-module (rnrs bytevectors) 28 #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port 29 open-bytevector-output-port 30 put-bytevector 31 get-bytevector-n 32 get-bytevector-all 33 unget-bytevector))) 34 35(define (display-line . args) 36 (for-each display args) 37 (newline)) 38 39(define (test-file) 40 (data-file-name "ports-test.tmp")) 41 42 43;;;; Some general utilities for testing ports. 44 45;; Make sure we are set up for 8-bit Latin-1 data. 46(fluid-set! %default-port-encoding "ISO-8859-1") 47(for-each (lambda (p) 48 (set-port-encoding! p (fluid-ref %default-port-encoding))) 49 (list (current-input-port) (current-output-port) 50 (current-error-port))) 51 52;;; Read from PORT until EOF, and return the result as a string. 53(define (read-all port) 54 (let loop ((chars '())) 55 (let ((char (read-char port))) 56 (if (eof-object? char) 57 (list->string (reverse! chars)) 58 (loop (cons char chars)))))) 59 60(define (read-file filename) 61 (let* ((port (open-input-file filename)) 62 (string (read-all port))) 63 (close-port port) 64 string)) 65 66 67 68(with-test-prefix "%default-port-conversion-strategy" 69 70 (pass-if "initial value" 71 (eq? 'substitute (fluid-ref %default-port-conversion-strategy))) 72 73 (pass-if "file port" 74 (let ((strategies '(error substitute escape))) 75 (equal? (map (lambda (s) 76 (with-fluids ((%default-port-conversion-strategy s)) 77 (call-with-output-file "/dev/null" 78 (lambda (p) 79 (port-conversion-strategy p))))) 80 strategies) 81 strategies))) 82 83 (pass-if "(set-port-conversion-strategy! #f sym)" 84 (begin 85 (set-port-conversion-strategy! #f 'error) 86 (and (eq? (fluid-ref %default-port-conversion-strategy) 'error) 87 (begin 88 (set-port-conversion-strategy! #f 'substitute) 89 (eq? (fluid-ref %default-port-conversion-strategy) 90 'substitute))))) 91 92) 93 94 95;;;; Normal file ports. 96 97;;; Write out an s-expression, and read it back. 98(let ((string '("From fairest creatures we desire increase," 99 "That thereby beauty's rose might never die,")) 100 (filename (test-file))) 101 (let ((port (open-output-file filename))) 102 (write string port) 103 (close-port port)) 104 (let ((port (open-input-file filename))) 105 (let ((in-string (read port))) 106 (pass-if "file: write and read back list of strings" 107 (equal? string in-string))) 108 (close-port port)) 109 (delete-file filename)) 110 111;;; Write out a string, and read it back a character at a time. 112(let ((string "This is a test string\nwith no newline at the end") 113 (filename (test-file))) 114 (let ((port (open-output-file filename))) 115 (display string port) 116 (close-port port)) 117 (let ((in-string (read-file filename))) 118 (pass-if "file: write and read back characters" 119 (equal? string in-string))) 120 (delete-file filename)) 121 122;;; Buffered input/output port with seeking. 123(let* ((filename (test-file)) 124 (port (open-file filename "w+"))) 125 (display "J'Accuse" port) 126 (seek port -1 SEEK_CUR) 127 (pass-if "file: r/w 1" 128 (char=? (read-char port) #\e)) 129 (pass-if "file: r/w 2" 130 (eof-object? (read-char port))) 131 (seek port -1 SEEK_CUR) 132 (write-char #\x port) 133 (seek port 7 SEEK_SET) 134 (pass-if "file: r/w 3" 135 (char=? (read-char port) #\x)) 136 (seek port -2 SEEK_END) 137 (pass-if "file: r/w 4" 138 (char=? (read-char port) #\s)) 139 (close-port port) 140 (delete-file filename)) 141 142;;; Unbuffered input/output port with seeking. 143(let* ((filename (test-file)) 144 (port (open-file filename "w+0"))) 145 (display "J'Accuse" port) 146 (seek port -1 SEEK_CUR) 147 (pass-if "file: ub r/w 1" 148 (char=? (read-char port) #\e)) 149 (pass-if "file: ub r/w 2" 150 (eof-object? (read-char port))) 151 (seek port -1 SEEK_CUR) 152 (write-char #\x port) 153 (seek port 7 SEEK_SET) 154 (pass-if "file: ub r/w 3" 155 (char=? (read-char port) #\x)) 156 (seek port -2 SEEK_END) 157 (pass-if "file: ub r/w 4" 158 (char=? (read-char port) #\s)) 159 (close-port port) 160 (delete-file filename)) 161 162;;; Buffered output-only and input-only ports with seeking. 163(let* ((filename (test-file)) 164 (port (open-output-file filename))) 165 (display "J'Accuse" port) 166 (pass-if "file: out tell" 167 (= (seek port 0 SEEK_CUR) 8)) 168 (seek port -1 SEEK_CUR) 169 (write-char #\x port) 170 (close-port port) 171 (let ((iport (open-input-file filename))) 172 (pass-if "file: in tell 0" 173 (= (seek iport 0 SEEK_CUR) 0)) 174 (read-char iport) 175 (pass-if "file: in tell 1" 176 (= (seek iport 0 SEEK_CUR) 1)) 177 (unread-char #\z iport) 178 (pass-if "file: in tell 0 after unread" 179 (= (seek iport 0 SEEK_CUR) 0)) 180 (pass-if "file: unread char still there" 181 (char=? (read-char iport) #\z)) 182 (seek iport 7 SEEK_SET) 183 (pass-if "file: in last char" 184 (char=? (read-char iport) #\x)) 185 (close-port iport)) 186 (delete-file filename)) 187 188;;; unusual characters. 189(let* ((filename (test-file)) 190 (port (open-output-file filename))) 191 (display (string #\nul (integer->char 255) (integer->char 128) 192 #\nul) port) 193 (close-port port) 194 (let* ((port (open-input-file filename)) 195 (line (read-line port))) 196 (pass-if "file: read back NUL 1" 197 (char=? (string-ref line 0) #\nul)) 198 (pass-if "file: read back 255" 199 (char=? (string-ref line 1) (integer->char 255))) 200 (pass-if "file: read back 128" 201 (char=? (string-ref line 2) (integer->char 128))) 202 (pass-if "file: read back NUL 2" 203 (char=? (string-ref line 3) #\nul)) 204 (pass-if "file: EOF" 205 (eof-object? (read-char port))) 206 (close-port port)) 207 (delete-file filename)) 208 209;;; line buffering mode. 210(let* ((filename (test-file)) 211 (port (open-file filename "wl")) 212 (test-string "one line more or less")) 213 (write-line test-string port) 214 (let* ((in-port (open-input-file filename)) 215 (line (read-line in-port))) 216 (close-port in-port) 217 (close-port port) 218 (pass-if "file: line buffering" 219 (string=? line test-string))) 220 (delete-file filename)) 221 222;;; read-line should use the port encoding (not the locale encoding). 223(let ((str "ĉu bone?")) 224 (with-locale "C" 225 (let* ((filename (test-file)) 226 (port (open-file filename "wl"))) 227 (set-port-encoding! port "UTF-8") 228 (write-line str port) 229 (let ((in-port (open-input-file filename))) 230 (set-port-encoding! in-port "UTF-8") 231 (let ((line (read-line in-port))) 232 (close-port in-port) 233 (close-port port) 234 (pass-if "file: read-line honors port encoding" 235 (string=? line str)))) 236 (delete-file filename)))) 237 238;;; binary mode ignores port encoding 239(pass-if "file: binary mode ignores port encoding" 240 (with-fluids ((%default-port-encoding "UTF-8")) 241 (let* ((filename (test-file)) 242 (port (open-file filename "w")) 243 (test-string "一二三") 244 (binary-test-string 245 (apply string 246 (map integer->char 247 (array->list 248 (string->utf8 test-string)))))) 249 (write-line test-string port) 250 (close-port port) 251 (let* ((in-port (open-file filename "rb")) 252 (line (read-line in-port))) 253 (close-port in-port) 254 (delete-file filename) 255 (string=? line binary-test-string))))) 256 257;;; binary mode ignores file coding declaration 258(pass-if "file: binary mode ignores file coding declaration" 259 (with-fluids ((%default-port-encoding "UTF-8")) 260 (let* ((filename (test-file)) 261 (port (open-file filename "w")) 262 (test-string "一二三") 263 (binary-test-string 264 (apply string 265 (map integer->char 266 (array->list 267 (string->utf8 test-string)))))) 268 (write-line ";; coding: utf-8" port) 269 (write-line test-string port) 270 (close-port port) 271 (let* ((in-port (open-file filename "rb")) 272 (line1 (read-line in-port)) 273 (line2 (read-line in-port))) 274 (close-port in-port) 275 (delete-file filename) 276 (string=? line2 binary-test-string))))) 277 278;; open-file ignores file coding declaration by default 279(pass-if "file: open-file ignores coding declaration by default" 280 (with-fluids ((%default-port-encoding "UTF-8")) 281 (let* ((filename (test-file)) 282 (port (open-output-file filename)) 283 (test-string "€100")) 284 (write-line ";; coding: iso-8859-15" port) 285 (write-line test-string port) 286 (close-port port) 287 (let* ((in-port (open-input-file filename)) 288 (line1 (read-line in-port)) 289 (line2 (read-line in-port))) 290 (close-port in-port) 291 (delete-file filename) 292 (string=? line2 test-string))))) 293 294;; open-input-file with guess-encoding honors coding declaration 295(pass-if "file: open-input-file with guess-encoding honors coding declaration" 296 (with-fluids ((%default-port-encoding "UTF-8")) 297 (let* ((filename (test-file)) 298 (port (open-output-file filename)) 299 (test-string "€100")) 300 (set-port-encoding! port "iso-8859-15") 301 (write-line ";; coding: iso-8859-15" port) 302 (write-line test-string port) 303 (close-port port) 304 (let* ((in-port (open-input-file filename 305 #:guess-encoding #t)) 306 (line1 (read-line in-port)) 307 (line2 (read-line in-port))) 308 (close-port in-port) 309 (delete-file filename) 310 (string=? line2 test-string))))) 311 312(pass-if-exception "invalid wide mode string" 313 exception:out-of-range 314 (open-file "/dev/null" "λ")) 315 316(pass-if "valid wide mode string" 317 ;; Pass 'open-file' a valid mode string, but as a wide string. 318 (let ((mode (string-copy "λ"))) 319 (string-set! mode 0 #\r) 320 (let ((port (open-file "/dev/null" mode))) 321 (and (input-port? port) 322 (begin 323 (close-port port) 324 #t))))) 325 326(with-test-prefix "keyword arguments for file openers" 327 (with-fluids ((%default-port-encoding "UTF-8")) 328 (let ((filename (test-file))) 329 330 (with-test-prefix "write #:encoding" 331 332 (pass-if-equal "open-file" 333 #vu8(116 0 101 0 115 0 116 0) 334 (let ((port (open-file filename "w" 335 #:encoding "UTF-16LE"))) 336 (display "test" port) 337 (close-port port)) 338 (let* ((port (open-file filename "rb")) 339 (bv (get-bytevector-all port))) 340 (close-port port) 341 bv)) 342 343 (pass-if-equal "open-output-file" 344 #vu8(116 0 101 0 115 0 116 0) 345 (let ((port (open-output-file filename 346 #:encoding "UTF-16LE"))) 347 (display "test" port) 348 (close-port port)) 349 (let* ((port (open-file filename "rb")) 350 (bv (get-bytevector-all port))) 351 (close-port port) 352 bv)) 353 354 (pass-if-equal "call-with-output-file" 355 #vu8(116 0 101 0 115 0 116 0) 356 (call-with-output-file filename 357 (lambda (port) 358 (display "test" port)) 359 #:encoding "UTF-16LE") 360 (let* ((port (open-file filename "rb")) 361 (bv (get-bytevector-all port))) 362 (close-port port) 363 bv)) 364 365 (pass-if-equal "with-output-to-file" 366 #vu8(116 0 101 0 115 0 116 0) 367 (with-output-to-file filename 368 (lambda () 369 (display "test")) 370 #:encoding "UTF-16LE") 371 (let* ((port (open-file filename "rb")) 372 (bv (get-bytevector-all port))) 373 (close-port port) 374 bv)) 375 376 (pass-if-equal "with-error-to-file" 377 #vu8(116 0 101 0 115 0 116 0) 378 (with-error-to-file 379 filename 380 (lambda () 381 (display "test" (current-error-port))) 382 #:encoding "UTF-16LE") 383 (let* ((port (open-file filename "rb")) 384 (bv (get-bytevector-all port))) 385 (close-port port) 386 bv))) 387 388 (with-test-prefix "write #:binary" 389 390 (pass-if-equal "open-output-file" 391 "ISO-8859-1" 392 (let* ((port (open-output-file filename #:binary #t)) 393 (enc (port-encoding port))) 394 (close-port port) 395 enc)) 396 397 (pass-if-equal "call-with-output-file" 398 "ISO-8859-1" 399 (call-with-output-file filename port-encoding #:binary #t)) 400 401 (pass-if-equal "with-output-to-file" 402 "ISO-8859-1" 403 (with-output-to-file filename 404 (lambda () (port-encoding (current-output-port))) 405 #:binary #t)) 406 407 (pass-if-equal "with-error-to-file" 408 "ISO-8859-1" 409 (with-error-to-file 410 filename 411 (lambda () (port-encoding (current-error-port))) 412 #:binary #t))) 413 414 (with-test-prefix "read #:encoding" 415 416 (pass-if-equal "open-file read #:encoding" 417 "test" 418 (call-with-output-file filename 419 (lambda (port) 420 (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) 421 (let* ((port (open-file filename "r" #:encoding "UTF-16LE")) 422 (str (read-string port))) 423 (close-port port) 424 str)) 425 426 (pass-if-equal "open-input-file #:encoding" 427 "test" 428 (call-with-output-file filename 429 (lambda (port) 430 (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) 431 (let* ((port (open-input-file filename #:encoding "UTF-16LE")) 432 (str (read-string port))) 433 (close-port port) 434 str)) 435 436 (pass-if-equal "call-with-input-file #:encoding" 437 "test" 438 (call-with-output-file filename 439 (lambda (port) 440 (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) 441 (call-with-input-file filename 442 read-string 443 #:encoding "UTF-16LE")) 444 445 (pass-if-equal "with-input-from-file #:encoding" 446 "test" 447 (call-with-output-file filename 448 (lambda (port) 449 (put-bytevector port #vu8(116 0 101 0 115 0 116 0)))) 450 (with-input-from-file filename 451 read-string 452 #:encoding "UTF-16LE"))) 453 454 (with-test-prefix "read #:binary" 455 456 (pass-if-equal "open-input-file" 457 "ISO-8859-1" 458 (let* ((port (open-input-file filename #:binary #t)) 459 (enc (port-encoding port))) 460 (close-port port) 461 enc)) 462 463 (pass-if-equal "call-with-input-file" 464 "ISO-8859-1" 465 (call-with-input-file filename port-encoding #:binary #t)) 466 467 (pass-if-equal "with-input-from-file" 468 "ISO-8859-1" 469 (with-input-from-file filename 470 (lambda () (port-encoding (current-input-port))) 471 #:binary #t))) 472 473 (with-test-prefix "#:guess-encoding with coding declaration" 474 475 (pass-if-equal "open-file" 476 "€100" 477 (with-output-to-file filename 478 (lambda () 479 (write-line "test") 480 (write-line "; coding: ISO-8859-15") 481 (write-line "€100")) 482 #:encoding "ISO-8859-15") 483 (let* ((port (open-file filename "r" 484 #:guess-encoding #t 485 #:encoding "UTF-16LE")) 486 (str (begin (read-line port) 487 (read-line port) 488 (read-line port)))) 489 (close-port port) 490 str)) 491 492 (pass-if-equal "open-input-file" 493 "€100" 494 (with-output-to-file filename 495 (lambda () 496 (write-line "test") 497 (write-line "; coding: ISO-8859-15") 498 (write-line "€100")) 499 #:encoding "ISO-8859-15") 500 (let* ((port (open-input-file filename 501 #:guess-encoding #t 502 #:encoding "UTF-16LE")) 503 (str (begin (read-line port) 504 (read-line port) 505 (read-line port)))) 506 (close-port port) 507 str)) 508 509 (pass-if-equal "call-with-input-file" 510 "€100" 511 (with-output-to-file filename 512 (lambda () 513 (write-line "test") 514 (write-line "; coding: ISO-8859-15") 515 (write-line "€100")) 516 #:encoding "ISO-8859-15") 517 (call-with-input-file filename 518 (lambda (port) 519 (read-line port) 520 (read-line port) 521 (read-line port)) 522 #:guess-encoding #t 523 #:encoding "UTF-16LE")) 524 525 (pass-if-equal "with-input-from-file" 526 "€100" 527 (with-output-to-file filename 528 (lambda () 529 (write-line "test") 530 (write-line "; coding: ISO-8859-15") 531 (write-line "€100")) 532 #:encoding "ISO-8859-15") 533 (with-input-from-file filename 534 (lambda () 535 (read-line) 536 (read-line) 537 (read-line)) 538 #:guess-encoding #t 539 #:encoding "UTF-16LE"))) 540 541 (with-test-prefix "#:guess-encoding without coding declaration" 542 543 (pass-if-equal "open-file" 544 "€100" 545 (with-output-to-file filename 546 (lambda () (write-line "€100")) 547 #:encoding "ISO-8859-15") 548 (let* ((port (open-file filename "r" 549 #:guess-encoding #t 550 #:encoding "ISO-8859-15")) 551 (str (read-line port))) 552 (close-port port) 553 str)) 554 555 (pass-if-equal "open-input-file" 556 "€100" 557 (with-output-to-file filename 558 (lambda () (write-line "€100")) 559 #:encoding "ISO-8859-15") 560 (let* ((port (open-input-file filename 561 #:guess-encoding #t 562 #:encoding "ISO-8859-15")) 563 (str (read-line port))) 564 (close-port port) 565 str)) 566 567 (pass-if-equal "call-with-input-file" 568 "€100" 569 (with-output-to-file filename 570 (lambda () (write-line "€100")) 571 #:encoding "ISO-8859-15") 572 (call-with-input-file filename 573 read-line 574 #:guess-encoding #t 575 #:encoding "ISO-8859-15")) 576 577 (pass-if-equal "with-input-from-file" 578 "€100" 579 (with-output-to-file filename 580 (lambda () (write-line "€100")) 581 #:encoding "ISO-8859-15") 582 (with-input-from-file filename 583 read-line 584 #:guess-encoding #t 585 #:encoding "ISO-8859-15"))) 586 587 (delete-file filename)))) 588 589;;; ungetting characters and strings. 590(with-input-from-string "walk on the moon\nmoon" 591 (lambda () 592 (read-char) 593 (unread-char #\a (current-input-port)) 594 (pass-if "unread-char" 595 (char=? (read-char) #\a)) 596 (read-line) 597 (let ((replacenoid "chicken enchilada")) 598 (unread-char #\newline (current-input-port)) 599 (unread-string replacenoid (current-input-port)) 600 (pass-if "unread-string" 601 (string=? (read-line) replacenoid))) 602 (pass-if "unread residue" 603 (string=? (read-line) "moon")))) 604 605(pass-if-equal "initial revealed count" ;<https://bugs.gnu.org/41204> 606 0 607 (let* ((port (open-input-file "/dev/null")) 608 (revealed (port-revealed port))) 609 (close-port port) 610 revealed)) 611 612(pass-if-equal "non-revealed port is closed" 613 EBADF 614 (let* ((port (open-input-file "/dev/null")) 615 (fdes (fileno port))) ;leaves revealed count unchanged 616 (unless (zero? (port-revealed port)) 617 (error "wrong revealed count" (port-revealed port))) 618 619 (set! port #f) 620 (gc) 621 (catch 'system-error 622 (lambda () 623 (seek fdes 0 SEEK_CUR) 624 625 ;; If we get here, it might be because PORT was not GC'd, we 626 ;; don't know (and we can't use a guardian because it would keep 627 ;; PORT alive.) 628 (close-fdes fdes) 629 (throw 'unresolved)) 630 (lambda args 631 (system-error-errno args))))) 632 633(pass-if-equal "close-port & revealed port" 634 EBADF 635 (let* ((port (open-file "/dev/null" "r0")) 636 (fdes (port->fdes port))) ;increments revealed count of PORT 637 (unless (= 1 (port-revealed port)) 638 (error "wrong revealed count" (port-revealed port))) 639 (close-port port) ;closes FDES as a side-effect 640 (catch 'system-error 641 (lambda () 642 (seek fdes 0 SEEK_CUR) 643 #f) 644 (lambda args 645 (system-error-errno args))))) 646 647(pass-if "revealed port fdes not closed" 648 (let* ((port (open-file "/dev/null" "r0")) 649 (fdes (port->fdes port))) 650 (unless (= 1 (port-revealed port)) 651 (error "wrong revealed count" (port-revealed port))) 652 653 (set! port #f) 654 (gc) 655 656 ;; Note: We can't know for sure whether PORT was GC'd; using a 657 ;; guardian is not an option because it would keep it alive. 658 (and (zero? (seek fdes 0 SEEK_CUR)) 659 (begin 660 (close-fdes fdes) 661 #t)))) 662 663(when (and (provided? 'threads) (provided? 'fcntl)) 664 (let* ((p (pipe)) 665 (r (car p)) 666 (w (cdr p))) 667 (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) 668 (let ((thread (call-with-new-thread 669 (lambda () 670 (usleep (* 250 1000)) 671 (write-char #\a w) 672 (force-output w))))) 673 (pass-if-equal "non-blocking-I/O" #\a (read-char r)) 674 (join-thread thread)))) 675 676 677;;;; Pipe (popen) ports. 678 679;;; Run a command, and read its output. 680(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) 681 (in-string (read-all pipe))) 682 (close-pipe pipe) 683 (pass-if "pipe: read" 684 (equal? in-string "Howdy there, partner!\n"))) 685 686;;; Run a command, send some output to it, and see if it worked. 687(let* ((filename (test-file)) 688 (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) 689 (display "Now Jimmy lives on a mushroom cloud\n" pipe) 690 (display "Mommy, why does everybody have a bomb?\n" pipe) 691 (close-pipe pipe) 692 (let ((in-string (read-file filename))) 693 (pass-if "pipe: write" 694 (equal? in-string "Mommy, why does everybody have a bomb?\n"))) 695 (delete-file filename)) 696 697(pass-if-equal "pipe, fdopen, and line buffering" 698 "foo\nbar\n" 699 (unless (provided? 'fork) 700 (throw 'unresolved)) 701 (let ((in+out (pipe)) 702 (pid (primitive-fork))) 703 (if (zero? pid) 704 (dynamic-wind 705 (const #t) 706 (lambda () 707 (close-port (car in+out)) 708 (let ((port (cdr in+out))) 709 (setvbuf port 'line ) 710 ;; Strings containing '\n' or should be flushed; others 711 ;; should be kept in PORT's buffer. 712 (display "foo\n" port) 713 (display "bar\n" port) 714 (display "this will be kept in PORT's buffer" port))) 715 (lambda () 716 (primitive-_exit 0))) 717 (begin 718 (close-port (cdr in+out)) 719 (let ((str (read-all (car in+out)))) 720 (waitpid pid) 721 str))))) 722 723 724;;;; Void ports. These are so trivial we don't test them. 725 726 727;;;; String ports. 728 729(with-test-prefix "string ports" 730 731 ;; Write text to a string port. 732 (let* ((string "Howdy there, partner!") 733 (in-string (call-with-output-string 734 (lambda (port) 735 (display string port) 736 (newline port))))) 737 (pass-if "display text" 738 (equal? in-string (string-append string "\n")))) 739 740 ;; Write an s-expression to a string port. 741 (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) 742 (in-sexpr 743 (call-with-input-string (call-with-output-string 744 (lambda (port) 745 (write sexpr port))) 746 read))) 747 (pass-if "write/read sexpr" 748 (equal? in-sexpr sexpr))) 749 750 ;; seeking and unreading from an input string. 751 (let ((text "that text didn't look random to me")) 752 (call-with-input-string text 753 (lambda (p) 754 (pass-if "input tell 0" 755 (= (seek p 0 SEEK_CUR) 0)) 756 (read-char p) 757 (pass-if "input tell 1" 758 (= (seek p 0 SEEK_CUR) 1)) 759 (unread-char #\x p) 760 (pass-if "input tell back to 0" 761 (= (seek p 0 SEEK_CUR) 0)) 762 (pass-if "input ungetted char" 763 (char=? (read-char p) #\x)) 764 (seek p 0 SEEK_END) 765 (pass-if "input seek to end" 766 (= (seek p 0 SEEK_CUR) 767 (string-length text))) 768 (unread-char #\x p) 769 (pass-if "input seek to beginning" 770 (= (seek p 0 SEEK_SET) 0)) 771 (pass-if "input reread first char" 772 (char=? (read-char p) 773 (string-ref text 0)))))) 774 775 ;; seeking an output string. 776 (let* ((text (string-copy "123456789")) 777 (len (string-length text)) 778 (result (call-with-output-string 779 (lambda (p) 780 (pass-if "output tell 0" 781 (= (seek p 0 SEEK_CUR) 0)) 782 (display text p) 783 (pass-if "output tell end" 784 (= (seek p 0 SEEK_CUR) len)) 785 (pass-if "output seek to beginning" 786 (= (seek p 0 SEEK_SET) 0)) 787 (write-char #\a p) 788 (seek p -1 SEEK_END) 789 (pass-if "output seek to last char" 790 (= (seek p 0 SEEK_CUR) 791 (- len 1))) 792 (write-char #\b p))))) 793 (string-set! text 0 #\a) 794 (string-set! text (- len 1) #\b) 795 (pass-if "output check" 796 (string=? text result))) 797 798 (pass-if-exception "truncating input string fails" 799 exception:wrong-type-arg 800 (call-with-input-string "hej" 801 (lambda (p) 802 (truncate-file p 0)))) 803 804 (pass-if-equal "truncating output string" "hej" 805 (call-with-output-string 806 (lambda (p) 807 (truncate-file p 0) 808 (display "hej" p)))) 809 810 (pass-if-exception "truncating output string before position" 811 exception:out-of-range 812 (call-with-output-string 813 (lambda (p) 814 (display "hej" p) 815 (truncate-file p 0)))) 816 817 (pass-if-equal "truncating output string at position" "hej" 818 (call-with-output-string 819 (lambda (p) 820 (display "hej" p) 821 (truncate-file p 3)))) 822 823 (pass-if-equal "truncating output string after seek" "" 824 (call-with-output-string 825 (lambda (p) 826 (display "hej" p) 827 (seek p 0 SEEK_SET) 828 (truncate-file p 0)))) 829 830 (pass-if-equal "truncating output string after seek to end" "hej" 831 (call-with-output-string 832 (lambda (p) 833 (display "hej" p) 834 (seek p 0 SEEK_SET) 835 (truncate-file p 3)))) 836 837 (pass-if "%default-port-encoding is ignored" 838 (let ((str "ĉu bone?")) 839 ;; Latin-1 cannot represent ‘ĉ’. 840 (with-fluids ((%default-port-encoding "ISO-8859-1")) 841 (string=? (call-with-output-string 842 (lambda (p) 843 (set-port-conversion-strategy! p 'substitute) 844 (display str p))) 845 "ĉu bone?")))) 846 847 (pass-if "%default-port-conversion-strategy is honored" 848 (let ((strategies '(error substitute escape))) 849 (equal? (map (lambda (s) 850 (with-fluids ((%default-port-conversion-strategy s)) 851 (call-with-output-string 852 (lambda (p) 853 (and (eq? s (port-conversion-strategy p)) 854 (begin 855 (set-port-conversion-strategy! p s) 856 (display (port-conversion-strategy p) 857 p))))))) 858 strategies) 859 (map symbol->string strategies)))) 860 861 (pass-if "suitable encoding [latin-1]" 862 (let ((str "hello, world") 863 (encoding "ISO-8859-1")) 864 (equal? str 865 (call-with-output-string 866 (lambda (p) 867 (set-port-encoding! p encoding) 868 (display str p)))))) 869 870 (pass-if "suitable encoding [latin-3]" 871 (let ((str "ĉu bone?") 872 (encoding "ISO-8859-3")) 873 (equal? str 874 (call-with-output-string 875 (lambda (p) 876 (set-port-encoding! p encoding) 877 (display str p)))))) 878 879 (pass-if "wrong encoding, error" 880 (let ((str "ĉu bone?")) 881 (catch 'encoding-error 882 (lambda () 883 (with-fluids ((%default-port-conversion-strategy 'error)) 884 (call-with-output-string 885 (lambda (p) 886 ;; Latin-1 cannot represent ‘ĉ’. 887 (set-port-encoding! p "ISO-8859-1") 888 (display str p)))) 889 #f) ; so the test really fails here 890 (lambda (key subr message errno port chr) 891 (and (eqv? chr #\ĉ) 892 (string? (strerror errno))))))) 893 894 (pass-if "wrong encoding, substitute" 895 (let ((str "ĉu bone?")) 896 (string=? (call-with-output-string 897 (lambda (p) 898 (set-port-encoding! p "ISO-8859-1") 899 (set-port-conversion-strategy! p 'substitute) 900 (display str p))) 901 "?u bone?"))) 902 903 (pass-if "wrong encoding, escape" 904 (let ((str "ĉu bone?")) 905 (string=? (call-with-output-string 906 (lambda (p) 907 (set-port-encoding! p "ISO-8859-1") 908 (set-port-conversion-strategy! p 'escape) 909 (display str p))) 910 "\\u0109u bone?"))) 911 912 (pass-if "peek-char" 913 (let ((p (open-input-string "안녕하세요"))) 914 (and (char=? (peek-char p) #\안) 915 (char=? (peek-char p) #\안) 916 (char=? (peek-char p) #\안) 917 (= (port-line p) 0) 918 (= (port-column p) 0)))) 919 920 ;; Mini DSL to test decoding error handling. 921 (letrec-syntax ((decoding-error? 922 (syntax-rules () 923 ((_ port proc) 924 (catch 'decoding-error 925 (lambda () 926 (pk 'proc (proc port)) 927 #f) 928 (lambda (key subr message errno p) 929 (define (skip-over-error) 930 (let ((strategy (port-conversion-strategy p))) 931 (set-port-conversion-strategy! p 'substitute) 932 ;; If `proc' is `read-char', this will 933 ;; skip over the bad bytes. 934 (let ((c (proc p))) 935 (unless (eqv? c #\xFFFD) 936 (error "unexpected char" c)) 937 (set-port-conversion-strategy! p strategy) 938 #t))) 939 (and (eq? p port) 940 (not (= 0 errno)) 941 (skip-over-error))))))) 942 (make-check 943 (syntax-rules (-> error eof) 944 ((_ port (proc -> error)) 945 (if (eq? 'substitute 946 (port-conversion-strategy port)) 947 (eqv? (proc port) #\xFFFD) 948 (decoding-error? port proc))) 949 ((_ port (proc -> eof)) 950 (eof-object? (proc port))) 951 ((_ port (proc -> char)) 952 (eqv? (proc port) char)))) 953 (make-checks 954 (syntax-rules () 955 ((_ port check ...) 956 (and (make-check port check) ...)))) 957 (make-peek+read-checks 958 (syntax-rules () 959 ((_ port (result ...) e1 expected ...) 960 (make-peek+read-checks port 961 (result ... 962 (peek-char -> e1) 963 (read-char -> e1)) 964 expected ...)) 965 ((_ port (result ...)) 966 (make-checks port result ...)) 967 ((_ port #f e1 expected ...) 968 (make-peek+read-checks port 969 ((peek-char -> e1) 970 (read-char -> e1)) 971 expected ...)))) 972 973 (test-decoding-error* 974 (syntax-rules () 975 ((_ sequence encoding strategy (expected ...)) 976 (begin 977 (pass-if (format #f "test-decoding-error: ~s ~s ~s" 978 'sequence encoding strategy) 979 (let ((p (open-bytevector-input-port 980 (u8-list->bytevector 'sequence)))) 981 (set-port-encoding! p encoding) 982 (set-port-conversion-strategy! p strategy) 983 (make-checks p 984 (read-char -> expected) ...))) 985 986 ;; Generate the same test, but with one 987 ;; `peek-char' call before each `read-char'. 988 ;; Both should yield the same result. 989 (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char" 990 'sequence encoding strategy) 991 (let ((p (open-bytevector-input-port 992 (u8-list->bytevector 'sequence)))) 993 (set-port-encoding! p encoding) 994 (set-port-conversion-strategy! p strategy) 995 (make-peek+read-checks p #f expected 996 ...))))))) 997 (test-decoding-error 998 (syntax-rules () 999 ((_ sequence encoding (expected ...)) 1000 (begin 1001 (test-decoding-error* sequence encoding 'error 1002 (expected ...)) 1003 1004 ;; `escape' should behave exactly like `error'. 1005 (test-decoding-error* sequence encoding 'escape 1006 (expected ...)) 1007 1008 (test-decoding-error* sequence encoding 'substitute 1009 (expected ...))))))) 1010 1011 (test-decoding-error (255 65 66 67) "UTF-8" 1012 (error #\A #\B #\C eof)) 1013 1014 (test-decoding-error (255 206 187 206 188) "UTF-8" 1015 (error #\λ #\μ eof)) 1016 1017 (test-decoding-error (206 187 206) "UTF-8" 1018 ;; Unterminated sequence. 1019 (#\λ error eof)) 1020 1021 ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7 1022 ;; of the "Conformance" chapter of Unicode 6.0.0.) 1023 1024 (test-decoding-error (#xc0 #x80 #x41) "UTF-8" 1025 (error ;; C0: should be in the C2..DF range 1026 error ;; 80: invalid 1027 #\A 1028 eof)) 1029 1030 (test-decoding-error (#xc2 #x41 #x42) "UTF-8" 1031 ;; Section 3.9 of Unicode 6.0.0 reads: 1032 ;; "If the converter encounters an ill-formed UTF-8 code unit 1033 ;; sequence which starts with a valid first byte, but which does 1034 ;; not continue with valid successor bytes (see Table 3-7), it 1035 ;; must not consume the successor bytes". 1036 ;; Glibc/libiconv do not conform to it and instead swallow the 1037 ;; #x41. This example appears literally in Section 3.9. 1038 (error ;; 41: invalid successor 1039 #\A ;; 41: valid starting byte 1040 #\B 1041 eof)) 1042 1043 (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8" 1044 ;; According to Unicode 6.0.0, Section 3.9, "the only formal 1045 ;; requirement mandated by Unicode conformance for a converter is 1046 ;; that the <41> be processed and correctly interpreted as 1047 ;; <U+0041>". 1048 (error ;; 2nd byte should be in the A0..BF range 1049 error ;; 80: not a valid starting byte 1050 error ;; 80: not a valid starting byte 1051 #\A 1052 eof)) 1053 1054 (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8" 1055 (error ;; 3rd byte should be in the 80..BF range 1056 #\A 1057 #\B 1058 eof)) 1059 1060 (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8" 1061 (error ;; 2nd byte should be in the 90..BF range 1062 error ;; 88: not a valid starting byte 1063 error ;; 88: not a valid starting byte 1064 error ;; 88: not a valid starting byte 1065 eof)))) 1066 1067(with-test-prefix "call-with-output-string" 1068 1069 ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't 1070 ;; occur. 1071 (pass-if-exception "proc closes port" exception:wrong-type-arg 1072 (call-with-output-string close-port))) 1073 1074 1075 1076;;;; Soft ports. No tests implemented yet. 1077 1078 1079;;;; Generic operations across all port types. 1080 1081(let ((port-loop-temp (test-file))) 1082 1083 ;; Return a list of input ports that all return the same text. 1084 ;; We map tests over this list. 1085 (define (input-port-list text) 1086 1087 ;; Create a text file some of the ports will use. 1088 (let ((out-port (open-output-file port-loop-temp))) 1089 (display text out-port) 1090 (close-port out-port)) 1091 1092 (list (open-input-file port-loop-temp) 1093 (open-input-pipe (string-append "cat " port-loop-temp)) 1094 (call-with-input-string text (lambda (x) x)) 1095 ;; We don't test soft ports at the moment. 1096 )) 1097 1098 (define port-list-names '("file" "pipe" "string")) 1099 1100 ;; Test the line counter. 1101 (define (test-line-counter text second-line final-column) 1102 (with-test-prefix "line counter" 1103 (let ((ports (input-port-list text))) 1104 (for-each 1105 (lambda (port port-name) 1106 (with-test-prefix port-name 1107 (pass-if "at beginning of input" 1108 (= (port-line port) 0)) 1109 (pass-if "read first character" 1110 (eqv? (read-char port) #\x)) 1111 (pass-if "after reading one character" 1112 (= (port-line port) 0)) 1113 (pass-if "read first newline" 1114 (eqv? (read-char port) #\newline)) 1115 (pass-if "after reading first newline char" 1116 (= (port-line port) 1)) 1117 (pass-if "second line read correctly" 1118 (equal? (read-line port) second-line)) 1119 (pass-if "read-line increments line number" 1120 (= (port-line port) 2)) 1121 (pass-if "read-line returns EOF" 1122 (let loop ((i 0)) 1123 (cond 1124 ((eof-object? (read-line port)) #t) 1125 ((> i 20) #f) 1126 (else (loop (+ i 1)))))) 1127 (pass-if "line count is 5 at EOF" 1128 (= (port-line port) 5)) 1129 (pass-if "column is correct at EOF" 1130 (= (port-column port) final-column)))) 1131 ports port-list-names) 1132 (for-each close-port ports) 1133 (delete-file port-loop-temp)))) 1134 1135 (with-test-prefix "newline" 1136 (test-line-counter 1137 (string-append "x\n" 1138 "He who receives an idea from me, receives instruction\n" 1139 "himself without lessening mine; as he who lights his\n" 1140 "taper at mine, receives light without darkening me.\n" 1141 " --- Thomas Jefferson\n") 1142 "He who receives an idea from me, receives instruction" 1143 0)) 1144 1145 (with-test-prefix "no newline" 1146 (test-line-counter 1147 (string-append "x\n" 1148 "He who receives an idea from me, receives instruction\n" 1149 "himself without lessening mine; as he who lights his\n" 1150 "taper at mine, receives light without darkening me.\n" 1151 " --- Thomas Jefferson\n" 1152 "no newline here") 1153 "He who receives an idea from me, receives instruction" 1154 15))) 1155 1156;; Test port-line and port-column for output ports 1157 1158(define (test-output-line-counter text final-column) 1159 (with-test-prefix "port-line and port-column for output ports" 1160 (let ((port (open-output-string))) 1161 (pass-if "at beginning of input" 1162 (and (= (port-line port) 0) 1163 (= (port-column port) 0))) 1164 (write-char #\x port) 1165 (pass-if "after writing one character" 1166 (and (= (port-line port) 0) 1167 (= (port-column port) 1))) 1168 (write-char #\newline port) 1169 (pass-if "after writing first newline char" 1170 (and (= (port-line port) 1) 1171 (= (port-column port) 0))) 1172 (display text port) 1173 (pass-if "line count is 5 at end" 1174 (= (port-line port) 5)) 1175 (pass-if "column is correct at end" 1176 (= (port-column port) final-column))))) 1177 1178(test-output-line-counter 1179 (string-append "He who receives an idea from me, receives instruction\n" 1180 "himself without lessening mine; as he who lights his\n" 1181 "taper at mine, receives light without darkening me.\n" 1182 " --- Thomas Jefferson\n" 1183 "no newline here") 1184 15) 1185 1186(with-test-prefix "port-column" 1187 1188 (with-test-prefix "output" 1189 1190 (pass-if "x" 1191 (let ((port (open-output-string))) 1192 (display "x" port) 1193 (= 1 (port-column port)))) 1194 1195 (pass-if "\\a" 1196 (let ((port (open-output-string))) 1197 (display "\a" port) 1198 (= 0 (port-column port)))) 1199 1200 (pass-if "x\\a" 1201 (let ((port (open-output-string))) 1202 (display "x\a" port) 1203 (= 1 (port-column port)))) 1204 1205 (pass-if "\\x08 backspace" 1206 (let ((port (open-output-string))) 1207 (display "\x08" port) 1208 (= 0 (port-column port)))) 1209 1210 (pass-if "x\\x08 backspace" 1211 (let ((port (open-output-string))) 1212 (display "x\x08" port) 1213 (= 0 (port-column port)))) 1214 1215 (pass-if "\\n" 1216 (let ((port (open-output-string))) 1217 (display "\n" port) 1218 (= 0 (port-column port)))) 1219 1220 (pass-if "x\\n" 1221 (let ((port (open-output-string))) 1222 (display "x\n" port) 1223 (= 0 (port-column port)))) 1224 1225 (pass-if "\\r" 1226 (let ((port (open-output-string))) 1227 (display "\r" port) 1228 (= 0 (port-column port)))) 1229 1230 (pass-if "x\\r" 1231 (let ((port (open-output-string))) 1232 (display "x\r" port) 1233 (= 0 (port-column port)))) 1234 1235 (pass-if "\\t" 1236 (let ((port (open-output-string))) 1237 (display "\t" port) 1238 (= 8 (port-column port)))) 1239 1240 (pass-if "x\\t" 1241 (let ((port (open-output-string))) 1242 (display "x\t" port) 1243 (= 8 (port-column port))))) 1244 1245 (with-test-prefix "input" 1246 1247 (pass-if "x" 1248 (let ((port (open-input-string "x"))) 1249 (while (not (eof-object? (read-char port)))) 1250 (= 1 (port-column port)))) 1251 1252 (pass-if "\\a" 1253 (let ((port (open-input-string "\a"))) 1254 (while (not (eof-object? (read-char port)))) 1255 (= 0 (port-column port)))) 1256 1257 (pass-if "x\\a" 1258 (let ((port (open-input-string "x\a"))) 1259 (while (not (eof-object? (read-char port)))) 1260 (= 1 (port-column port)))) 1261 1262 (pass-if "\\x08 backspace" 1263 (let ((port (open-input-string "\x08"))) 1264 (while (not (eof-object? (read-char port)))) 1265 (= 0 (port-column port)))) 1266 1267 (pass-if "x\\x08 backspace" 1268 (let ((port (open-input-string "x\x08"))) 1269 (while (not (eof-object? (read-char port)))) 1270 (= 0 (port-column port)))) 1271 1272 (pass-if "\\n" 1273 (let ((port (open-input-string "\n"))) 1274 (while (not (eof-object? (read-char port)))) 1275 (= 0 (port-column port)))) 1276 1277 (pass-if "x\\n" 1278 (let ((port (open-input-string "x\n"))) 1279 (while (not (eof-object? (read-char port)))) 1280 (= 0 (port-column port)))) 1281 1282 (pass-if "\\r" 1283 (let ((port (open-input-string "\r"))) 1284 (while (not (eof-object? (read-char port)))) 1285 (= 0 (port-column port)))) 1286 1287 (pass-if "x\\r" 1288 (let ((port (open-input-string "x\r"))) 1289 (while (not (eof-object? (read-char port)))) 1290 (= 0 (port-column port)))) 1291 1292 (pass-if "\\t" 1293 (let ((port (open-input-string "\t"))) 1294 (while (not (eof-object? (read-char port)))) 1295 (= 8 (port-column port)))) 1296 1297 (pass-if "x\\t" 1298 (let ((port (open-input-string "x\t"))) 1299 (while (not (eof-object? (read-char port)))) 1300 (= 8 (port-column port)))))) 1301 1302(with-test-prefix "port-line" 1303 1304 ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas 1305 ;; scm_t_port actually holds a long; this restricted the range on 64-bit 1306 ;; systems 1307 (pass-if "set most-positive-fixnum/2" 1308 (let ((n (quotient most-positive-fixnum 2)) 1309 (port (open-output-string))) 1310 (set-port-line! port n) 1311 (eqv? n (port-line port))))) 1312 1313(with-test-prefix "port-encoding" 1314 1315 (pass-if-exception "set-port-encoding!, wrong encoding" 1316 exception:miscellaneous-error 1317 (let ((p (open-input-string "q"))) 1318 (set-port-encoding! p "does-not-exist") 1319 (read p))) 1320 1321 (let* ((filename (test-file)) 1322 (port (open-output-file filename))) 1323 (write 'test port) 1324 (close-port port) 1325 1326 (pass-if-exception "%default-port-encoding, wrong encoding" 1327 exception:miscellaneous-error 1328 (with-fluids ((%default-port-encoding "does-not-exist")) 1329 (set! port (open-input-file filename)) 1330 (read port))) 1331 (false-if-exception (close-port port)) 1332 (delete-file filename))) 1333 1334;;; 1335;;; port-for-each 1336;;; 1337 1338(with-test-prefix "port-for-each" 1339 1340 ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to 1341 ;; its iterator func if a port was inaccessible in the last gc mark but 1342 ;; the lazy sweeping has not yet reached it to remove it from the port 1343 ;; table (scm_i_port_table). Provoking those gc conditions is a little 1344 ;; tricky, but the following code made it happen in 1.8.2. 1345 (pass-if "passing freed cell" 1346 (let ((lst '())) 1347 ;; clear out the heap 1348 (gc) (gc) (gc) 1349 ;; allocate cells so the opened ports aren't at the start of the heap 1350 (make-list 1000) 1351 (open-input-file "/dev/null") 1352 (make-list 1000) 1353 (open-input-file "/dev/null") 1354 ;; this gc leaves the above ports unmarked, ie. inaccessible 1355 (gc) 1356 ;; but they're still in the port table, so this sees them 1357 (port-for-each (lambda (port) 1358 (set! lst (cons port lst)))) 1359 ;; this forces completion of the sweeping 1360 (gc) (gc) (gc) 1361 ;; and (if the bug is present) the cells accumulated in LST are now 1362 ;; freed cells, which give #f from `port?' 1363 (not (memq #f (map port? lst)))))) 1364 1365(with-test-prefix 1366 "fdes->port" 1367 (pass-if "fdes->ports finds port" 1368 (let* ((port (open-file (test-file) "w")) 1369 (res (not (not (memq port (fdes->ports (port->fdes port))))))) 1370 (close-port port) 1371 res))) 1372 1373;;; 1374;;; seek 1375;;; 1376 1377(with-test-prefix "seek" 1378 1379 (with-test-prefix "file port" 1380 1381 (pass-if "SEEK_CUR" 1382 (call-with-output-file (test-file) 1383 (lambda (port) 1384 (display "abcde" port))) 1385 (let ((port (open-file (test-file) "r"))) 1386 (read-char port) 1387 (seek port 2 SEEK_CUR) 1388 (let ((res (eqv? #\d (read-char port)))) 1389 (close-port port) 1390 res))) 1391 1392 (pass-if "SEEK_SET" 1393 (call-with-output-file (test-file) 1394 (lambda (port) 1395 (display "abcde" port))) 1396 (let ((port (open-file (test-file) "r"))) 1397 (read-char port) 1398 (seek port 3 SEEK_SET) 1399 (let ((res (eqv? #\d (read-char port)))) 1400 (close-port port) 1401 res))) 1402 1403 (pass-if "SEEK_END" 1404 (call-with-output-file (test-file) 1405 (lambda (port) 1406 (display "abcde" port))) 1407 (let ((port (open-file (test-file) "r"))) 1408 (read-char port) 1409 (seek port -2 SEEK_END) 1410 (let ((res (eqv? #\d (read-char port)))) 1411 (close-port port) 1412 res))))) 1413 1414;;; 1415;;; truncate-file 1416;;; 1417 1418(with-test-prefix "truncate-file" 1419 1420 (pass-if-exception "flonum file" exception:wrong-type-arg 1421 (truncate-file 1.0 123)) 1422 1423 (pass-if-exception "frac file" exception:wrong-type-arg 1424 (truncate-file 7/3 123)) 1425 1426 (with-test-prefix "filename" 1427 1428 (pass-if-exception "flonum length" exception:wrong-type-arg 1429 (call-with-output-file (test-file) 1430 (lambda (port) 1431 (display "hello" port))) 1432 (truncate-file (test-file) 1.0)) 1433 1434 (pass-if "shorten" 1435 (call-with-output-file (test-file) 1436 (lambda (port) 1437 (display "hello" port))) 1438 (truncate-file (test-file) 1) 1439 (eqv? 1 (stat:size (stat (test-file))))) 1440 1441 (pass-if-exception "shorten to current pos" exception:miscellaneous-error 1442 (call-with-output-file (test-file) 1443 (lambda (port) 1444 (display "hello" port))) 1445 (truncate-file (test-file)))) 1446 1447 (with-test-prefix "file descriptor" 1448 1449 (pass-if "shorten" 1450 (call-with-output-file (test-file) 1451 (lambda (port) 1452 (display "hello" port))) 1453 (let ((fd (open-fdes (test-file) O_RDWR))) 1454 (truncate-file fd 1) 1455 (close-fdes fd)) 1456 (eqv? 1 (stat:size (stat (test-file))))) 1457 1458 (pass-if "shorten to current pos" 1459 (call-with-output-file (test-file) 1460 (lambda (port) 1461 (display "hello" port))) 1462 (let ((fd (open-fdes (test-file) O_RDWR))) 1463 (seek fd 1 SEEK_SET) 1464 (truncate-file fd) 1465 (close-fdes fd)) 1466 (eqv? 1 (stat:size (stat (test-file)))))) 1467 1468 (with-test-prefix "file port" 1469 1470 (pass-if "shorten" 1471 (call-with-output-file (test-file) 1472 (lambda (port) 1473 (display "hello" port))) 1474 (let ((port (open-file (test-file) "r+"))) 1475 (truncate-file port 1) 1476 (close-port port)) 1477 (eqv? 1 (stat:size (stat (test-file))))) 1478 1479 (pass-if "shorten to current pos" 1480 (call-with-output-file (test-file) 1481 (lambda (port) 1482 (display "hello" port))) 1483 (let ((port (open-file (test-file) "r+"))) 1484 (read-char port) 1485 (truncate-file port) 1486 (close-port port)) 1487 (eqv? 1 (stat:size (stat (test-file))))))) 1488 1489 1490;;;; testing read-delimited and friends 1491 1492(with-test-prefix "read-delimited!" 1493 (let ((c (make-string 20 #\!))) 1494 (call-with-input-string 1495 "defdef\nghighi\n" 1496 (lambda (port) 1497 1498 (read-delimited! "\n" c port 'concat) 1499 (pass-if "read-delimited! reads a first line" 1500 (string=? c "defdef\n!!!!!!!!!!!!!")) 1501 1502 (read-delimited! "\n" c port 'concat 3) 1503 (pass-if "read-delimited! reads a first line" 1504 (string=? c "defghighi\n!!!!!!!!!!")))))) 1505 1506 1507;;;; char-ready? 1508 1509(call-with-input-string 1510 "howdy" 1511 (lambda (port) 1512 (pass-if "char-ready? returns true on string port" 1513 (char-ready? port)))) 1514 1515;;; This segfaults on some versions of Guile. We really should run 1516;;; the tests in a subprocess... 1517 1518(call-with-input-string 1519 "howdy" 1520 (lambda (port) 1521 (with-input-from-port 1522 port 1523 (lambda () 1524 (pass-if "char-ready? returns true on string port as default port" 1525 (char-ready?)))))) 1526 1527 1528;;;; pending-eof behavior 1529 1530(with-test-prefix "pending EOF behavior" 1531 ;; Make a test port that will produce the given sequence. Each 1532 ;; element of 'lst' may be either a character or #f (which means EOF). 1533 (define (test-soft-port . lst) 1534 (make-soft-port 1535 (vector (lambda (c) #f) ; write char 1536 (lambda (s) #f) ; write string 1537 (lambda () #f) ; flush 1538 (lambda () ; read char 1539 (let ((c (car lst))) 1540 (set! lst (cdr lst)) 1541 c)) 1542 (lambda () #f)) ; close 1543 "rw")) 1544 1545 (define (call-with-port p proc) 1546 (dynamic-wind 1547 (lambda () #f) 1548 (lambda () (proc p)) 1549 (lambda () (close-port p)))) 1550 1551 (define (call-with-test-file str proc) 1552 (let ((filename (test-file))) 1553 (dynamic-wind 1554 (lambda () (call-with-output-file filename 1555 (lambda (p) (display str p)))) 1556 (lambda () (call-with-input-file filename proc)) 1557 (lambda () (delete-file (test-file)))))) 1558 1559 (pass-if "peek-char does not swallow EOF (soft port)" 1560 (call-with-port (test-soft-port #\a #f #\b) 1561 (lambda (p) 1562 (and (char=? #\a (peek-char p)) 1563 (char=? #\a (read-char p)) 1564 (eof-object? (peek-char p)) 1565 (eof-object? (read-char p)) 1566 (char=? #\b (peek-char p)) 1567 (char=? #\b (read-char p)))))) 1568 1569 (pass-if "unread clears pending EOF (soft port)" 1570 (call-with-port (test-soft-port #\a #f #\b) 1571 (lambda (p) 1572 (and (char=? #\a (read-char p)) 1573 (eof-object? (peek-char p)) 1574 (begin (unread-char #\u p) 1575 (char=? #\u (read-char p))))))) 1576 1577 (pass-if "unread clears pending EOF (string port)" 1578 (call-with-input-string "a" 1579 (lambda (p) 1580 (and (char=? #\a (read-char p)) 1581 (eof-object? (peek-char p)) 1582 (begin (unread-char #\u p) 1583 (char=? #\u (read-char p))))))) 1584 1585 (pass-if "unread clears pending EOF (file port)" 1586 (call-with-test-file 1587 "a" 1588 (lambda (p) 1589 (and (char=? #\a (read-char p)) 1590 (eof-object? (peek-char p)) 1591 (begin (unread-char #\u p) 1592 (char=? #\u (read-char p))))))) 1593 1594 (pass-if "seek clears pending EOF (string port)" 1595 (call-with-input-string "a" 1596 (lambda (p) 1597 (and (char=? #\a (read-char p)) 1598 (eof-object? (peek-char p)) 1599 (begin (seek p 0 SEEK_SET) 1600 (char=? #\a (read-char p))))))) 1601 1602 (pass-if "seek clears pending EOF (file port)" 1603 (call-with-test-file 1604 "a" 1605 (lambda (p) 1606 (and (char=? #\a (read-char p)) 1607 (eof-object? (peek-char p)) 1608 (begin (seek p 0 SEEK_SET) 1609 (char=? #\a (read-char p)))))))) 1610 1611 1612;;;; Close current-input-port, and make sure everyone can handle it. 1613 1614(with-test-prefix "closing current-input-port" 1615 (for-each (lambda (procedure name) 1616 (with-input-from-port 1617 (call-with-input-string "foo" (lambda (p) p)) 1618 (lambda () 1619 (close-port (current-input-port)) 1620 (pass-if-exception name 1621 exception:wrong-type-arg 1622 (procedure))))) 1623 (list read read-char read-line) 1624 '("read" "read-char" "read-line"))) 1625 1626 1627 1628(with-test-prefix "setvbuf" 1629 1630 (pass-if-exception "closed port" 1631 exception:wrong-type-arg 1632 (let ((port (open-input-file "/dev/null"))) 1633 (close-port port) 1634 (setvbuf port 'block))) 1635 1636 (pass-if-exception "string port" 1637 exception:wrong-type-arg 1638 (let ((port (open-input-string "Hey!"))) 1639 (close-port port) 1640 (setvbuf port 'block))) 1641 1642 (pass-if "line/column number preserved" 1643 ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's 1644 ;; line and/or column number. 1645 (call-with-output-file (test-file) 1646 (lambda (p) 1647 (display "This is GNU Guile.\nWelcome." p))) 1648 (call-with-input-file (test-file) 1649 (lambda (p) 1650 (and (eqv? #\T (read-char p)) 1651 (let ((line (port-line p)) 1652 (col (port-column p))) 1653 (and (= line 0) (= col 1) 1654 (begin 1655 (setvbuf p 'block 777) 1656 (let ((line* (port-line p)) 1657 (col* (port-column p))) 1658 (and (= line line*) 1659 (= col col*))))))))))) 1660 1661 1662 1663(pass-if-equal "unget-bytevector" 1664 #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203 1665 1 2 3 4 251 253 254 255) 1666 (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255)))) 1667 (unget-bytevector port #vu8(200 201 202 203)) 1668 (unget-bytevector port #vu8(20 21 22 23 24)) 1669 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4) 1670 (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2) 1671 (unget-bytevector port #vu8(10 11)) 1672 (get-bytevector-all port))) 1673 1674 1675 1676(with-test-prefix "unicode byte-order marks (BOMs)" 1677 1678 (define (bv-read-test* encoding bv proc) 1679 (let ((port (open-bytevector-input-port bv))) 1680 (set-port-encoding! port encoding) 1681 (proc port))) 1682 1683 (define (bv-read-test encoding bv) 1684 (bv-read-test* encoding bv read-string)) 1685 1686 (define (bv-write-test* encoding proc) 1687 (call-with-values 1688 (lambda () (open-bytevector-output-port)) 1689 (lambda (port get-bytevector) 1690 (set-port-encoding! port encoding) 1691 (proc port) 1692 (get-bytevector)))) 1693 1694 (define (bv-write-test encoding str) 1695 (bv-write-test* encoding 1696 (lambda (p) 1697 (display str p)))) 1698 1699 (pass-if-equal "BOM not discarded from Latin-1 stream" 1700 "\xEF\xBB\xBF\x61" 1701 (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61))) 1702 1703 (pass-if-equal "BOM not discarded from Latin-2 stream" 1704 "\u010F\u0165\u017C\x61" 1705 (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61))) 1706 1707 (pass-if-equal "BOM not discarded from UTF-16BE stream" 1708 "\uFEFF\x61" 1709 (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61))) 1710 1711 (pass-if-equal "BOM not discarded from UTF-16LE stream" 1712 "\uFEFF\x61" 1713 (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00))) 1714 1715 (pass-if-equal "BOM not discarded from UTF-32BE stream" 1716 "\uFEFF\x61" 1717 (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF 1718 #x00 #x00 #x00 #x61))) 1719 1720 (pass-if-equal "BOM not discarded from UTF-32LE stream" 1721 "\uFEFF\x61" 1722 (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00 1723 #x61 #x00 #x00 #x00))) 1724 1725 (pass-if-equal "BOM not written to UTF-8 stream" 1726 #vu8(#x61) 1727 (bv-write-test "UTF-8" "a")) 1728 1729 (pass-if-equal "BOM not written to UTF-16BE stream" 1730 #vu8(#x00 #x61) 1731 (bv-write-test "UTF-16BE" "a")) 1732 1733 (pass-if-equal "BOM not written to UTF-16LE stream" 1734 #vu8(#x61 #x00) 1735 (bv-write-test "UTF-16LE" "a")) 1736 1737 (pass-if-equal "BOM not written to UTF-32BE stream" 1738 #vu8(#x00 #x00 #x00 #x61) 1739 (bv-write-test "UTF-32BE" "a")) 1740 1741 (pass-if-equal "BOM not written to UTF-32LE stream" 1742 #vu8(#x61 #x00 #x00 #x00) 1743 (bv-write-test "UTF-32LE" "a")) 1744 1745 (pass-if "Don't read from the port unless user asks to" 1746 (let* ((p (make-soft-port 1747 (vector 1748 (lambda (c) #f) ; write char 1749 (lambda (s) #f) ; write string 1750 (lambda () #f) ; flush 1751 (lambda () (throw 'fail)) ; read char 1752 (lambda () #f)) 1753 "rw"))) 1754 (set-port-encoding! p "UTF-16") 1755 (display "abc" p) 1756 (set-port-encoding! p "UTF-32") 1757 (display "def" p) 1758 #t)) 1759 1760 ;; TODO: test that input and output streams are independent when 1761 ;; appropriate, and linked when appropriate. 1762 1763 (pass-if-equal "BOM discarded from start of UTF-8 stream" 1764 "a" 1765 (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61))) 1766 1767 (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0" 1768 '(#\a "a") 1769 (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61) 1770 (lambda (p) 1771 (let ((c (read-char p))) 1772 (seek p 0 SEEK_SET) 1773 (let ((s (read-string p))) 1774 (list c s)))))) 1775 1776 (pass-if-equal "Only one BOM discarded from start of UTF-8 stream" 1777 "\uFEFFa" 1778 (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61))) 1779 1780 (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0" 1781 "\uFEFFb" 1782 (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62) 1783 (lambda (p) 1784 (seek p 1 SEEK_SET) 1785 (read-string p)))) 1786 1787 (pass-if-equal "BOM not discarded unless at start of UTF-8 stream" 1788 "a\uFEFFb" 1789 (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62))) 1790 1791 (pass-if-equal "BOM (BE) written to start of UTF-16 stream" 1792 #vu8(#xFE #xFF #x00 #x61 #x00 #x62) 1793 (bv-write-test "UTF-16" "ab")) 1794 1795 (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!" 1796 #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64) 1797 (bv-write-test* "UTF-16" 1798 (lambda (p) 1799 (display "ab" p) 1800 (set-port-encoding! p "UTF-16") 1801 (display "cd" p)))) 1802 1803 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)" 1804 "a" 1805 (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61))) 1806 1807 (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0" 1808 '(#\a "a") 1809 (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61) 1810 (lambda (p) 1811 (let ((c (read-char p))) 1812 (seek p 0 SEEK_SET) 1813 (let ((s (read-string p))) 1814 (list c s)))))) 1815 1816 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)" 1817 "\uFEFFa" 1818 (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61))) 1819 1820 (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0" 1821 "\uFEFFa" 1822 (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61) 1823 (lambda (p) 1824 (seek p 2 SEEK_SET) 1825 (read-string p)))) 1826 1827 (pass-if-equal "BOM not discarded unless at start of UTF-16 stream" 1828 "a\uFEFFb" 1829 (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62))) 1830 1831 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)" 1832 "a" 1833 (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00))) 1834 1835 (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0" 1836 '(#\a "a") 1837 (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00) 1838 (lambda (p) 1839 (let ((c (read-char p))) 1840 (seek p 0 SEEK_SET) 1841 (let ((s (read-string p))) 1842 (list c s)))))) 1843 1844 (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)" 1845 "\uFEFFa" 1846 (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00))) 1847 1848 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)" 1849 "a" 1850 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF 1851 #x00 #x00 #x00 #x61))) 1852 1853 (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0" 1854 '(#\a "a") 1855 (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF 1856 #x00 #x00 #x00 #x61) 1857 (lambda (p) 1858 (let ((c (read-char p))) 1859 (seek p 0 SEEK_SET) 1860 (let ((s (read-string p))) 1861 (list c s)))))) 1862 1863 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)" 1864 "\uFEFFa" 1865 (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF 1866 #x00 #x00 #xFE #xFF 1867 #x00 #x00 #x00 #x61))) 1868 1869 (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0" 1870 "\uFEFFa" 1871 (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF 1872 #x00 #x00 #xFE #xFF 1873 #x00 #x00 #x00 #x61) 1874 (lambda (p) 1875 (seek p 4 SEEK_SET) 1876 (read-string p)))) 1877 1878 (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!" 1879 "ab" 1880 (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62) 1881 (lambda (p) 1882 (let ((a (read-char p))) 1883 (set-port-encoding! p "UTF-16") 1884 (string a (read-char p)))))) 1885 1886 (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!" 1887 "ab" 1888 (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00) 1889 (lambda (p) 1890 (let ((a (read-char p))) 1891 (set-port-encoding! p "UTF-16") 1892 (string a (read-char p)))))) 1893 1894 (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!" 1895 "ab" 1896 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 1897 #x00 #x00 #xFE #xFF 1898 #x00 #x00 #x00 #x62) 1899 (lambda (p) 1900 (let ((a (read-char p))) 1901 (set-port-encoding! p "UTF-32") 1902 (string a (read-char p)))))) 1903 1904 (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!" 1905 "ab" 1906 (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61 1907 #xFF #xFE #x00 #x00 1908 #x62 #x00 #x00 #x00) 1909 (lambda (p) 1910 (let ((a (read-char p))) 1911 (set-port-encoding! p "UTF-32") 1912 (string a (read-char p)))))) 1913 1914 (pass-if-equal "BOM not discarded unless at start of UTF-32 stream" 1915 "a\uFEFFb" 1916 (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61 1917 #x00 #x00 #xFE #xFF 1918 #x00 #x00 #x00 #x62))) 1919 1920 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)" 1921 "a" 1922 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 1923 #x61 #x00 #x00 #x00))) 1924 1925 (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0" 1926 '(#\a "a") 1927 (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00 1928 #x61 #x00 #x00 #x00) 1929 (lambda (p) 1930 (let ((c (read-char p))) 1931 (seek p 0 SEEK_SET) 1932 (let ((s (read-string p))) 1933 (list c s)))))) 1934 1935 (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)" 1936 "\uFEFFa" 1937 (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00 1938 #xFF #xFE #x00 #x00 1939 #x61 #x00 #x00 #x00)))) 1940 1941 1942 1943(define-syntax-rule (with-load-path path body ...) 1944 (let ((new path) 1945 (old %load-path)) 1946 (dynamic-wind 1947 (lambda () 1948 (set! %load-path new)) 1949 (lambda () 1950 body ...) 1951 (lambda () 1952 (set! %load-path old))))) 1953 1954(define %temporary-directory 1955 (string-append (or (getenv "TMPDIR") "/tmp") "/guile-ports-test." 1956 (number->string (getpid)))) 1957 1958(with-test-prefix "%file-port-name-canonicalization" 1959 1960 (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null" 1961 ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead 1962 ;; of "/dev/null". See 1963 ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html> 1964 ;; for a discussion. 1965 (with-load-path (cons "" (delete "/" %load-path)) 1966 (with-fluids ((%file-port-name-canonicalization 'relative)) 1967 (port-filename (open-input-file "/dev/null"))))) 1968 1969 (pass-if-equal "relative canonicalization with /" "dev/null" 1970 (with-load-path (cons "/" %load-path) 1971 (with-fluids ((%file-port-name-canonicalization 'relative)) 1972 (port-filename (open-input-file "/dev/null"))))) 1973 1974 (pass-if-equal "relative canonicalization with /dev/.." "dev/null" 1975 (with-load-path (cons "/dev/.." %load-path) 1976 (with-fluids ((%file-port-name-canonicalization 'relative)) 1977 (port-filename (open-input-file "/dev/null"))))) 1978 1979 (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm" 1980 (with-fluids ((%file-port-name-canonicalization 'relative)) 1981 (port-filename 1982 (open-input-file (%search-load-path "ice-9/q.scm"))))) 1983 1984 (pass-if-equal "relative canonicalization with common prefixes" 1985 "x.scm" 1986 1987 ;; In Guile up to 2.2.2, this would return "wrong/x.scm'. 1988 (let* ((dir1 (string-append %temporary-directory "/something")) 1989 (dir2 (string-append dir1 "-wrong"))) 1990 (with-load-path (append (list dir1 dir2) %load-path) 1991 (dynamic-wind 1992 (lambda () 1993 (mkdir %temporary-directory) 1994 (mkdir dir1) 1995 (mkdir dir2) 1996 (call-with-output-file (string-append dir2 "/x.scm") 1997 (const #t))) 1998 (lambda () 1999 (with-fluids ((%file-port-name-canonicalization 'relative)) 2000 (port-filename 2001 (open-input-file (string-append dir2 "/x.scm"))))) 2002 (lambda () 2003 (delete-file (string-append dir2 "/x.scm")) 2004 (rmdir dir2) 2005 (rmdir dir1) 2006 (rmdir %temporary-directory)))))) 2007 2008 (pass-if-equal "absolute canonicalization from ice-9" 2009 (canonicalize-path 2010 (string-append (assoc-ref %guile-build-info 'top_srcdir) 2011 "/module/ice-9/q.scm")) 2012 (with-fluids ((%file-port-name-canonicalization 'absolute)) 2013 (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))) 2014 2015(with-test-prefix "file name separators" 2016 2017 (pass-if "no backslash separators in Windows file names" 2018 ;; In Guile 2.0.11 and earlier, %load-path on Windows could 2019 ;; include file names with backslashes, and `getcwd' on Windows 2020 ;; would always return a directory name with backslashes. 2021 (or (not (file-name-separator? #\\)) 2022 (with-load-path (cons (getcwd) %load-path) 2023 (not (string-index (%search-load-path (basename (test-file))) 2024 #\\)))))) 2025 2026(delete-file (test-file)) 2027 2028;;; Local Variables: 2029;;; eval: (put 'test-decoding-error 'scheme-indent-function 3) 2030;;; eval: (put 'with-load-path 'scheme-indent-function 1) 2031;;; End: 2032