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