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,
   5 ;;;;      2011, 2012 Free Software Foundation, Inc.
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20
  21 (define-module (test-suite test-ports)
  22   #:use-module (test-suite lib)
  23   #:use-module (test-suite guile-test)
  24   #:use-module (ice-9 popen)
  25   #:use-module (ice-9 rdelim)
  26   #:use-module (rnrs bytevectors)
  27   #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)))
  28
  29 (define (display-line . args)
  30   (for-each display args)
  31   (newline))
  32
  33 (define (test-file)
  34   (data-file-name "ports-test.tmp"))
  35
  36 \f
  37 ;;;; Some general utilities for testing ports.
  38
  39 ;; Make sure we are set up for 8-bit Latin-1 data.
  40 (fluid-set! %default-port-encoding "ISO-8859-1")
  41 (for-each (lambda (p)
  42             (set-port-encoding! p (fluid-ref %default-port-encoding)))
  43           (list (current-input-port) (current-output-port)
  44                 (current-error-port)))
  45
  46 ;;; Read from PORT until EOF, and return the result as a string.
  47 (define (read-all port)
  48   (let loop ((chars '()))
  49     (let ((char (read-char port)))
  50       (if (eof-object? char)
  51           (list->string (reverse! chars))
  52           (loop (cons char chars))))))
  53
  54 (define (read-file filename)
  55   (let* ((port (open-input-file filename))
  56          (string (read-all port)))
  57     (close-port port)
  58     string))
  59
  60 \f
  61 ;;;; Normal file ports.
  62
  63 ;;; Write out an s-expression, and read it back.
  64 (let ((string '("From fairest creatures we desire increase,"
  65                 "That thereby beauty's rose might never die,"))
  66       (filename (test-file)))
  67   (let ((port (open-output-file filename)))
  68     (write string port)
  69     (close-port port))
  70   (let ((port (open-input-file filename)))
  71     (let ((in-string (read port)))
  72       (pass-if "file: write and read back list of strings"
  73                (equal? string in-string)))
  74     (close-port port))
  75   (delete-file filename))
  76
  77 ;;; Write out a string, and read it back a character at a time.
  78 (let ((string "This is a test string\nwith no newline at the end")
  79       (filename (test-file)))
  80   (let ((port (open-output-file filename)))
  81     (display string port)
  82     (close-port port))
  83   (let ((in-string (read-file filename)))
  84     (pass-if "file: write and read back characters"
  85              (equal? string in-string)))
  86   (delete-file filename))
  87
  88 ;;; Buffered input/output port with seeking.
  89 (let* ((filename (test-file))
  90        (port (open-file filename "w+")))
  91   (display "J'Accuse" port)
  92   (seek port -1 SEEK_CUR)
  93   (pass-if "file: r/w 1"
  94            (char=? (read-char port) #\e))
  95   (pass-if "file: r/w 2"
  96            (eof-object? (read-char port)))
  97   (seek port -1 SEEK_CUR)
  98   (write-char #\x port)
  99   (seek port 7 SEEK_SET)
 100   (pass-if "file: r/w 3"
 101            (char=? (read-char port) #\x))
 102   (seek port -2 SEEK_END)
 103   (pass-if "file: r/w 4"
 104            (char=? (read-char port) #\s))
 105   (close-port port)
 106   (delete-file filename))
 107
 108 ;;; Unbuffered input/output port with seeking.
 109 (let* ((filename (test-file))
 110        (port (open-file filename "w+0")))
 111   (display "J'Accuse" port)
 112   (seek port -1 SEEK_CUR)
 113   (pass-if "file: ub r/w 1"
 114            (char=? (read-char port) #\e))
 115   (pass-if "file: ub r/w 2"
 116            (eof-object? (read-char port)))
 117   (seek port -1 SEEK_CUR)
 118   (write-char #\x port)
 119   (seek port 7 SEEK_SET)
 120   (pass-if "file: ub r/w 3"
 121            (char=? (read-char port) #\x))
 122   (seek port -2 SEEK_END)
 123   (pass-if "file: ub r/w 4"
 124            (char=? (read-char port) #\s))
 125   (close-port port)
 126   (delete-file filename))
 127
 128 ;;; Buffered output-only and input-only ports with seeking.
 129 (let* ((filename (test-file))
 130        (port (open-output-file filename)))
 131   (display "J'Accuse" port)
 132   (pass-if "file: out tell"
 133            (= (seek port 0 SEEK_CUR) 8))
 134   (seek port -1 SEEK_CUR)
 135   (write-char #\x port)
 136   (close-port port)
 137   (let ((iport (open-input-file filename)))
 138     (pass-if "file: in tell 0"
 139              (= (seek iport 0 SEEK_CUR) 0))
 140     (read-char iport)
 141     (pass-if "file: in tell 1"
 142              (= (seek iport 0 SEEK_CUR) 1))
 143     (unread-char #\z iport)
 144     (pass-if "file: in tell 0 after unread"
 145              (= (seek iport 0 SEEK_CUR) 0))
 146     (pass-if "file: unread char still there"
 147              (char=? (read-char iport) #\z))
 148     (seek iport 7 SEEK_SET)
 149     (pass-if "file: in last char"
 150              (char=? (read-char iport) #\x))
 151     (close-port iport))
 152   (delete-file filename))
 153
 154 ;;; unusual characters.
 155 (let* ((filename (test-file))
 156        (port (open-output-file filename)))
 157   (display (string #\nul (integer->char 255) (integer->char 128)
 158                    #\nul) port)
 159   (close-port port)
 160   (let* ((port (open-input-file filename))
 161          (line (read-line port)))
 162     (pass-if "file: read back NUL 1"
 163              (char=? (string-ref line 0) #\nul))
 164     (pass-if "file: read back 255"
 165              (char=? (string-ref line 1) (integer->char 255)))
 166     (pass-if "file: read back 128"
 167              (char=? (string-ref line 2) (integer->char 128)))
 168     (pass-if "file: read back NUL 2"
 169              (char=? (string-ref line 3) #\nul))
 170     (pass-if "file: EOF"
 171              (eof-object? (read-char port)))
 172     (close-port port))
 173   (delete-file filename))
 174
 175 ;;; line buffering mode.
 176 (let* ((filename (test-file))
 177        (port (open-file filename "wl"))
 178        (test-string "one line more or less"))
 179   (write-line test-string port)
 180   (let* ((in-port (open-input-file filename))
 181          (line (read-line in-port)))
 182     (close-port in-port)
 183     (close-port port)
 184     (pass-if "file: line buffering"
 185              (string=? line test-string)))
 186   (delete-file filename))
 187
 188 ;;; read-line should use the port encoding (not the locale encoding).
 189 (let ((str "ĉu bone?"))
 190   (with-locale "C"
 191                (let* ((filename (test-file))
 192                       (port (open-file filename "wl")))
 193                  (set-port-encoding! port "UTF-8")
 194                  (write-line str port)
 195                  (let ((in-port (open-input-file filename)))
 196                    (set-port-encoding! in-port "UTF-8")
 197                    (let ((line (read-line in-port)))
 198                      (close-port in-port)
 199                      (close-port port)
 200                      (pass-if "file: read-line honors port encoding"
 201                               (string=? line str))))
 202                  (delete-file filename))))
 203
 204 ;;; binary mode ignores port encoding
 205 (pass-if "file: binary mode ignores port encoding"
 206   (with-fluids ((%default-port-encoding "UTF-8"))
 207                (let* ((filename (test-file))
 208                       (port (open-file filename "w"))
 209                       (test-string "一二三")
 210                       (binary-test-string
 211                        (apply string
 212                               (map integer->char
 213                                    (uniform-vector->list
 214                                     (string->utf8 test-string))))))
 215                  (write-line test-string port)
 216                  (close-port port)
 217                  (let* ((in-port (open-file filename "rb"))
 218                         (line (read-line in-port)))
 219                    (close-port in-port)
 220                    (delete-file filename)
 221                    (string=? line binary-test-string)))))
 222
 223 ;;; binary mode ignores file coding declaration
 224 (pass-if "file: binary mode ignores file coding declaration"
 225   (with-fluids ((%default-port-encoding "UTF-8"))
 226                (let* ((filename (test-file))
 227                       (port (open-file filename "w"))
 228                       (test-string "一二三")
 229                       (binary-test-string
 230                        (apply string
 231                               (map integer->char
 232                                    (uniform-vector->list
 233                                     (string->utf8 test-string))))))
 234                  (write-line ";; coding: utf-8" port)
 235                  (write-line test-string port)
 236                  (close-port port)
 237                  (let* ((in-port (open-file filename "rb"))
 238                         (line1 (read-line in-port))
 239                         (line2 (read-line in-port)))
 240                    (close-port in-port)
 241                    (delete-file filename)
 242                    (string=? line2 binary-test-string)))))
 243
 244 ;; open-file honors file coding declarations
 245 (pass-if "file: open-file honors coding declarations"
 246   (with-fluids ((%default-port-encoding "UTF-8"))
 247                (let* ((filename (test-file))
 248                       (port (open-output-file filename))
 249                       (test-string "€100"))
 250                  (set-port-encoding! port "ISO-8859-15")
 251                  (write-line ";; coding: iso-8859-15" port)
 252                  (write-line test-string port)
 253                  (close-port port)
 254                  (let* ((in-port (open-input-file filename))
 255                         (line1 (read-line in-port))
 256                         (line2 (read-line in-port)))
 257                    (close-port in-port)
 258                    (delete-file filename)
 259                    (string=? line2 test-string)))))
 260
 261 ;;; ungetting characters and strings.
 262 (with-input-from-string "walk on the moon\nmoon"
 263                         (lambda ()
 264                           (read-char)
 265                           (unread-char #\a (current-input-port))
 266                           (pass-if "unread-char"
 267                                    (char=? (read-char) #\a))
 268                           (read-line)
 269                           (let ((replacenoid "chicken enchilada"))
 270                             (unread-char #\newline (current-input-port))
 271                             (unread-string replacenoid (current-input-port))
 272                             (pass-if "unread-string"
 273                                      (string=? (read-line) replacenoid)))
 274                           (pass-if "unread residue"
 275                                    (string=? (read-line) "moon"))))
 276
 277 ;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
 278 ;;; the reading end.  try to read a byte: should get EAGAIN or
 279 ;;; EWOULDBLOCK error.
 280 (let* ((p (pipe))
 281        (r (car p)))
 282   (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
 283   (pass-if "non-blocking-I/O"
 284            (catch 'system-error
 285                   (lambda () (read-char r) #f)
 286                   (lambda (key . args)
 287                     (and (eq? key 'system-error)
 288                          (let ((errno (car (list-ref args 3))))
 289                            (or (= errno EAGAIN)
 290                                (= errno EWOULDBLOCK))))))))
 291
 292 \f
 293 ;;;; Pipe (popen) ports.
 294
 295 ;;; Run a command, and read its output.
 296 (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
 297        (in-string (read-all pipe)))
 298   (close-pipe pipe)
 299   (pass-if "pipe: read"
 300            (equal? in-string "Howdy there, partner!\n")))
 301
 302 ;;; Run a command, send some output to it, and see if it worked.
 303 (let* ((filename (test-file))
 304        (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
 305   (display "Now Jimmy lives on a mushroom cloud\n" pipe)
 306   (display "Mommy, why does everybody have a bomb?\n" pipe)
 307   (close-pipe pipe)
 308   (let ((in-string (read-file filename)))
 309     (pass-if "pipe: write"
 310              (equal? in-string "Mommy, why does everybody have a bomb?\n")))
 311   (delete-file filename))
 312
 313 \f
 314 ;;;; Void ports.  These are so trivial we don't test them.
 315
 316 \f
 317 ;;;; String ports.
 318
 319 (with-test-prefix "string ports"
 320
 321   ;; Write text to a string port.
 322   (let* ((string "Howdy there, partner!")
 323          (in-string (call-with-output-string
 324                      (lambda (port)
 325                        (display string port)
 326                        (newline port)))))
 327     (pass-if "display text"
 328              (equal? in-string (string-append string "\n"))))
 329
 330   ;; Write an s-expression to a string port.
 331   (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
 332          (in-sexpr
 333           (call-with-input-string (call-with-output-string
 334                                    (lambda (port)
 335                                      (write sexpr port)))
 336                                   read)))
 337     (pass-if "write/read sexpr"
 338              (equal? in-sexpr sexpr)))
 339
 340   ;; seeking and unreading from an input string.
 341   (let ((text "that text didn't look random to me"))
 342     (call-with-input-string text
 343                             (lambda (p)
 344                               (pass-if "input tell 0"
 345                                        (= (seek p 0 SEEK_CUR) 0))
 346                               (read-char p)
 347                               (pass-if "input tell 1"
 348                                        (= (seek p 0 SEEK_CUR) 1))
 349                               (unread-char #\x p)
 350                               (pass-if "input tell back to 0"
 351                                        (= (seek p 0 SEEK_CUR) 0))
 352                               (pass-if "input ungetted char"
 353                                        (char=? (read-char p) #\x))
 354                               (seek p 0 SEEK_END)
 355                               (pass-if "input seek to end"
 356                                        (= (seek p 0 SEEK_CUR)
 357                                           (string-length text)))
 358                               (unread-char #\x p)
 359                               (pass-if "input seek to beginning"
 360                                        (= (seek p 0 SEEK_SET) 0))
 361                               (pass-if "input reread first char"
 362                                        (char=? (read-char p)
 363                                                (string-ref text 0))))))
 364
 365   ;; seeking an output string.
 366   (let* ((text (string-copy "123456789"))
 367          (len (string-length text))
 368          (result (call-with-output-string
 369                   (lambda (p)
 370                     (pass-if "output tell 0"
 371                              (= (seek p 0 SEEK_CUR) 0))
 372                     (display text p)
 373                     (pass-if "output tell end"
 374                              (= (seek p 0 SEEK_CUR) len))
 375                     (pass-if "output seek to beginning"
 376                              (= (seek p 0 SEEK_SET) 0))
 377                     (write-char #\a p)
 378                     (seek p -1 SEEK_END)
 379                     (pass-if "output seek to last char"
 380                              (= (seek p 0 SEEK_CUR)
 381                                 (- len 1)))
 382                     (write-char #\b p)))))
 383     (string-set! text 0 #\a)
 384     (string-set! text (- len 1) #\b)
 385     (pass-if "output check"
 386              (string=? text result)))
 387
 388   (pass-if "%default-port-encoding is honored"
 389     (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
 390       (equal? (map (lambda (e)
 391                      (with-fluids ((%default-port-encoding e))
 392                        (call-with-output-string
 393                          (lambda (p)
 394                            (and (string=? e (port-encoding p))
 395                                 (display (port-encoding p) p))))))
 396                    encodings)
 397               encodings)))
 398
 399   (pass-if "suitable encoding [latin-1]"
 400     (let ((str "hello, world"))
 401       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 402         (equal? str
 403                 (with-output-to-string
 404                   (lambda ()
 405                     (display str)))))))
 406
 407   (pass-if "suitable encoding [latin-3]"
 408     (let ((str "ĉu bone?"))
 409       (with-fluids ((%default-port-encoding "ISO-8859-3"))
 410         (equal? str
 411                 (with-output-to-string
 412                   (lambda ()
 413                     (display str)))))))
 414
 415   (pass-if "wrong encoding"
 416     (let ((str "ĉu bone?"))
 417       (catch 'encoding-error
 418         (lambda ()
 419           ;; Latin-1 cannot represent ‘ĉ’.
 420           (with-fluids ((%default-port-encoding "ISO-8859-1"))
 421             (with-output-to-string
 422               (lambda ()
 423                 (display str)))))
 424         (lambda (key subr message errno port chr)
 425           (and (eq? chr #\ĉ)
 426                (string? (strerror errno)))))))
 427
 428   (pass-if "wrong encoding, substitute"
 429     (let ((str "ĉu bone?"))
 430       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 431         (string=? (with-output-to-string
 432                     (lambda ()
 433                       (set-port-conversion-strategy! (current-output-port)
 434                                                      'substitute)
 435                       (display str)))
 436                   "?u bone?"))))
 437
 438   (pass-if "wrong encoding, escape"
 439     (let ((str "ĉu bone?"))
 440       (with-fluids ((%default-port-encoding "ISO-8859-1"))
 441         (string=? (with-output-to-string
 442                     (lambda ()
 443                       (set-port-conversion-strategy! (current-output-port)
 444                                                      'escape)
 445                       (display str)))
 446                   "\\u0109u bone?"))))
 447
 448   (pass-if "peek-char [latin-1]"
 449     (let ((p (with-fluids ((%default-port-encoding #f))
 450                (open-input-string "hello, world"))))
 451       (and (char=? (peek-char p) #\h)
 452            (char=? (peek-char p) #\h)
 453            (char=? (peek-char p) #\h)
 454            (= (port-line p) 0)
 455            (= (port-column p) 0))))
 456
 457   (pass-if "peek-char [utf-8]"
 458     (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
 459                (open-input-string "안녕하세요"))))
 460       (and (char=? (peek-char p) #\안)
 461            (char=? (peek-char p) #\안)
 462            (char=? (peek-char p) #\안)
 463            (= (port-line p) 0)
 464            (= (port-column p) 0))))
 465
 466   (pass-if "peek-char [utf-16]"
 467     (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
 468                (open-input-string "안녕하세요"))))
 469       (and (char=? (peek-char p) #\안)
 470            (char=? (peek-char p) #\안)
 471            (char=? (peek-char p) #\안)
 472            (= (port-line p) 0)
 473            (= (port-column p) 0))))
 474
 475   ;; Mini DSL to test decoding error handling.
 476   (letrec-syntax ((decoding-error?
 477                    (syntax-rules ()
 478                      ((_ port exp)
 479                       (catch 'decoding-error
 480                         (lambda ()
 481                           (pk 'exp exp)
 482                           #f)
 483                         (lambda (key subr message errno p)
 484                           (and (eq? p port)
 485                                (not (= 0 errno))))))))
 486                   (make-check
 487                    (syntax-rules (-> error eof)
 488                      ((_ port (proc -> error))
 489                       (if (eq? 'substitute
 490                                (port-conversion-strategy port))
 491                           (eq? (proc port) #\?)
 492                           (decoding-error? port (proc port))))
 493                      ((_ port (proc -> eof))
 494                       (eof-object? (proc port)))
 495                      ((_ port (proc -> char))
 496                       (eq? (proc port) char))))
 497                   (make-checks
 498                    (syntax-rules ()
 499                      ((_ port check ...)
 500                       (and (make-check port check) ...))))
 501                   (make-peek+read-checks
 502                    (syntax-rules ()
 503                      ((_ port (result ...) e1 expected ...)
 504                       (make-peek+read-checks port
 505                                              (result ...
 506                                                      (peek-char -> e1)
 507                                                      (read-char -> e1))
 508                                              expected ...))
 509                      ((_ port (result ...))
 510                       (make-checks port result ...))
 511                      ((_ port #f e1 expected ...)
 512                       (make-peek+read-checks port
 513                                              ((peek-char -> e1)
 514                                               (read-char -> e1))
 515                                              expected ...))))
 516
 517                   (test-decoding-error*
 518                       (syntax-rules ()
 519                         ((_ sequence encoding strategy (expected ...))
 520                          (begin
 521                           (pass-if (format #f "test-decoding-error: ~s ~s ~s"
 522                                            'sequence encoding strategy)
 523                             (let ((p (open-bytevector-input-port
 524                                       (u8-list->bytevector 'sequence))))
 525                               (set-port-encoding! p encoding)
 526                               (set-port-conversion-strategy! p strategy)
 527                               (make-checks p
 528                                            (read-char -> expected) ...)))
 529
 530                           ;; Generate the same test, but with one
 531                           ;; `peek-char' call before each `read-char'.
 532                           ;; Both should yield the same result.
 533                           (pass-if (format #f "test-decoding-error: ~s ~s ~s + peek-char"
 534                                            'sequence encoding strategy)
 535                             (let ((p (open-bytevector-input-port
 536                                       (u8-list->bytevector 'sequence))))
 537                               (set-port-encoding! p encoding)
 538                               (set-port-conversion-strategy! p strategy)
 539                               (make-peek+read-checks p #f expected
 540                                                      ...)))))))
 541                   (test-decoding-error
 542                       (syntax-rules ()
 543                         ((_ sequence encoding (expected ...))
 544                          (begin
 545                            (test-decoding-error* sequence encoding 'error
 546                              (expected ...))
 547
 548                            ;; `escape' should behave exactly like `error'.
 549                            (test-decoding-error* sequence encoding 'escape
 550                              (expected ...))
 551
 552                            (test-decoding-error* sequence encoding 'substitute
 553                              (expected ...)))))))
 554
 555     (test-decoding-error (255 65 66 67) "UTF-8"
 556       (error #\A #\B #\C eof))
 557
 558     (test-decoding-error (255 206 187 206 188) "UTF-8"
 559       (error #\λ #\μ eof))
 560
 561     (test-decoding-error (206 187 206) "UTF-8"
 562       ;; Unterminated sequence.
 563       (#\λ error eof))
 564
 565     ;; Check how ill-formed UTF-8 sequences are handled (see Table 3-7
 566     ;; of the "Conformance" chapter of Unicode 6.0.0.)
 567
 568     (test-decoding-error (#xc0 #x80 #x41) "UTF-8"
 569       (error                ;; C0: should be in the C2..DF range
 570        error                ;; 80: invalid
 571        #\A
 572        eof))
 573
 574     (test-decoding-error (#xc2 #x41 #x42) "UTF-8"
 575       ;; Section 3.9 of Unicode 6.0.0 reads:
 576       ;;   "If the converter encounters an ill-formed UTF-8 code unit
 577       ;;   sequence which starts with a valid first byte, but which does
 578       ;;   not continue with valid successor bytes (see Table 3-7), it
 579       ;;   must not consume the successor bytes".
 580       ;; Glibc/libiconv do not conform to it and instead swallow the
 581       ;; #x41.  This example appears literally in Section 3.9.
 582       (error                ;; 41: invalid successor
 583        #\A                  ;; 41: valid starting byte
 584        #\B
 585        eof))
 586
 587     (test-decoding-error (#xf0 #x80 #x80 #x41) "UTF-8"
 588       ;; According to Unicode 6.0.0, Section 3.9, "the only formal
 589       ;; requirement mandated by Unicode conformance for a converter is
 590       ;; that the <41> be processed and correctly interpreted as
 591       ;; <U+0041>".
 592       (error                ;; 2nd byte should be in the A0..BF range
 593        error                ;; 80: not a valid starting byte
 594        error                ;; 80: not a valid starting byte
 595        #\A
 596        eof))
 597
 598     (test-decoding-error (#xe0 #xa0 #x41 #x42) "UTF-8"
 599       (error                ;; 3rd byte should be in the 80..BF range
 600        #\A
 601        #\B
 602        eof))
 603
 604     (test-decoding-error (#xf0 #x88 #x88 #x88) "UTF-8"
 605       (error                ;; 2nd byte should be in the 90..BF range
 606        error                ;; 88: not a valid starting byte
 607        error                ;; 88: not a valid starting byte
 608        error                ;; 88: not a valid starting byte
 609        eof))))
 610
 611 (with-test-prefix "call-with-output-string"
 612
 613   ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
 614   ;; occur.
 615   (pass-if-exception "proc closes port" exception:wrong-type-arg
 616     (call-with-output-string close-port)))
 617
 618
 619 \f
 620 ;;;; Soft ports.  No tests implemented yet.
 621
 622 \f
 623 ;;;; Generic operations across all port types.
 624
 625 (let ((port-loop-temp (test-file)))
 626
 627   ;; Return a list of input ports that all return the same text.
 628   ;; We map tests over this list.
 629   (define (input-port-list text)
 630
 631     ;; Create a text file some of the ports will use.
 632     (let ((out-port (open-output-file port-loop-temp)))
 633       (display text out-port)
 634       (close-port out-port))
 635
 636     (list (open-input-file port-loop-temp)
 637           (open-input-pipe (string-append "cat " port-loop-temp))
 638           (call-with-input-string text (lambda (x) x))
 639           ;; We don't test soft ports at the moment.
 640           ))
 641
 642   (define port-list-names '("file" "pipe" "string"))
 643
 644   ;; Test the line counter.
 645   (define (test-line-counter text second-line final-column)
 646     (with-test-prefix "line counter"
 647       (let ((ports (input-port-list text)))
 648         (for-each
 649          (lambda (port port-name)
 650            (with-test-prefix port-name
 651              (pass-if "at beginning of input"
 652                       (= (port-line port) 0))
 653              (pass-if "read first character"
 654                       (eqv? (read-char port) #\x))
 655              (pass-if "after reading one character"
 656                       (= (port-line port) 0))
 657              (pass-if "read first newline"
 658                       (eqv? (read-char port) #\newline))
 659              (pass-if "after reading first newline char"
 660                       (= (port-line port) 1))
 661              (pass-if "second line read correctly"
 662                       (equal? (read-line port) second-line))
 663              (pass-if "read-line increments line number"
 664                       (= (port-line port) 2))
 665              (pass-if "read-line returns EOF"
 666                       (let loop ((i 0))
 667                         (cond
 668                          ((eof-object? (read-line port)) #t)
 669                          ((> i 20) #f)
 670                          (else (loop (+ i 1))))))
 671              (pass-if "line count is 5 at EOF"
 672                       (= (port-line port) 5))
 673              (pass-if "column is correct at EOF"
 674                       (= (port-column port) final-column))))
 675          ports port-list-names)
 676         (for-each close-port ports)
 677         (delete-file port-loop-temp))))
 678
 679   (with-test-prefix "newline"
 680     (test-line-counter
 681      (string-append "x\n"
 682                     "He who receives an idea from me, receives instruction\n"
 683                     "himself without lessening mine; as he who lights his\n"
 684                     "taper at mine, receives light without darkening me.\n"
 685                     "  --- Thomas Jefferson\n")
 686      "He who receives an idea from me, receives instruction"
 687      0))
 688
 689   (with-test-prefix "no newline"
 690     (test-line-counter
 691      (string-append "x\n"
 692                     "He who receives an idea from me, receives instruction\n"
 693                     "himself without lessening mine; as he who lights his\n"
 694                     "taper at mine, receives light without darkening me.\n"
 695                     "  --- Thomas Jefferson\n"
 696                     "no newline here")
 697      "He who receives an idea from me, receives instruction"
 698      15)))
 699
 700 ;; Test port-line and port-column for output ports
 701
 702 (define (test-output-line-counter text final-column)
 703   (with-test-prefix "port-line and port-column for output ports"
 704     (let ((port (open-output-string)))
 705       (pass-if "at beginning of input"
 706                (and (= (port-line port) 0)
 707                     (= (port-column port) 0)))
 708       (write-char #\x port)
 709       (pass-if "after writing one character"
 710                (and (= (port-line port) 0)
 711                     (= (port-column port) 1)))
 712       (write-char #\newline port)
 713       (pass-if "after writing first newline char"
 714                (and (= (port-line port) 1)
 715                     (= (port-column port) 0)))
 716       (display text port)
 717       (pass-if "line count is 5 at end"
 718                (= (port-line port) 5))
 719       (pass-if "column is correct at end"
 720                (= (port-column port) final-column)))))
 721
 722 (test-output-line-counter
 723  (string-append "He who receives an idea from me, receives instruction\n"
 724                 "himself without lessening mine; as he who lights his\n"
 725                 "taper at mine, receives light without darkening me.\n"
 726                 "  --- Thomas Jefferson\n"
 727                 "no newline here")
 728  15)
 729
 730 (with-test-prefix "port-column"
 731
 732   (with-test-prefix "output"
 733
 734     (pass-if "x"
 735       (let ((port (open-output-string)))
 736         (display "x" port)
 737         (= 1 (port-column port))))
 738
 739     (pass-if "\\a"
 740       (let ((port (open-output-string)))
 741         (display "\a" port)
 742         (= 0 (port-column port))))
 743
 744     (pass-if "x\\a"
 745       (let ((port (open-output-string)))
 746         (display "x\a" port)
 747         (= 1 (port-column port))))
 748
 749     (pass-if "\\x08 backspace"
 750       (let ((port (open-output-string)))
 751         (display "\x08" port)
 752         (= 0 (port-column port))))
 753
 754     (pass-if "x\\x08 backspace"
 755       (let ((port (open-output-string)))
 756         (display "x\x08" port)
 757         (= 0 (port-column port))))
 758
 759     (pass-if "\\n"
 760       (let ((port (open-output-string)))
 761         (display "\n" port)
 762         (= 0 (port-column port))))
 763
 764     (pass-if "x\\n"
 765       (let ((port (open-output-string)))
 766         (display "x\n" port)
 767         (= 0 (port-column port))))
 768
 769     (pass-if "\\r"
 770       (let ((port (open-output-string)))
 771         (display "\r" port)
 772         (= 0 (port-column port))))
 773
 774     (pass-if "x\\r"
 775       (let ((port (open-output-string)))
 776         (display "x\r" port)
 777         (= 0 (port-column port))))
 778
 779     (pass-if "\\t"
 780       (let ((port (open-output-string)))
 781         (display "\t" port)
 782         (= 8 (port-column port))))
 783
 784     (pass-if "x\\t"
 785       (let ((port (open-output-string)))
 786         (display "x\t" port)
 787         (= 8 (port-column port)))))
 788
 789   (with-test-prefix "input"
 790
 791     (pass-if "x"
 792       (let ((port (open-input-string "x")))
 793         (while (not (eof-object? (read-char port))))
 794         (= 1 (port-column port))))
 795
 796     (pass-if "\\a"
 797       (let ((port (open-input-string "\a")))
 798         (while (not (eof-object? (read-char port))))
 799         (= 0 (port-column port))))
 800
 801     (pass-if "x\\a"
 802       (let ((port (open-input-string "x\a")))
 803         (while (not (eof-object? (read-char port))))
 804         (= 1 (port-column port))))
 805
 806     (pass-if "\\x08 backspace"
 807       (let ((port (open-input-string "\x08")))
 808         (while (not (eof-object? (read-char port))))
 809         (= 0 (port-column port))))
 810
 811     (pass-if "x\\x08 backspace"
 812       (let ((port (open-input-string "x\x08")))
 813         (while (not (eof-object? (read-char port))))
 814         (= 0 (port-column port))))
 815
 816     (pass-if "\\n"
 817       (let ((port (open-input-string "\n")))
 818         (while (not (eof-object? (read-char port))))
 819         (= 0 (port-column port))))
 820
 821     (pass-if "x\\n"
 822       (let ((port (open-input-string "x\n")))
 823         (while (not (eof-object? (read-char port))))
 824         (= 0 (port-column port))))
 825
 826     (pass-if "\\r"
 827       (let ((port (open-input-string "\r")))
 828         (while (not (eof-object? (read-char port))))
 829         (= 0 (port-column port))))
 830
 831     (pass-if "x\\r"
 832       (let ((port (open-input-string "x\r")))
 833         (while (not (eof-object? (read-char port))))
 834         (= 0 (port-column port))))
 835
 836     (pass-if "\\t"
 837       (let ((port (open-input-string "\t")))
 838         (while (not (eof-object? (read-char port))))
 839         (= 8 (port-column port))))
 840
 841     (pass-if "x\\t"
 842       (let ((port (open-input-string "x\t")))
 843         (while (not (eof-object? (read-char port))))
 844         (= 8 (port-column port))))))
 845
 846 (with-test-prefix "port-line"
 847
 848   ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
 849   ;; scm_t_port actually holds a long; this restricted the range on 64-bit
 850   ;; systems
 851   (pass-if "set most-positive-fixnum/2"
 852     (let ((n    (quotient most-positive-fixnum 2))
 853           (port (open-output-string)))
 854       (set-port-line! port n)
 855       (eqv? n (port-line port)))))
 856
 857 (with-test-prefix "port-encoding"
 858
 859   (pass-if-exception "set-port-encoding!, wrong encoding"
 860     exception:miscellaneous-error
 861     (set-port-encoding! (open-input-string "") "does-not-exist"))
 862
 863   (pass-if-exception "%default-port-encoding, wrong encoding"
 864     exception:miscellaneous-error
 865     (read (with-fluids ((%default-port-encoding "does-not-exist"))
 866             (open-input-string "")))))
 867
 868 ;;;
 869 ;;; port-for-each
 870 ;;;
 871
 872 (with-test-prefix "port-for-each"
 873
 874   ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
 875   ;; its iterator func if a port was inaccessible in the last gc mark but
 876   ;; the lazy sweeping has not yet reached it to remove it from the port
 877   ;; table (scm_i_port_table).  Provoking those gc conditions is a little
 878   ;; tricky, but the following code made it happen in 1.8.2.
 879   (pass-if "passing freed cell"
 880     (let ((lst '()))
 881       ;; clear out the heap
 882       (gc) (gc) (gc)
 883       ;; allocate cells so the opened ports aren't at the start of the heap
 884       (make-list 1000)
 885       (open-input-file "/dev/null")
 886       (make-list 1000)
 887       (open-input-file "/dev/null")
 888       ;; this gc leaves the above ports unmarked, ie. inaccessible
 889       (gc)
 890       ;; but they're still in the port table, so this sees them
 891       (port-for-each (lambda (port)
 892                        (set! lst (cons port lst))))
 893       ;; this forces completion of the sweeping
 894       (gc) (gc) (gc)
 895       ;; and (if the bug is present) the cells accumulated in LST are now
 896       ;; freed cells, which give #f from `port?'
 897       (not (memq #f (map port? lst))))))
 898
 899 (with-test-prefix
 900  "fdes->port"
 901  (pass-if "fdes->ports finds port"
 902           (let ((port (open-file (test-file) "w")))
 903
 904             (not (not (memq port (fdes->ports (port->fdes port))))))))
 905
 906 ;;;
 907 ;;; seek
 908 ;;;
 909
 910 (with-test-prefix "seek"
 911
 912   (with-test-prefix "file port"
 913
 914     (pass-if "SEEK_CUR"
 915       (call-with-output-file (test-file)
 916         (lambda (port)
 917           (display "abcde" port)))
 918       (let ((port (open-file (test-file) "r")))
 919         (read-char port)
 920         (seek port 2 SEEK_CUR)
 921         (eqv? #\d (read-char port))))
 922
 923     (pass-if "SEEK_SET"
 924       (call-with-output-file (test-file)
 925         (lambda (port)
 926           (display "abcde" port)))
 927       (let ((port (open-file (test-file) "r")))
 928         (read-char port)
 929         (seek port 3 SEEK_SET)
 930         (eqv? #\d (read-char port))))
 931
 932     (pass-if "SEEK_END"
 933       (call-with-output-file (test-file)
 934         (lambda (port)
 935           (display "abcde" port)))
 936       (let ((port (open-file (test-file) "r")))
 937         (read-char port)
 938         (seek port -2 SEEK_END)
 939         (eqv? #\d (read-char port))))))
 940
 941 ;;;
 942 ;;; truncate-file
 943 ;;;
 944
 945 (with-test-prefix "truncate-file"
 946
 947   (pass-if-exception "flonum file" exception:wrong-type-arg
 948     (truncate-file 1.0 123))
 949
 950   (pass-if-exception "frac file" exception:wrong-type-arg
 951     (truncate-file 7/3 123))
 952
 953   (with-test-prefix "filename"
 954
 955     (pass-if-exception "flonum length" exception:wrong-type-arg
 956       (call-with-output-file (test-file)
 957         (lambda (port)
 958           (display "hello" port)))
 959       (truncate-file (test-file) 1.0))
 960
 961     (pass-if "shorten"
 962       (call-with-output-file (test-file)
 963         (lambda (port)
 964           (display "hello" port)))
 965       (truncate-file (test-file) 1)
 966       (eqv? 1 (stat:size (stat (test-file)))))
 967
 968     (pass-if-exception "shorten to current pos" exception:miscellaneous-error
 969       (call-with-output-file (test-file)
 970         (lambda (port)
 971           (display "hello" port)))
 972       (truncate-file (test-file))))
 973
 974   (with-test-prefix "file descriptor"
 975
 976     (pass-if "shorten"
 977       (call-with-output-file (test-file)
 978         (lambda (port)
 979           (display "hello" port)))
 980       (let ((fd (open-fdes (test-file) O_RDWR)))
 981         (truncate-file fd 1)
 982         (close-fdes fd))
 983       (eqv? 1 (stat:size (stat (test-file)))))
 984
 985     (pass-if "shorten to current pos"
 986       (call-with-output-file (test-file)
 987         (lambda (port)
 988           (display "hello" port)))
 989       (let ((fd (open-fdes (test-file) O_RDWR)))
 990         (seek fd 1 SEEK_SET)
 991         (truncate-file fd)
 992         (close-fdes fd))
 993       (eqv? 1 (stat:size (stat (test-file))))))
 994
 995   (with-test-prefix "file port"
 996
 997     (pass-if "shorten"
 998       (call-with-output-file (test-file)
 999         (lambda (port)
1000           (display "hello" port)))
1001       (let ((port (open-file (test-file) "r+")))
1002         (truncate-file port 1))
1003       (eqv? 1 (stat:size (stat (test-file)))))
1004
1005     (pass-if "shorten to current pos"
1006       (call-with-output-file (test-file)
1007         (lambda (port)
1008           (display "hello" port)))
1009       (let ((port (open-file (test-file) "r+")))
1010         (read-char port)
1011         (truncate-file port))
1012       (eqv? 1 (stat:size (stat (test-file)))))))
1013
1014
1015 ;;;; testing read-delimited and friends
1016
1017 (with-test-prefix "read-delimited!"
1018   (let ((c (make-string 20 #\!)))
1019     (call-with-input-string
1020      "defdef\nghighi\n"
1021      (lambda (port)
1022
1023        (read-delimited! "\n" c port 'concat)
1024        (pass-if "read-delimited! reads a first line"
1025                 (string=? c "defdef\n!!!!!!!!!!!!!"))
1026
1027        (read-delimited! "\n" c port 'concat 3)
1028        (pass-if "read-delimited! reads a first line"
1029                 (string=? c "defghighi\n!!!!!!!!!!"))))))
1030
1031 \f
1032 ;;;; char-ready?
1033
1034 (call-with-input-string
1035  "howdy"
1036  (lambda (port)
1037    (pass-if "char-ready? returns true on string port"
1038             (char-ready? port))))
1039
1040 ;;; This segfaults on some versions of Guile.  We really should run
1041 ;;; the tests in a subprocess...
1042
1043 (call-with-input-string
1044  "howdy"
1045  (lambda (port)
1046    (with-input-from-port
1047        port
1048      (lambda ()
1049        (pass-if "char-ready? returns true on string port as default port"
1050                 (char-ready?))))))
1051
1052 \f
1053 ;;;; Close current-input-port, and make sure everyone can handle it.
1054
1055 (with-test-prefix "closing current-input-port"
1056   (for-each (lambda (procedure name)
1057               (with-input-from-port
1058                   (call-with-input-string "foo" (lambda (p) p))
1059                 (lambda ()
1060                   (close-port (current-input-port))
1061                   (pass-if-exception name
1062                     exception:wrong-type-arg
1063                     (procedure)))))
1064             (list read read-char read-line)
1065             '("read" "read-char" "read-line")))
1066
1067 \f
1068
1069 (with-test-prefix "setvbuf"
1070
1071   (pass-if "line/column number preserved"
1072     ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
1073     ;; line and/or column number.
1074     (call-with-output-file (test-file)
1075       (lambda (p)
1076         (display "This is GNU Guile.\nWelcome." p)))
1077     (call-with-input-file (test-file)
1078       (lambda (p)
1079         (and (eq? #\T (read-char p))
1080              (let ((line (port-line p))
1081                    (col  (port-column p)))
1082                (and (= line 0) (= col 1)
1083                     (begin
1084                       (setvbuf p _IOFBF 777)
1085                       (let ((line* (port-line p))
1086                             (col*  (port-column p)))
1087                         (and (= line line*)
1088                              (= col col*)))))))))))
1089
1090 \f
1091
1092 (define-syntax-rule (with-load-path path body ...)
1093   (let ((new path)
1094         (old %load-path))
1095     (dynamic-wind
1096       (lambda ()
1097         (set! %load-path new))
1098       (lambda ()
1099         body ...)
1100       (lambda ()
1101         (set! %load-path old)))))
1102
1103 (with-test-prefix "%file-port-name-canonicalization"
1104
1105   (pass-if "absolute file name & empty %load-path entry"
1106     ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
1107     ;; of "/dev/null".  See
1108     ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
1109     ;; for a discussion.
1110     (equal? "/dev/null"
1111             (with-load-path (cons "" (delete "/" %load-path))
1112               (with-fluids ((%file-port-name-canonicalization 'relative))
1113                 (port-filename (open-input-file "/dev/null"))))))
1114
1115   (pass-if "relative canonicalization with /"
1116     (equal? "dev/null"
1117             (with-load-path (cons "/" %load-path)
1118               (with-fluids ((%file-port-name-canonicalization 'relative))
1119                 (port-filename (open-input-file "/dev/null"))))))
1120
1121   (pass-if "relative canonicalization from ice-9"
1122     (equal? "ice-9/q.scm"
1123             (with-fluids ((%file-port-name-canonicalization 'relative))
1124               (port-filename
1125                (open-input-file (%search-load-path "ice-9/q.scm"))))))
1126
1127   (pass-if "absolute canonicalization from ice-9"
1128     (equal? (string-append (assoc-ref %guile-build-info 'top_srcdir)
1129                            "/module/ice-9/q.scm")
1130             (with-fluids ((%file-port-name-canonicalization 'absolute))
1131               (port-filename (open-input-file (%search-load-path "ice-9/q.scm")))))))
1132
1133 (delete-file (test-file))
1134
1135 ;;; Local Variables:
1136 ;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
1137 ;;; eval: (put 'with-load-path 'scheme-indent-function 1)
1138 ;;; End: