test-suite/tests/ports.test

   1 ;;;; ports.test --- test suite for Guile I/O ports     -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
   3 ;;;;
   4 ;;;;    Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
   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-suite test-ports)
  21   :use-module (test-suite lib)
  22   :use-module (test-suite guile-test)
  23   :use-module (ice-9 popen)
  24   :use-module (ice-9 rdelim))
  25
  26 (define (display-line . args)
  27   (for-each display args)
  28   (newline))
  29
  30 (define (test-file)
  31   (data-file-name "ports-test.tmp"))
  32
  33 \f
  34 ;;;; Some general utilities for testing ports.
  35
  36 ;;; Make sure we are set up for 8-bit data
  37 (setbinary)
  38
  39 ;;; Read from PORT until EOF, and return the result as a string.
  40 (define (read-all port)
  41   (let loop ((chars '()))
  42     (let ((char (read-char port)))
  43       (if (eof-object? char)
  44           (list->string (reverse! chars))
  45           (loop (cons char chars))))))
  46
  47 (define (read-file filename)
  48   (let* ((port (open-input-file filename))
  49          (string (read-all port)))
  50     (close-port port)
  51     string))
  52
  53 \f
  54 ;;;; Normal file ports.
  55
  56 ;;; Write out an s-expression, and read it back.
  57 (let ((string '("From fairest creatures we desire increase,"
  58                 "That thereby beauty's rose might never die,"))
  59       (filename (test-file)))
  60   (let ((port (open-output-file filename)))
  61     (write string port)
  62     (close-port port))
  63   (let ((port (open-input-file filename)))
  64     (let ((in-string (read port)))
  65       (pass-if "file: write and read back list of strings"
  66                (equal? string in-string)))
  67     (close-port port))
  68   (delete-file filename))
  69
  70 ;;; Write out a string, and read it back a character at a time.
  71 (let ((string "This is a test string\nwith no newline at the end")
  72       (filename (test-file)))
  73   (let ((port (open-output-file filename)))
  74     (display string port)
  75     (close-port port))
  76   (let ((in-string (read-file filename)))
  77     (pass-if "file: write and read back characters"
  78              (equal? string in-string)))
  79   (delete-file filename))
  80
  81 ;;; Buffered input/output port with seeking.
  82 (let* ((filename (test-file))
  83        (port (open-file filename "w+")))
  84   (display "J'Accuse" port)
  85   (seek port -1 SEEK_CUR)
  86   (pass-if "file: r/w 1"
  87            (char=? (read-char port) #\e))
  88   (pass-if "file: r/w 2"
  89            (eof-object? (read-char port)))
  90   (seek port -1 SEEK_CUR)
  91   (write-char #\x port)
  92   (seek port 7 SEEK_SET)
  93   (pass-if "file: r/w 3"
  94            (char=? (read-char port) #\x))
  95   (seek port -2 SEEK_END)
  96   (pass-if "file: r/w 4"
  97            (char=? (read-char port) #\s))
  98   (close-port port)
  99   (delete-file filename))
 100
 101 ;;; Unbuffered input/output port with seeking.
 102 (let* ((filename (test-file))
 103        (port (open-file filename "w+0")))
 104   (display "J'Accuse" port)
 105   (seek port -1 SEEK_CUR)
 106   (pass-if "file: ub r/w 1"
 107            (char=? (read-char port) #\e))
 108   (pass-if "file: ub r/w 2"
 109            (eof-object? (read-char port)))
 110   (seek port -1 SEEK_CUR)
 111   (write-char #\x port)
 112   (seek port 7 SEEK_SET)
 113   (pass-if "file: ub r/w 3"
 114            (char=? (read-char port) #\x))
 115   (seek port -2 SEEK_END)
 116   (pass-if "file: ub r/w 4"
 117            (char=? (read-char port) #\s))
 118   (close-port port)
 119   (delete-file filename))
 120
 121 ;;; Buffered output-only and input-only ports with seeking.
 122 (let* ((filename (test-file))
 123        (port (open-output-file filename)))
 124   (display "J'Accuse" port)
 125   (pass-if "file: out tell"
 126            (= (seek port 0 SEEK_CUR) 8))
 127   (seek port -1 SEEK_CUR)
 128   (write-char #\x port)
 129   (close-port port)
 130   (let ((iport (open-input-file filename)))
 131     (pass-if "file: in tell 0"
 132              (= (seek iport 0 SEEK_CUR) 0))
 133     (read-char iport)
 134     (pass-if "file: in tell 1"
 135              (= (seek iport 0 SEEK_CUR) 1))
 136     (unread-char #\z iport)
 137     (pass-if "file: in tell 0 after unread"
 138              (= (seek iport 0 SEEK_CUR) 0))
 139     (pass-if "file: unread char still there"
 140              (char=? (read-char iport) #\z))
 141     (seek iport 7 SEEK_SET)
 142     (pass-if "file: in last char"
 143              (char=? (read-char iport) #\x))
 144     (close-port iport))
 145   (delete-file filename))
 146
 147 ;;; unusual characters.
 148 (let* ((filename (test-file))
 149        (port (open-output-file filename)))
 150   (display (string #\nul (integer->char 255) (integer->char 128)
 151                    #\nul) port)
 152   (close-port port)
 153   (let* ((port (open-input-file filename))
 154          (line (read-line port)))
 155     (pass-if "file: read back NUL 1"
 156              (char=? (string-ref line 0) #\nul))
 157     (pass-if "file: read back 255"
 158              (char=? (string-ref line 1) (integer->char 255)))
 159     (pass-if "file: read back 128"
 160              (char=? (string-ref line 2) (integer->char 128)))
 161     (pass-if "file: read back NUL 2"
 162              (char=? (string-ref line 3) #\nul))
 163     (pass-if "file: EOF"
 164              (eof-object? (read-char port)))
 165     (close-port port))
 166   (delete-file filename))
 167
 168 ;;; line buffering mode.
 169 (let* ((filename (test-file))
 170        (port (open-file filename "wl"))
 171        (test-string "one line more or less"))
 172   (write-line test-string port)
 173   (let* ((in-port (open-input-file filename))
 174          (line (read-line in-port)))
 175     (close-port in-port)
 176     (close-port port)
 177     (pass-if "file: line buffering"
 178              (string=? line test-string)))
 179   (delete-file filename))
 180
 181 ;;; ungetting characters and strings.
 182 (with-input-from-string "walk on the moon\nmoon"
 183                         (lambda ()
 184                           (read-char)
 185                           (unread-char #\a (current-input-port))
 186                           (pass-if "unread-char"
 187                                    (char=? (read-char) #\a))
 188                           (read-line)
 189                           (let ((replacenoid "chicken enchilada"))
 190                             (unread-char #\newline (current-input-port))
 191                             (unread-string replacenoid (current-input-port))
 192                             (pass-if "unread-string"
 193                                      (string=? (read-line) replacenoid)))
 194                           (pass-if "unread residue"
 195                                    (string=? (read-line) "moon"))))
 196
 197 ;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
 198 ;;; the reading end.  try to read a byte: should get EAGAIN or
 199 ;;; EWOULDBLOCK error.
 200 (let* ((p (pipe))
 201        (r (car p)))
 202   (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
 203   (pass-if "non-blocking-I/O"
 204            (catch 'system-error
 205                   (lambda () (read-char r) #f)
 206                   (lambda (key . args)
 207                     (and (eq? key 'system-error)
 208                          (let ((errno (car (list-ref args 3))))
 209                            (or (= errno EAGAIN)
 210                                (= errno EWOULDBLOCK))))))))
 211
 212 \f
 213 ;;;; Pipe (popen) ports.
 214
 215 ;;; Run a command, and read its output.
 216 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
 217        (in-string (read-all pipe)))
 218   (close-pipe pipe)
 219   (pass-if "pipe: read"
 220            (equal? in-string "Howdy there, partner!\n")))
 221
 222 ;;; Run a command, send some output to it, and see if it worked.
 223 (let* ((filename (test-file))
 224        (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
 225   (display "Now Jimmy lives on a mushroom cloud\n" pipe)
 226   (display "Mommy, why does everybody have a bomb?\n" pipe)
 227   (close-pipe pipe)
 228   (let ((in-string (read-file filename)))
 229     (pass-if "pipe: write"
 230              (equal? in-string "Mommy, why does everybody have a bomb?\n")))
 231   (delete-file filename))
 232
 233 \f
 234 ;;;; Void ports.  These are so trivial we don't test them.
 235
 236 \f
 237 ;;;; String ports.
 238
 239 (with-test-prefix "string ports"
 240
 241   ;; Write text to a string port.
 242   (let* ((string "Howdy there, partner!")
 243          (in-string (call-with-output-string
 244                      (lambda (port)
 245                        (display string port)
 246                        (newline port)))))
 247     (pass-if "display text"
 248              (equal? in-string (string-append string "\n"))))
 249
 250   ;; Write an s-expression to a string port.
 251   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
 252          (in-sexpr
 253           (call-with-input-string (call-with-output-string
 254                                    (lambda (port)
 255                                      (write sexpr port)))
 256                                   read)))
 257     (pass-if "write/read sexpr"
 258              (equal? in-sexpr sexpr)))
 259
 260   ;; seeking and unreading from an input string.
 261   (let ((text "that text didn't look random to me"))
 262     (call-with-input-string text
 263                             (lambda (p)
 264                               (pass-if "input tell 0"
 265                                        (= (seek p 0 SEEK_CUR) 0))
 266                               (read-char p)
 267                               (pass-if "input tell 1"
 268                                        (= (seek p 0 SEEK_CUR) 1))
 269                               (unread-char #\x p)
 270                               (pass-if "input tell back to 0"
 271                                        (= (seek p 0 SEEK_CUR) 0))
 272                               (pass-if "input ungetted char"
 273                                        (char=? (read-char p) #\x))
 274                               (seek p 0 SEEK_END)
 275                               (pass-if "input seek to end"
 276                                        (= (seek p 0 SEEK_CUR)
 277                                           (string-length text)))
 278                               (unread-char #\x p)
 279                               (pass-if "input seek to beginning"
 280                                        (= (seek p 0 SEEK_SET) 0))
 281                               (pass-if "input reread first char"
 282                                        (char=? (read-char p)
 283                                                (string-ref text 0))))))
 284
 285   ;; seeking an output string.
 286   (let* ((text (string-copy "123456789"))
 287          (len (string-length text))
 288          (result (call-with-output-string
 289                   (lambda (p)
 290                     (pass-if "output tell 0"
 291                              (= (seek p 0 SEEK_CUR) 0))
 292                     (display text p)
 293                     (pass-if "output tell end"
 294                              (= (seek p 0 SEEK_CUR) len))
 295                     (pass-if "output seek to beginning"
 296                              (= (seek p 0 SEEK_SET) 0))
 297                     (write-char #\a p)
 298                     (seek p -1 SEEK_END)
 299                     (pass-if "output seek to last char"
 300                              (= (seek p 0 SEEK_CUR)
 301                                 (- len 1)))
 302                     (write-char #\b p)))))
 303     (string-set! text 0 #\a)
 304     (string-set! text (- len 1) #\b)
 305     (pass-if "output check"
 306              (string=? text result))))
 307
 308 (with-test-prefix "call-with-output-string"
 309
 310   ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
 311   ;; occur.
 312   (pass-if-exception "proc closes port" exception:wrong-type-arg
 313     (call-with-output-string close-port)))
 314
 315
 316 \f
 317 ;;;; Soft ports.  No tests implemented yet.
 318
 319 \f
 320 ;;;; Generic operations across all port types.
 321
 322 (let ((port-loop-temp (test-file)))
 323
 324   ;; Return a list of input ports that all return the same text.
 325   ;; We map tests over this list.
 326   (define (input-port-list text)
 327
 328     ;; Create a text file some of the ports will use.
 329     (let ((out-port (open-output-file port-loop-temp)))
 330       (display text out-port)
 331       (close-port out-port))
 332
 333     (list (open-input-file port-loop-temp)
 334           (open-input-pipe (string-append "cat " port-loop-temp))
 335           (call-with-input-string text (lambda (x) x))
 336           ;; We don't test soft ports at the moment.
 337           ))
 338
 339   (define port-list-names '("file" "pipe" "string"))
 340
 341   ;; Test the line counter.
 342   (define (test-line-counter text second-line final-column)
 343     (with-test-prefix "line counter"
 344       (let ((ports (input-port-list text)))
 345         (for-each
 346          (lambda (port port-name)
 347            (with-test-prefix port-name
 348              (pass-if "at beginning of input"
 349                       (= (port-line port) 0))
 350              (pass-if "read first character"
 351                       (eqv? (read-char port) #\x))
 352              (pass-if "after reading one character"
 353                       (= (port-line port) 0))
 354              (pass-if "read first newline"
 355                       (eqv? (read-char port) #\newline))
 356              (pass-if "after reading first newline char"
 357                       (= (port-line port) 1))
 358              (pass-if "second line read correctly"
 359                       (equal? (read-line port) second-line))
 360              (pass-if "read-line increments line number"
 361                       (= (port-line port) 2))
 362              (pass-if "read-line returns EOF"
 363                       (let loop ((i 0))
 364                         (cond
 365                          ((eof-object? (read-line port)) #t)
 366                          ((> i 20) #f)
 367                          (else (loop (+ i 1))))))
 368              (pass-if "line count is 5 at EOF"
 369                       (= (port-line port) 5))
 370              (pass-if "column is correct at EOF"
 371                       (= (port-column port) final-column))))
 372          ports port-list-names)
 373         (for-each close-port ports)
 374         (delete-file port-loop-temp))))
 375
 376   (with-test-prefix "newline"
 377     (test-line-counter
 378      (string-append "x\n"
 379                     "He who receives an idea from me, receives instruction\n"
 380                     "himself without lessening mine; as he who lights his\n"
 381                     "taper at mine, receives light without darkening me.\n"
 382                     "  --- Thomas Jefferson\n")
 383      "He who receives an idea from me, receives instruction"
 384      0))
 385
 386   (with-test-prefix "no newline"
 387     (test-line-counter
 388      (string-append "x\n"
 389                     "He who receives an idea from me, receives instruction\n"
 390                     "himself without lessening mine; as he who lights his\n"
 391                     "taper at mine, receives light without darkening me.\n"
 392                     "  --- Thomas Jefferson\n"
 393                     "no newline here")
 394      "He who receives an idea from me, receives instruction"
 395      15)))
 396
 397 ;; Test port-line and port-column for output ports
 398
 399 (define (test-output-line-counter text final-column)
 400   (with-test-prefix "port-line and port-column for output ports"
 401     (let ((port (open-output-string)))
 402       (pass-if "at beginning of input"
 403                (and (= (port-line port) 0)
 404                     (= (port-column port) 0)))
 405       (write-char #\x port)
 406       (pass-if "after writing one character"
 407                (and (= (port-line port) 0)
 408                     (= (port-column port) 1)))
 409       (write-char #\newline port)
 410       (pass-if "after writing first newline char"
 411                (and (= (port-line port) 1)
 412                     (= (port-column port) 0)))
 413       (display text port)
 414       (pass-if "line count is 5 at end"
 415                (= (port-line port) 5))
 416       (pass-if "column is correct at end"
 417                (= (port-column port) final-column)))))
 418
 419 (test-output-line-counter
 420  (string-append "He who receives an idea from me, receives instruction\n"
 421                 "himself without lessening mine; as he who lights his\n"
 422                 "taper at mine, receives light without darkening me.\n"
 423                 "  --- Thomas Jefferson\n"
 424                 "no newline here")
 425  15)
 426
 427 (with-test-prefix "port-column"
 428
 429   (with-test-prefix "output"
 430
 431     (pass-if "x"
 432       (let ((port (open-output-string)))
 433         (display "x" port)
 434         (= 1 (port-column port))))
 435
 436     (pass-if "\\a"
 437       (let ((port (open-output-string)))
 438         (display "\a" port)
 439         (= 0 (port-column port))))
 440
 441     (pass-if "x\\a"
 442       (let ((port (open-output-string)))
 443         (display "x\a" port)
 444         (= 1 (port-column port))))
 445
 446     (pass-if "\\x08 backspace"
 447       (let ((port (open-output-string)))
 448         (display "\x08" port)
 449         (= 0 (port-column port))))
 450
 451     (pass-if "x\\x08 backspace"
 452       (let ((port (open-output-string)))
 453         (display "x\x08" port)
 454         (= 0 (port-column port))))
 455
 456     (pass-if "\\n"
 457       (let ((port (open-output-string)))
 458         (display "\n" port)
 459         (= 0 (port-column port))))
 460
 461     (pass-if "x\\n"
 462       (let ((port (open-output-string)))
 463         (display "x\n" port)
 464         (= 0 (port-column port))))
 465
 466     (pass-if "\\r"
 467       (let ((port (open-output-string)))
 468         (display "\r" port)
 469         (= 0 (port-column port))))
 470
 471     (pass-if "x\\r"
 472       (let ((port (open-output-string)))
 473         (display "x\r" port)
 474         (= 0 (port-column port))))
 475
 476     (pass-if "\\t"
 477       (let ((port (open-output-string)))
 478         (display "\t" port)
 479         (= 8 (port-column port))))
 480
 481     (pass-if "x\\t"
 482       (let ((port (open-output-string)))
 483         (display "x\t" port)
 484         (= 8 (port-column port)))))
 485
 486   (with-test-prefix "input"
 487
 488     (pass-if "x"
 489       (let ((port (open-input-string "x")))
 490         (while (not (eof-object? (read-char port))))
 491         (= 1 (port-column port))))
 492
 493     (pass-if "\\a"
 494       (let ((port (open-input-string "\a")))
 495         (while (not (eof-object? (read-char port))))
 496         (= 0 (port-column port))))
 497
 498     (pass-if "x\\a"
 499       (let ((port (open-input-string "x\a")))
 500         (while (not (eof-object? (read-char port))))
 501         (= 1 (port-column port))))
 502
 503     (pass-if "\\x08 backspace"
 504       (let ((port (open-input-string "\x08")))
 505         (while (not (eof-object? (read-char port))))
 506         (= 0 (port-column port))))
 507
 508     (pass-if "x\\x08 backspace"
 509       (let ((port (open-input-string "x\x08")))
 510         (while (not (eof-object? (read-char port))))
 511         (= 0 (port-column port))))
 512
 513     (pass-if "\\n"
 514       (let ((port (open-input-string "\n")))
 515         (while (not (eof-object? (read-char port))))
 516         (= 0 (port-column port))))
 517
 518     (pass-if "x\\n"
 519       (let ((port (open-input-string "x\n")))
 520         (while (not (eof-object? (read-char port))))
 521         (= 0 (port-column port))))
 522
 523     (pass-if "\\r"
 524       (let ((port (open-input-string "\r")))
 525         (while (not (eof-object? (read-char port))))
 526         (= 0 (port-column port))))
 527
 528     (pass-if "x\\r"
 529       (let ((port (open-input-string "x\r")))
 530         (while (not (eof-object? (read-char port))))
 531         (= 0 (port-column port))))
 532
 533     (pass-if "\\t"
 534       (let ((port (open-input-string "\t")))
 535         (while (not (eof-object? (read-char port))))
 536         (= 8 (port-column port))))
 537
 538     (pass-if "x\\t"
 539       (let ((port (open-input-string "x\t")))
 540         (while (not (eof-object? (read-char port))))
 541         (= 8 (port-column port))))))
 542
 543 (with-test-prefix "port-line"
 544
 545   ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
 546   ;; scm_t_port actually holds a long; this restricted the range on 64-bit
 547   ;; systems
 548   (pass-if "set most-positive-fixnum/2"
 549     (let ((n    (quotient most-positive-fixnum 2))
 550           (port (open-output-string)))
 551       (set-port-line! port n)
 552       (eqv? n (port-line port)))))
 553
 554 ;;;
 555 ;;; port-for-each
 556 ;;;
 557
 558 (with-test-prefix "port-for-each"
 559
 560   ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
 561   ;; its iterator func if a port was inaccessible in the last gc mark but
 562   ;; the lazy sweeping has not yet reached it to remove it from the port
 563   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
 564   ;; tricky, but the following code made it happen in 1.8.2.
 565   (pass-if "passing freed cell"
 566     (let ((lst '()))
 567       ;; clear out the heap
 568       (gc) (gc) (gc)
 569       ;; allocate cells so the opened ports aren't at the start of the heap
 570       (make-list 1000)
 571       (open-input-file "/dev/null")
 572       (make-list 1000)
 573       (open-input-file "/dev/null")
 574       ;; this gc leaves the above ports unmarked, ie. inaccessible
 575       (gc)
 576       ;; but they're still in the port table, so this sees them
 577       (port-for-each (lambda (port)
 578                        (set! lst (cons port lst))))
 579       ;; this forces completion of the sweeping
 580       (gc) (gc) (gc)
 581       ;; and (if the bug is present) the cells accumulated in LST are now
 582       ;; freed cells, which give #f from `port?'
 583       (not (memq #f (map port? lst))))))
 584
 585 (with-test-prefix
 586  "fdes->port"
 587  (pass-if "fdes->ports finds port"
 588           (let ((port (open-file (test-file) "w")))
 589
 590             (not (not (memq port (fdes->ports (port->fdes port))))))))
 591
 592 ;;;
 593 ;;; seek
 594 ;;;
 595
 596 (with-test-prefix "seek"
 597
 598   (with-test-prefix "file port"
 599
 600     (pass-if "SEEK_CUR"
 601       (call-with-output-file (test-file)
 602         (lambda (port)
 603           (display "abcde" port)))
 604       (let ((port (open-file (test-file) "r")))
 605         (read-char port)
 606         (seek port 2 SEEK_CUR)
 607         (eqv? #\d (read-char port))))
 608
 609     (pass-if "SEEK_SET"
 610       (call-with-output-file (test-file)
 611         (lambda (port)
 612           (display "abcde" port)))
 613       (let ((port (open-file (test-file) "r")))
 614         (read-char port)
 615         (seek port 3 SEEK_SET)
 616         (eqv? #\d (read-char port))))
 617
 618     (pass-if "SEEK_END"
 619       (call-with-output-file (test-file)
 620         (lambda (port)
 621           (display "abcde" port)))
 622       (let ((port (open-file (test-file) "r")))
 623         (read-char port)
 624         (seek port -2 SEEK_END)
 625         (eqv? #\d (read-char port))))))
 626
 627 ;;;
 628 ;;; truncate-file
 629 ;;;
 630
 631 (with-test-prefix "truncate-file"
 632
 633   (pass-if-exception "flonum file" exception:wrong-type-arg
 634     (truncate-file 1.0 123))
 635
 636   (pass-if-exception "frac file" exception:wrong-type-arg
 637     (truncate-file 7/3 123))
 638
 639   (with-test-prefix "filename"
 640
 641     (pass-if-exception "flonum length" exception:wrong-type-arg
 642       (call-with-output-file (test-file)
 643         (lambda (port)
 644           (display "hello" port)))
 645       (truncate-file (test-file) 1.0))
 646
 647     (pass-if "shorten"
 648       (call-with-output-file (test-file)
 649         (lambda (port)
 650           (display "hello" port)))
 651       (truncate-file (test-file) 1)
 652       (eqv? 1 (stat:size (stat (test-file)))))
 653
 654     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
 655       (call-with-output-file (test-file)
 656         (lambda (port)
 657           (display "hello" port)))
 658       (truncate-file (test-file))))
 659
 660   (with-test-prefix "file descriptor"
 661
 662     (pass-if "shorten"
 663       (call-with-output-file (test-file)
 664         (lambda (port)
 665           (display "hello" port)))
 666       (let ((fd (open-fdes (test-file) O_RDWR)))
 667         (truncate-file fd 1)
 668         (close-fdes fd))
 669       (eqv? 1 (stat:size (stat (test-file)))))
 670
 671     (pass-if "shorten to current pos"
 672       (call-with-output-file (test-file)
 673         (lambda (port)
 674           (display "hello" port)))
 675       (let ((fd (open-fdes (test-file) O_RDWR)))
 676         (seek fd 1 SEEK_SET)
 677         (truncate-file fd)
 678         (close-fdes fd))
 679       (eqv? 1 (stat:size (stat (test-file))))))
 680
 681   (with-test-prefix "file port"
 682
 683     (pass-if "shorten"
 684       (call-with-output-file (test-file)
 685         (lambda (port)
 686           (display "hello" port)))
 687       (let ((port (open-file (test-file) "r+")))
 688         (truncate-file port 1))
 689       (eqv? 1 (stat:size (stat (test-file)))))
 690
 691     (pass-if "shorten to current pos"
 692       (call-with-output-file (test-file)
 693         (lambda (port)
 694           (display "hello" port)))
 695       (let ((port (open-file (test-file) "r+")))
 696         (read-char port)
 697         (truncate-file port))
 698       (eqv? 1 (stat:size (stat (test-file)))))))
 699
 700
 701 ;;;; testing read-delimited and friends
 702
 703 (with-test-prefix "read-delimited!"
 704   (let ((c (make-string 20 #\!)))
 705     (call-with-input-string
 706      "defdef\nghighi\n"
 707      (lambda (port)
 708
 709        (read-delimited! "\n" c port 'concat)
 710        (pass-if "read-delimited! reads a first line"
 711                 (string=? c "defdef\n!!!!!!!!!!!!!"))
 712
 713        (read-delimited! "\n" c port 'concat 3)
 714        (pass-if "read-delimited! reads a first line"
 715                 (string=? c "defghighi\n!!!!!!!!!!"))))))
 716
 717 \f
 718 ;;;; char-ready?
 719
 720 (call-with-input-string
 721  "howdy"
 722  (lambda (port)
 723    (pass-if "char-ready? returns true on string port"
 724             (char-ready? port))))
 725
 726 ;;; This segfaults on some versions of Guile.  We really should run
 727 ;;; the tests in a subprocess...
 728
 729 (call-with-input-string
 730  "howdy"
 731  (lambda (port)
 732    (with-input-from-port
 733        port
 734      (lambda ()
 735        (pass-if "char-ready? returns true on string port as default port"
 736                 (char-ready?))))))
 737
 738 \f
 739 ;;;; Close current-input-port, and make sure everyone can handle it.
 740
 741 (with-test-prefix "closing current-input-port"
 742   (for-each (lambda (procedure name)
 743               (with-input-from-port
 744                   (call-with-input-string "foo" (lambda (p) p))
 745                 (lambda ()
 746                   (close-port (current-input-port))
 747                   (pass-if-exception name
 748                     exception:wrong-type-arg
 749                     (procedure)))))
 750             (list read read-char read-line)
 751             '("read" "read-char" "read-line")))
 752
 753 (delete-file (test-file))