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   (pass-if "peek-char [latin-1]"
 428     (let ((p (with-fluids ((%default-port-encoding #f))
 429                (open-input-string "hello, world"))))
 430       (and (char=? (peek-char p) #\h)
 431            (char=? (peek-char p) #\h)
 432            (char=? (peek-char p) #\h)
 433            (= (port-line p) 0)
 434            (= (port-column p) 0))))
 435
 436   (pass-if "peek-char [utf-8]"
 437     (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
 438                (open-input-string "안녕하세요"))))
 439       (and (char=? (peek-char p) #\안)
 440            (char=? (peek-char p) #\안)
 441            (char=? (peek-char p) #\안)
 442            (= (port-line p) 0)
 443            (= (port-column p) 0)))))
 444
 445 (with-test-prefix "call-with-output-string"
 446
 447   ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
 448   ;; occur.
 449   (pass-if-exception "proc closes port" exception:wrong-type-arg
 450     (call-with-output-string close-port)))
 451
 452
 453 \f
 454 ;;;; Soft ports.  No tests implemented yet.
 455
 456 \f
 457 ;;;; Generic operations across all port types.
 458
 459 (let ((port-loop-temp (test-file)))
 460
 461   ;; Return a list of input ports that all return the same text.
 462   ;; We map tests over this list.
 463   (define (input-port-list text)
 464
 465     ;; Create a text file some of the ports will use.
 466     (let ((out-port (open-output-file port-loop-temp)))
 467       (display text out-port)
 468       (close-port out-port))
 469
 470     (list (open-input-file port-loop-temp)
 471           (open-input-pipe (string-append "cat " port-loop-temp))
 472           (call-with-input-string text (lambda (x) x))
 473           ;; We don't test soft ports at the moment.
 474           ))
 475
 476   (define port-list-names '("file" "pipe" "string"))
 477
 478   ;; Test the line counter.
 479   (define (test-line-counter text second-line final-column)
 480     (with-test-prefix "line counter"
 481       (let ((ports (input-port-list text)))
 482         (for-each
 483          (lambda (port port-name)
 484            (with-test-prefix port-name
 485              (pass-if "at beginning of input"
 486                       (= (port-line port) 0))
 487              (pass-if "read first character"
 488                       (eqv? (read-char port) #\x))
 489              (pass-if "after reading one character"
 490                       (= (port-line port) 0))
 491              (pass-if "read first newline"
 492                       (eqv? (read-char port) #\newline))
 493              (pass-if "after reading first newline char"
 494                       (= (port-line port) 1))
 495              (pass-if "second line read correctly"
 496                       (equal? (read-line port) second-line))
 497              (pass-if "read-line increments line number"
 498                       (= (port-line port) 2))
 499              (pass-if "read-line returns EOF"
 500                       (let loop ((i 0))
 501                         (cond
 502                          ((eof-object? (read-line port)) #t)
 503                          ((> i 20) #f)
 504                          (else (loop (+ i 1))))))
 505              (pass-if "line count is 5 at EOF"
 506                       (= (port-line port) 5))
 507              (pass-if "column is correct at EOF"
 508                       (= (port-column port) final-column))))
 509          ports port-list-names)
 510         (for-each close-port ports)
 511         (delete-file port-loop-temp))))
 512
 513   (with-test-prefix "newline"
 514     (test-line-counter
 515      (string-append "x\n"
 516                     "He who receives an idea from me, receives instruction\n"
 517                     "himself without lessening mine; as he who lights his\n"
 518                     "taper at mine, receives light without darkening me.\n"
 519                     "  --- Thomas Jefferson\n")
 520      "He who receives an idea from me, receives instruction"
 521      0))
 522
 523   (with-test-prefix "no newline"
 524     (test-line-counter
 525      (string-append "x\n"
 526                     "He who receives an idea from me, receives instruction\n"
 527                     "himself without lessening mine; as he who lights his\n"
 528                     "taper at mine, receives light without darkening me.\n"
 529                     "  --- Thomas Jefferson\n"
 530                     "no newline here")
 531      "He who receives an idea from me, receives instruction"
 532      15)))
 533
 534 ;; Test port-line and port-column for output ports
 535
 536 (define (test-output-line-counter text final-column)
 537   (with-test-prefix "port-line and port-column for output ports"
 538     (let ((port (open-output-string)))
 539       (pass-if "at beginning of input"
 540                (and (= (port-line port) 0)
 541                     (= (port-column port) 0)))
 542       (write-char #\x port)
 543       (pass-if "after writing one character"
 544                (and (= (port-line port) 0)
 545                     (= (port-column port) 1)))
 546       (write-char #\newline port)
 547       (pass-if "after writing first newline char"
 548                (and (= (port-line port) 1)
 549                     (= (port-column port) 0)))
 550       (display text port)
 551       (pass-if "line count is 5 at end"
 552                (= (port-line port) 5))
 553       (pass-if "column is correct at end"
 554                (= (port-column port) final-column)))))
 555
 556 (test-output-line-counter
 557  (string-append "He who receives an idea from me, receives instruction\n"
 558                 "himself without lessening mine; as he who lights his\n"
 559                 "taper at mine, receives light without darkening me.\n"
 560                 "  --- Thomas Jefferson\n"
 561                 "no newline here")
 562  15)
 563
 564 (with-test-prefix "port-column"
 565
 566   (with-test-prefix "output"
 567
 568     (pass-if "x"
 569       (let ((port (open-output-string)))
 570         (display "x" port)
 571         (= 1 (port-column port))))
 572
 573     (pass-if "\\a"
 574       (let ((port (open-output-string)))
 575         (display "\a" port)
 576         (= 0 (port-column port))))
 577
 578     (pass-if "x\\a"
 579       (let ((port (open-output-string)))
 580         (display "x\a" port)
 581         (= 1 (port-column port))))
 582
 583     (pass-if "\\x08 backspace"
 584       (let ((port (open-output-string)))
 585         (display "\x08" port)
 586         (= 0 (port-column port))))
 587
 588     (pass-if "x\\x08 backspace"
 589       (let ((port (open-output-string)))
 590         (display "x\x08" port)
 591         (= 0 (port-column port))))
 592
 593     (pass-if "\\n"
 594       (let ((port (open-output-string)))
 595         (display "\n" port)
 596         (= 0 (port-column port))))
 597
 598     (pass-if "x\\n"
 599       (let ((port (open-output-string)))
 600         (display "x\n" port)
 601         (= 0 (port-column port))))
 602
 603     (pass-if "\\r"
 604       (let ((port (open-output-string)))
 605         (display "\r" port)
 606         (= 0 (port-column port))))
 607
 608     (pass-if "x\\r"
 609       (let ((port (open-output-string)))
 610         (display "x\r" port)
 611         (= 0 (port-column port))))
 612
 613     (pass-if "\\t"
 614       (let ((port (open-output-string)))
 615         (display "\t" port)
 616         (= 8 (port-column port))))
 617
 618     (pass-if "x\\t"
 619       (let ((port (open-output-string)))
 620         (display "x\t" port)
 621         (= 8 (port-column port)))))
 622
 623   (with-test-prefix "input"
 624
 625     (pass-if "x"
 626       (let ((port (open-input-string "x")))
 627         (while (not (eof-object? (read-char port))))
 628         (= 1 (port-column port))))
 629
 630     (pass-if "\\a"
 631       (let ((port (open-input-string "\a")))
 632         (while (not (eof-object? (read-char port))))
 633         (= 0 (port-column port))))
 634
 635     (pass-if "x\\a"
 636       (let ((port (open-input-string "x\a")))
 637         (while (not (eof-object? (read-char port))))
 638         (= 1 (port-column port))))
 639
 640     (pass-if "\\x08 backspace"
 641       (let ((port (open-input-string "\x08")))
 642         (while (not (eof-object? (read-char port))))
 643         (= 0 (port-column port))))
 644
 645     (pass-if "x\\x08 backspace"
 646       (let ((port (open-input-string "x\x08")))
 647         (while (not (eof-object? (read-char port))))
 648         (= 0 (port-column port))))
 649
 650     (pass-if "\\n"
 651       (let ((port (open-input-string "\n")))
 652         (while (not (eof-object? (read-char port))))
 653         (= 0 (port-column port))))
 654
 655     (pass-if "x\\n"
 656       (let ((port (open-input-string "x\n")))
 657         (while (not (eof-object? (read-char port))))
 658         (= 0 (port-column port))))
 659
 660     (pass-if "\\r"
 661       (let ((port (open-input-string "\r")))
 662         (while (not (eof-object? (read-char port))))
 663         (= 0 (port-column port))))
 664
 665     (pass-if "x\\r"
 666       (let ((port (open-input-string "x\r")))
 667         (while (not (eof-object? (read-char port))))
 668         (= 0 (port-column port))))
 669
 670     (pass-if "\\t"
 671       (let ((port (open-input-string "\t")))
 672         (while (not (eof-object? (read-char port))))
 673         (= 8 (port-column port))))
 674
 675     (pass-if "x\\t"
 676       (let ((port (open-input-string "x\t")))
 677         (while (not (eof-object? (read-char port))))
 678         (= 8 (port-column port))))))
 679
 680 (with-test-prefix "port-line"
 681
 682   ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
 683   ;; scm_t_port actually holds a long; this restricted the range on 64-bit
 684   ;; systems
 685   (pass-if "set most-positive-fixnum/2"
 686     (let ((n    (quotient most-positive-fixnum 2))
 687           (port (open-output-string)))
 688       (set-port-line! port n)
 689       (eqv? n (port-line port)))))
 690
 691 ;;;
 692 ;;; port-for-each
 693 ;;;
 694
 695 (with-test-prefix "port-for-each"
 696
 697   ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
 698   ;; its iterator func if a port was inaccessible in the last gc mark but
 699   ;; the lazy sweeping has not yet reached it to remove it from the port
 700   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
 701   ;; tricky, but the following code made it happen in 1.8.2.
 702   (pass-if "passing freed cell"
 703     (let ((lst '()))
 704       ;; clear out the heap
 705       (gc) (gc) (gc)
 706       ;; allocate cells so the opened ports aren't at the start of the heap
 707       (make-list 1000)
 708       (open-input-file "/dev/null")
 709       (make-list 1000)
 710       (open-input-file "/dev/null")
 711       ;; this gc leaves the above ports unmarked, ie. inaccessible
 712       (gc)
 713       ;; but they're still in the port table, so this sees them
 714       (port-for-each (lambda (port)
 715                        (set! lst (cons port lst))))
 716       ;; this forces completion of the sweeping
 717       (gc) (gc) (gc)
 718       ;; and (if the bug is present) the cells accumulated in LST are now
 719       ;; freed cells, which give #f from `port?'
 720       (not (memq #f (map port? lst))))))
 721
 722 (with-test-prefix
 723  "fdes->port"
 724  (pass-if "fdes->ports finds port"
 725           (let ((port (open-file (test-file) "w")))
 726
 727             (not (not (memq port (fdes->ports (port->fdes port))))))))
 728
 729 ;;;
 730 ;;; seek
 731 ;;;
 732
 733 (with-test-prefix "seek"
 734
 735   (with-test-prefix "file port"
 736
 737     (pass-if "SEEK_CUR"
 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_CUR)
 744         (eqv? #\d (read-char port))))
 745
 746     (pass-if "SEEK_SET"
 747       (call-with-output-file (test-file)
 748         (lambda (port)
 749           (display "abcde" port)))
 750       (let ((port (open-file (test-file) "r")))
 751         (read-char port)
 752         (seek port 3 SEEK_SET)
 753         (eqv? #\d (read-char port))))
 754
 755     (pass-if "SEEK_END"
 756       (call-with-output-file (test-file)
 757         (lambda (port)
 758           (display "abcde" port)))
 759       (let ((port (open-file (test-file) "r")))
 760         (read-char port)
 761         (seek port -2 SEEK_END)
 762         (eqv? #\d (read-char port))))))
 763
 764 ;;;
 765 ;;; truncate-file
 766 ;;;
 767
 768 (with-test-prefix "truncate-file"
 769
 770   (pass-if-exception "flonum file" exception:wrong-type-arg
 771     (truncate-file 1.0 123))
 772
 773   (pass-if-exception "frac file" exception:wrong-type-arg
 774     (truncate-file 7/3 123))
 775
 776   (with-test-prefix "filename"
 777
 778     (pass-if-exception "flonum length" exception:wrong-type-arg
 779       (call-with-output-file (test-file)
 780         (lambda (port)
 781           (display "hello" port)))
 782       (truncate-file (test-file) 1.0))
 783
 784     (pass-if "shorten"
 785       (call-with-output-file (test-file)
 786         (lambda (port)
 787           (display "hello" port)))
 788       (truncate-file (test-file) 1)
 789       (eqv? 1 (stat:size (stat (test-file)))))
 790
 791     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
 792       (call-with-output-file (test-file)
 793         (lambda (port)
 794           (display "hello" port)))
 795       (truncate-file (test-file))))
 796
 797   (with-test-prefix "file descriptor"
 798
 799     (pass-if "shorten"
 800       (call-with-output-file (test-file)
 801         (lambda (port)
 802           (display "hello" port)))
 803       (let ((fd (open-fdes (test-file) O_RDWR)))
 804         (truncate-file fd 1)
 805         (close-fdes fd))
 806       (eqv? 1 (stat:size (stat (test-file)))))
 807
 808     (pass-if "shorten to current pos"
 809       (call-with-output-file (test-file)
 810         (lambda (port)
 811           (display "hello" port)))
 812       (let ((fd (open-fdes (test-file) O_RDWR)))
 813         (seek fd 1 SEEK_SET)
 814         (truncate-file fd)
 815         (close-fdes fd))
 816       (eqv? 1 (stat:size (stat (test-file))))))
 817
 818   (with-test-prefix "file port"
 819
 820     (pass-if "shorten"
 821       (call-with-output-file (test-file)
 822         (lambda (port)
 823           (display "hello" port)))
 824       (let ((port (open-file (test-file) "r+")))
 825         (truncate-file port 1))
 826       (eqv? 1 (stat:size (stat (test-file)))))
 827
 828     (pass-if "shorten to current pos"
 829       (call-with-output-file (test-file)
 830         (lambda (port)
 831           (display "hello" port)))
 832       (let ((port (open-file (test-file) "r+")))
 833         (read-char port)
 834         (truncate-file port))
 835       (eqv? 1 (stat:size (stat (test-file)))))))
 836
 837
 838 ;;;; testing read-delimited and friends
 839
 840 (with-test-prefix "read-delimited!"
 841   (let ((c (make-string 20 #\!)))
 842     (call-with-input-string
 843      "defdef\nghighi\n"
 844      (lambda (port)
 845
 846        (read-delimited! "\n" c port 'concat)
 847        (pass-if "read-delimited! reads a first line"
 848                 (string=? c "defdef\n!!!!!!!!!!!!!"))
 849
 850        (read-delimited! "\n" c port 'concat 3)
 851        (pass-if "read-delimited! reads a first line"
 852                 (string=? c "defghighi\n!!!!!!!!!!"))))))
 853
 854 \f
 855 ;;;; char-ready?
 856
 857 (call-with-input-string
 858  "howdy"
 859  (lambda (port)
 860    (pass-if "char-ready? returns true on string port"
 861             (char-ready? port))))
 862
 863 ;;; This segfaults on some versions of Guile.  We really should run
 864 ;;; the tests in a subprocess...
 865
 866 (call-with-input-string
 867  "howdy"
 868  (lambda (port)
 869    (with-input-from-port
 870        port
 871      (lambda ()
 872        (pass-if "char-ready? returns true on string port as default port"
 873                 (char-ready?))))))
 874
 875 \f
 876 ;;;; Close current-input-port, and make sure everyone can handle it.
 877
 878 (with-test-prefix "closing current-input-port"
 879   (for-each (lambda (procedure name)
 880               (with-input-from-port
 881                   (call-with-input-string "foo" (lambda (p) p))
 882                 (lambda ()
 883                   (close-port (current-input-port))
 884                   (pass-if-exception name
 885                     exception:wrong-type-arg
 886                     (procedure)))))
 887             (list read read-char read-line)
 888             '("read" "read-char" "read-line")))
 889
 890 (delete-file (test-file))