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