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