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