test-suite/tests/ports.test

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