tests/stream.impure.lisp

   1 ;;;; tests related to Lisp streams
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; Some of the tests herein try to read this file after we mess up *D-P-D*
  15 ;;; (to place temp files in TMPDIR). So stash the truename for later use.
  16 (defvar *this-file* (truename "stream.impure.lisp"))
  17
  18 #-win32
  19 (let ((dir (posix-getenv "TMPDIR")))
  20   (setq *default-pathname-defaults*
  21         (if dir
  22             (parse-native-namestring dir nil #P"" :as-directory t)
  23             #P"/tmp/")))
  24 (require :sb-posix)
  25
  26 ;;; Believe it or not the x86-64-specific trap routine for UPDATE-OBJECT-LAYOUT
  27 ;;; could fail to return the correct layout after calling from assembly code into lisp,
  28 ;;; back to assembly code, back to the vop, and not a single regression test failed.
  29 (defclass astream (fundamental-output-stream) ())
  30 (defvar *str* (make-instance 'astream))
  31 (assert (streamp *str*))
  32 (defclass astream (fundamental-output-stream) (x y))
  33 (with-test (:name :update-stream-layout)
  34   (assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
  35   (assert (streamp *str*))
  36   (assert (/= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
  37   (defclass astream () (x y))
  38   (assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
  39   (assert (= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
  40   (assert (not (streamp *str*)))
  41   (assert (/= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
  42   (defclass astream (fundamental-output-stream) (x y))
  43   (assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
  44   (assert (streamp *str*)))
  45
  46 ;;; type errors for inappropriate stream arguments, fixed in
  47 ;;; sbcl-0.7.8.19
  48 (with-test (:name (make-two-way-stream type-error))
  49   (locally (declare (optimize (safety 3)))
  50     (assert-error (make-two-way-stream (make-string-output-stream)
  51                                        (make-string-output-stream))
  52                   type-error)
  53     (assert-error (make-two-way-stream (make-string-input-stream "foo")
  54                                        (make-string-input-stream "bar"))
  55                   type-error)))
  56
  57 (with-test (:name (make-echo-stream type-error))
  58   (locally (declare (optimize (safety 3)))
  59     ;; the following two aren't actually guaranteed, because ANSI, as it
  60     ;; happens, doesn't say "should signal an error" for
  61     ;; MAKE-ECHO-STREAM. It's still good to have, but if future
  62     ;; maintenance work causes this test to fail because of these
  63     ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses
  64     ;; from the test. -- CSR, 2002-10-06
  65     (assert-error (make-echo-stream (make-string-output-stream)
  66                                     (make-string-output-stream))
  67                   type-error)
  68     (assert-error (make-echo-stream (make-string-input-stream "foo")
  69                                     (make-string-input-stream "bar"))
  70                   type-error)))
  71
  72 (with-test (:name (make-concatenated-stream type-error))
  73   (locally (declare (optimize (safety 3)))
  74     (assert-error (make-concatenated-stream
  75                    (make-string-output-stream)
  76                    (make-string-input-stream "foo"))
  77                   type-error)))
  78
  79 ;;; bug 225: STRING-STREAM was not a class
  80 (macrolet
  81     ((define-methods ()
  82        `(defgeneric bug225 (s)
  83           ,@(mapcar (lambda (class)
  84                       `(:method :around ((s ,class))
  85                          (cons ',class (call-next-method))))
  86                     '(stream string-stream
  87                       sb-impl::string-input-stream
  88                       sb-impl::string-output-stream))
  89           (:method (class) nil))))
  90   (define-methods))
  91
  92 (with-test (:name (string-stream class :bug-225))
  93   (assert (equal (bug225 (make-string-input-stream "hello"))
  94                  '(sb-impl::string-input-stream string-stream stream)))
  95   (assert (equal (bug225 (make-string-output-stream))
  96                  '(sb-impl::string-output-stream string-stream stream))))
  97
  98 \f
  99 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
 100 (with-test (:name (write-byte (unsigned-byte 8) read-byte (signed-byte 8)))
 101   (let ((p (scratch-file-name)))
 102     (with-open-file (s p
 103                        :direction :output
 104                        :element-type '(unsigned-byte 8)
 105                        :if-exists :supersede)
 106       (write-byte 255 s))
 107     (with-open-file (s p :element-type '(signed-byte 8))
 108       (assert (= (read-byte s) -1)))
 109     (delete-file p)))
 110 \f
 111 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
 112 ;;; Milan Zamazal)
 113 (with-test (:name (open :if-exists :error))
 114   (let* ((p (scratch-file-name))
 115          (stream (open p :direction :output :if-exists :error)))
 116     (assert (null (with-open-file (s p :direction :output :if-exists nil) s)))
 117     (assert-error
 118      (with-open-file (s p :direction :output :if-exists :error)))
 119     (close stream)
 120     (delete-file p)))
 121 \f
 122 (with-test (:name (read-byte make-string-input-stream type-error))
 123   (assert-error (read-byte (make-string-input-stream "abc"))
 124                 type-error))
 125
 126 (with-test (:name (:default :element-type read-byte error))
 127  (assert-error (with-open-file (s "/dev/zero")
 128                  (read-byte s))
 129                #-win32 type-error
 130                #+win32 sb-int:simple-file-error))
 131
 132 ;;; bidirectional streams getting confused about their position
 133 (with-test (:name (:direction :io))
 134   (let ((p (scratch-file-name)))
 135     (with-open-file (s p :direction :output :if-exists :supersede)
 136       (with-standard-io-syntax
 137         (format s "~S ~S ~S~%" 'these 'are 'symbols)))
 138     (with-open-file (s p :direction :io :if-exists :overwrite)
 139       (read s)
 140       (with-standard-io-syntax
 141         (prin1 'insert s)))
 142     (with-open-file (s p)
 143       (let ((line (read-line s))
 144             (want "THESE INSERTMBOLS"))
 145         (assert (equal line want))))
 146     (delete-file p)))
 147 \f
 148 ;;; :DIRECTION :IO didn't work on non-existent pathnames
 149 (with-test (:name (with-open-file :direction :io :non-existent-pathname))
 150   (let ((p (scratch-file-name)))
 151     (ignore-errors (delete-file p))
 152     (with-open-file (s p :direction :io)
 153       (format s "1")
 154       (finish-output s)
 155       (file-position s :start)
 156       (assert (char= (read-char s) #\1)))
 157     (delete-file p)))
 158 \f
 159 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
 160 (with-test (:name (file-position broadcast-stream 1))
 161   (assert (= 0 (file-position (make-broadcast-stream))))
 162   (assert (file-position (make-broadcast-stream) :start))
 163   (assert (file-position (make-broadcast-stream) 0))
 164   (assert (not (file-position (make-broadcast-stream) 1)))
 165   (let ((s (make-broadcast-stream)))
 166     (write-char #\a s)
 167     (assert (not (file-position s 1)))
 168     (assert (= 0 (file-position s)))))
 169
 170 (with-test (:name (file-position broadcast-stream 2))
 171   (let ((p (scratch-file-name)))
 172     (ignore-errors (delete-file p))
 173     (with-open-file (f p :direction :output)
 174       (let ((s (make-broadcast-stream f)))
 175         (assert (= 0 (file-position s)))
 176         (assert (file-position s :start))
 177         (assert (file-position s 0))
 178         (write-char #\a s)
 179         (assert (= 1 (file-position s))) ; unicode...
 180         (assert (file-position s 0))))
 181     (delete-file p)))
 182
 183 ;;; CLOSING a non-new streams should not delete them, and superseded
 184 ;;; files should be restored.
 185 (with-test (:name :test-file-for-close-should-not-delete)
 186   (let ((test (scratch-file-name)))
 187     (macrolet ((test-mode (mode)
 188                           `(progn
 189                              (catch :close-test-exit
 190                                (with-open-file (f test :direction :output :if-exists ,mode)
 191                                                (write-line "test" f)
 192                                                (throw :close-test-exit t)))
 193                              (assert (and (probe-file test) ,mode)))))
 194       (unwind-protect
 195           (progn
 196             (with-open-file (f test :direction :output)
 197                             (write-line "test" f))
 198             (test-mode :append)
 199             (test-mode :overwrite)
 200             ;; FIXME: We really should recover supersede files as well, according to
 201             ;; CLOSE in CLHS, but at the moment we don't.
 202             ;; (test-mode :supersede)
 203             (test-mode :rename)
 204             (test-mode :rename-and-delete))
 205         (when (probe-file test)
 206           (delete-file test))))))
 207
 208 ;;; test for read-write invariance of signed bytes, from Bruno Haible
 209 ;;; cmucl-imp 2004-09-06
 210 (defun bin-stream-test (&key (size (integer-length most-positive-fixnum))
 211                              (type 'unsigned-byte)
 212                              (file-name (scratch-file-name))
 213                         (num-bytes 10)
 214                         (bytes (if (eq type 'signed-byte)
 215                                    (loop :repeat num-bytes :collect
 216                                          (- (random (ash 1 size))
 217                                             (ash 1 (1- size))))
 218                                    (loop :repeat num-bytes :collect
 219                                          (random (ash 1 size))))))
 220   (with-open-file (foo file-name :direction :output :if-exists :supersede
 221                        :element-type (list type size))
 222     (dolist (byte bytes)
 223       (write-byte byte foo)))
 224   (unwind-protect
 225        (with-open-file (foo file-name :direction :input
 226                             :element-type (list type size))
 227          (list (stream-element-type foo) (file-length foo) bytes
 228                (loop :for byte :in bytes :for nb = (read-byte foo) :collect nb
 229                      :unless (= nb byte) :do
 230                      (flet ((by-out (sz by)
 231                               (format nil "~v,'0,' ,4:b"
 232                                       (+ sz (floor sz 4)) by)))
 233                        (error "~& * [(~s ~s)] ~a != ~a~%" type size
 234                               (by-out size byte) (by-out size nb))))))
 235     (delete-file file-name)))
 236
 237 (with-test (:name (:element-type signed-byte write-byte write-byte))
 238   (loop for size from 2 to 40 do
 239            (bin-stream-test :size size :type 'signed-byte)))
 240 \f
 241 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
 242 ;;; contain a stream element.
 243 ;;;
 244 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
 245 ;;; or slow paths are being taken for each element type.  To check the
 246 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
 247 ;;; READ-N-BYTES:
 248 ;;;
 249 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
 250 ;;;
 251 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
 252 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
 253
 254 (with-test (:name (read-sequence type-error))
 255   (let ((pathname (scratch-file-name)))
 256
 257     ;; Create the binary data.
 258     (with-open-file (stream pathname
 259                             :direction :output
 260                             :if-exists :supersede
 261                             :element-type '(unsigned-byte 8))
 262       (write-byte 255 stream))
 263
 264     ;; Check the slow path for generic vectors.
 265     (let ((sequence (make-array 1)))
 266       (with-open-file (stream pathname
 267                               :direction :input
 268                               :element-type '(unsigned-byte 8))
 269         (read-sequence sequence stream)
 270         (assert (equalp sequence #(255)))))
 271
 272     (let ((sequence (make-array 1)))
 273       (with-open-file (stream pathname
 274                               :direction :input
 275                               :external-format :latin-1
 276                               :element-type 'character)
 277         (read-sequence sequence stream)
 278         (assert (equalp sequence #(#.(code-char 255))))))
 279
 280     ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
 281     ;; 8) vectors.
 282     (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 283       (with-open-file (stream pathname
 284                               :direction :input
 285                               :element-type '(unsigned-byte 8))
 286         (read-sequence sequence stream)
 287         (assert (equalp sequence #(255)))))
 288
 289     (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 290       (with-open-file (stream pathname
 291                               :direction :input
 292                               :element-type '(signed-byte 8))
 293         (read-sequence sequence stream)
 294         (assert (equalp sequence #(-1)))))
 295
 296     ;; A bivalent stream can be read to a unsigned-byte vector, a
 297     ;; string, or a generic vector
 298
 299     (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 300       (with-open-file (stream pathname
 301                               :direction :input
 302                               :element-type :default)
 303         (read-sequence sequence stream)
 304         (assert (equalp sequence #(255)))))
 305
 306     (let ((sequence (make-array 1 :element-type 'character)))
 307       (with-open-file (stream pathname
 308                               :direction :input
 309                               :external-format :latin-1
 310                               :element-type :default)
 311         (read-sequence sequence stream)
 312         (assert (equalp sequence #(#.(code-char 255))))))
 313
 314     (let ((sequence (make-array 1)))
 315       (with-open-file (stream pathname
 316                               :direction :input
 317                               :external-format :latin-1
 318                               :element-type :default)
 319         (read-sequence sequence stream)
 320         (assert (equalp sequence #(#.(code-char 255))))))
 321
 322     ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
 323     ;; stream) pairs.
 324
 325     (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 326       (with-open-file (stream pathname
 327                               :direction :input
 328                               :element-type '(unsigned-byte 8))
 329         (handler-case (progn
 330                         (read-sequence sequence stream)
 331                         (error "READ-SEQUENCE didn't signal an error"))
 332           (type-error (condition)
 333             (assert (= (type-error-datum condition) 255))
 334             (assert (subtypep (type-error-expected-type condition)
 335                               '(signed-byte 8)))))))
 336
 337     (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 338       (with-open-file (stream pathname
 339                               :direction :input
 340                               :element-type '(signed-byte 8))
 341         (handler-case (progn
 342                         (read-sequence sequence stream)
 343                         (error "READ-SEQUENCE didn't signal an error"))
 344           (type-error (condition)
 345             (assert (= (type-error-datum condition) -1))
 346             (assert (subtypep (type-error-expected-type condition)
 347                               '(unsigned-byte 8)))))))
 348
 349     ;; Can't read a signed-byte from a bivalent stream
 350
 351     (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 352       (with-open-file (stream pathname
 353                               :direction :input
 354                               :external-format :latin1
 355                               :element-type :default)
 356         (handler-case (progn
 357                         (read-sequence sequence stream)
 358                         (error "READ-SEQUENCE didn't signal an error"))
 359           (type-error (condition)
 360             (assert (eql (type-error-datum condition) 255))
 361             (assert (subtypep (type-error-expected-type condition)
 362                               '(signed-byte 8)))))))
 363     (delete-file pathname)))
 364 \f
 365 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
 366 ;;; write a sequence element.
 367 ;;;
 368 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
 369 ;;; or slow paths are being taken for each element type.  See the
 370 ;;; READ-SEQUENCE tests above for more information.
 371 ;;;
 372 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered)
 373
 374 (with-test (:name (write-sequence type-error))
 375   (let ((pathname (scratch-file-name))
 376         (generic-sequence (make-array 1 :initial-contents '(255)))
 377         (generic-character-sequence (make-array 1 :initial-element #\a))
 378         (generic-mixed-sequence (make-array 2 :initial-element #\a))
 379         (string (make-array 1 :element-type 'character
 380                               :initial-element (code-char 255)))
 381         (unsigned-sequence (make-array 1
 382                                        :element-type '(unsigned-byte 8)
 383                                        :initial-contents '(255)))
 384         (signed-sequence (make-array 1
 385                                      :element-type '(signed-byte 8)
 386                                      :initial-contents '(-1))))
 387
 388     (setf (aref generic-mixed-sequence 1) 255)
 389
 390     ;; Check the slow path for generic vectors.
 391     (with-open-file (stream pathname
 392                             :direction :output
 393                             :if-exists :supersede
 394                             :element-type '(unsigned-byte 8))
 395       (write-sequence generic-sequence stream))
 396
 397     (with-open-file (stream pathname
 398                             :direction :output
 399                             :if-exists :supersede
 400                             :element-type 'character)
 401       (write-sequence generic-character-sequence stream))
 402
 403     ;; Check the fast path for unsigned and signed vectors.
 404     (with-open-file (stream pathname
 405                             :direction :output
 406                             :if-exists :supersede
 407                             :element-type '(unsigned-byte 8))
 408       (write-sequence unsigned-sequence stream))
 409
 410     (with-open-file (stream pathname
 411                             :direction :output
 412                             :if-exists :supersede
 413                             :element-type '(signed-byte 8))
 414       (write-sequence signed-sequence stream))
 415
 416     ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
 417     ;; vector with mixed characters and bytes
 418
 419     (with-open-file (stream pathname
 420                             :direction :output
 421                             :if-exists :supersede
 422                             :element-type :default)
 423       (write-sequence unsigned-sequence stream))
 424
 425     (with-open-file (stream pathname
 426                             :direction :output
 427                             :external-format :latin-1
 428                             :if-exists :supersede
 429                             :element-type :default)
 430       (write-sequence string stream))
 431
 432     (with-open-file (stream pathname
 433                             :direction :output
 434                             :external-format :latin-1
 435                             :if-exists :supersede
 436                             :element-type :default)
 437       (write-sequence generic-mixed-sequence stream))
 438
 439     ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
 440     ;; which are incompatible with the stream element type.
 441     (with-open-file (stream pathname
 442                             :direction :output
 443                             :if-exists :supersede
 444                             :element-type '(signed-byte 8))
 445       (handler-case (progn
 446                       (write-sequence unsigned-sequence stream)
 447                       (error "WRITE-SEQUENCE didn't signal an error"))
 448         (type-error (condition)
 449           (assert (= (type-error-datum condition) 255))
 450           (assert (subtypep (type-error-expected-type condition)
 451                             '(signed-byte 8))))))
 452
 453     (with-open-file (stream pathname
 454                             :direction :output
 455                             :if-exists :supersede
 456                             :element-type '(unsigned-byte 8))
 457       (handler-case (progn
 458                       (write-sequence signed-sequence stream)
 459                       (error "WRITE-SEQUENCE didn't signal an error"))
 460         (type-error (condition)
 461           (assert (= (type-error-datum condition) -1))
 462           (assert (subtypep (type-error-expected-type condition)
 463                             '(unsigned-byte 8))))))
 464
 465     (with-open-file (stream pathname
 466                             :direction :output
 467                             :if-exists :supersede
 468                             :element-type :default)
 469       (handler-case (progn
 470                       (write-sequence signed-sequence stream)
 471                       (error "WRITE-SEQUENCE didn't signal an error"))
 472         (type-error (condition)
 473           (assert (= (type-error-datum condition) -1))
 474           (assert (subtypep (type-error-expected-type condition)
 475                             '(unsigned-byte 8))))))
 476
 477     (delete-file pathname)))
 478
 479 ;;; writing looong lines. takes way too long and way too much space
 480 ;;; to test on 64 bit platforms
 481 (with-test (:name (:write-char :long-lines :stream-ouput-column)
 482             :skipped-on :64-bit)
 483   (let ((test (scratch-file-name)))
 484     (unwind-protect
 485          (with-open-file (f test
 486                             :direction :output
 487                             :external-format :ascii
 488                             :element-type 'character
 489                             :if-does-not-exist :create
 490                             :if-exists :supersede)
 491            (let* ((n (truncate most-positive-fixnum 16))
 492                   (m 18)
 493                   (p (* n m))
 494                   (buffer (make-string n)))
 495              (dotimes (i m)
 496                (write-char #\.)
 497                (finish-output)
 498                (write-sequence buffer f))
 499              (assert (= p (sb-impl::fd-stream-output-column f)))
 500              (write-char #\! f)
 501              (assert (= (+ 1 p) (sb-impl::fd-stream-output-column f)))
 502              (assert (typep p 'bignum))))
 503       (when (probe-file test)
 504         (delete-file test)))))
 505
 506 ;;; read-sequence misreported the amount read and lost position
 507 (with-test (:name (read-sequence :read-elements))
 508   (let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
 509                             :element-type 'character))
 510         (file (scratch-file-name)))
 511     (dotimes (i (length string))
 512       (setf (char string i) (code-char (mod i char-code-limit))))
 513     (with-open-file (f file
 514                        :if-exists :supersede
 515                        :direction :output
 516                        :external-format :utf-8)
 517       (write-sequence string f))
 518     (let ((copy
 519             (with-open-file (f file
 520                                :if-does-not-exist :error
 521                                :direction :input
 522                                :external-format :utf-8)
 523               (let ((buffer (make-array 128 :element-type 'character))
 524                     (total 0))
 525                 (with-output-to-string (datum)
 526                   (loop for n-read = (read-sequence buffer f)
 527                         do (write-sequence buffer datum :start 0 :end n-read)
 528                            (assert (<= (incf total n-read) (length string)))
 529                         while (and (= n-read 128))))))))
 530       (assert (equal copy string)))
 531     (delete-file file)))
 532
 533 ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
 534 ;;; target was an ANSI stream, but it could be a user-defined stream,
 535 ;;; e.g., a SLIME stream.
 536 (defclass user-output-stream (fundamental-output-stream)
 537   ())
 538
 539 (with-test (:name (make-synonym-stream :user-defined output-stream-p))
 540   (let ((*stream* (make-instance 'user-output-stream)))
 541     (declare (special *stream*))
 542     (with-open-stream (stream (make-synonym-stream '*stream*))
 543       (assert (output-stream-p stream)))))
 544
 545 (defclass user-input-stream (fundamental-input-stream)
 546   ())
 547
 548 (with-test (:name (make-synonym-stream :user-defined input-stream-p))
 549   (let ((*stream* (make-instance 'user-input-stream)))
 550     (declare (special *stream*))
 551     (with-open-stream (stream (make-synonym-stream '*stream*))
 552       (assert (input-stream-p stream)))))
 553
 554 ;;; READ-LINE on ANSI-STREAM did not return T for the last line
 555 ;;; (reported by Yoshinori Tahara)
 556 (with-test (:name (read-line :last-line))
 557   (let ((pathname (scratch-file-name)))
 558     (with-open-file (out pathname :direction :output :if-exists :supersede)
 559       (format out "a~%b"))
 560     (let ((result (with-open-file (in pathname)
 561                     (list (multiple-value-list (read-line in nil nil))
 562                           (multiple-value-list (read-line in nil nil))
 563                           (multiple-value-list (read-line in nil nil))))))
 564       (delete-file pathname)
 565       (assert (equal result '(("a" nil) ("b" t) (nil t)))))))
 566
 567 ;;; READ-LINE used to work on closed streams because input buffers were left in place
 568 (with-test (:name (close read-line :bug-425))
 569   ;; Normal close
 570   (let ((f (open *this-file* :direction :input)))
 571     (assert (stringp (read-line f)))
 572     (close f)
 573     (assert-error (read-line f) sb-int:closed-stream-error))
 574   ;; Abort
 575   (let ((f (open *this-file* :direction :input)))
 576     (assert (stringp (read-line f nil nil)))
 577     (close f :abort t)
 578     (assert-error (read-line f) sb-int:closed-stream-error)))
 579
 580 (with-test (:name :regression-1.0.12.22)
 581   (with-open-file (s *this-file* :direction :input)
 582     (let ((buffer (make-string 20)))
 583       (assert (= 2 (read-sequence buffer s :start 0 :end 2)))
 584       (assert (= 3 (read-sequence buffer s :start 2 :end 3)))
 585       (file-position s :end)
 586       (assert (= 3 (read-sequence buffer s :start 3))))))
 587
 588 ;;; In 1.0.27 (and also 0.9.16; presumably in between, too), binary
 589 ;;; input operations on a bivalent stream did something bad after
 590 ;;; unread-char: READ-BYTE would return the character, and
 591 ;;; READ-SEQUENCE into a byte buffer would lose when attempting to
 592 ;;; store the character in the vector.
 593 (with-test (:name (:bivalent stream unread-char read-byte))
 594   (let ((pathname (scratch-file-name)))
 595     (with-open-file (s pathname
 596                        :element-type :default
 597                        :direction :io :if-exists :rename)
 598       (write-char #\a s)
 599       (file-position s :start)
 600       (unread-char (read-char s) s)
 601       (assert (integerp (read-byte s))))
 602     (delete-file pathname)))
 603
 604 (with-test (:name (:bivalent stream unread-char read-sequence))
 605   (let ((pathname (scratch-file-name)))
 606     (with-open-file (s pathname
 607                        :element-type :default
 608                        :direction :io :if-exists :rename)
 609       (write-char #\a s)
 610       (file-position s :start)
 611       (unread-char (read-char s) s)
 612       (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
 613                 (read-sequence buffer s))))
 614     (delete-file pathname)))
 615
 616 (with-test (:name (:bivalent stream unread-char read-byte :utf8)
 617             :skipped-on (:not :sb-unicode))
 618   (let ((pathname (scratch-file-name)))
 619     (with-open-file (s pathname
 620                        :element-type :default
 621                        :direction :io :if-exists :rename
 622                        :external-format :utf8)
 623       (write-char (code-char 192) s)
 624       (file-position s :start)
 625       (unread-char (read-char s) s)
 626       (assert (integerp (read-byte s))))
 627     (delete-file pathname)))
 628
 629 (with-test (:name (:bivalent stream unread-char read-sequence :utf8)
 630             :skipped-on (:not :sb-unicode))
 631   (let ((pathname (scratch-file-name)))
 632     (with-open-file (s pathname
 633                        :element-type :default
 634                        :direction :io :if-exists :rename
 635                        :external-format :utf8)
 636       (write-char (code-char 192) s)
 637       (file-position s :start)
 638       (unread-char (read-char s) s)
 639       (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
 640                 (read-sequence buffer s))))
 641     (delete-file pathname)))
 642
 643 (with-test (:name (delete-file :on stream))
 644   (with-open-file (f (scratch-file-name)
 645                      :direction :io)
 646     (delete-file f)
 647     #-win32
 648     (progn
 649       (write-line "still open" f)
 650       (file-position f :start)
 651       (assert (equal "still open" (read-line f)))))
 652   (assert (not (probe-file "delete-file-on-stream-test.tmp"))))
 653 \f
 654 ;;; READ-CHAR-NO-HANG on bivalent streams (as returned by RUN-PROGRAM)
 655 ;;; was wrong.  CSR managed to promote the wrongness to all streams in
 656 ;;; the 1.0.32.x series, breaking slime instantly.
 657 (with-test (:name (read-char :no-hang-after unread-char) :skipped-on :win32)
 658   (let* ((process (run-program "/bin/sh" '("-c" "echo a && sleep 10")
 659                                :output :stream :wait nil))
 660          (stream (process-output process))
 661          (char (read-char stream)))
 662     (assert (char= char #\a))
 663     (unread-char char stream)
 664     (assert (char= (read-char stream) #\a))
 665     (assert (char= (read-char stream) #\Newline))
 666     (let ((time (get-universal-time)))
 667       ;; no input, not yet known to be at EOF: should return
 668       ;; immediately
 669       (read-char-no-hang stream)
 670       (assert (< (- (get-universal-time) time) 2)))))
 671
 672 #-win32
 673 (with-test (:name (open :interrupt)
 674                   :skipped-on (or :win32 (:and :darwin :sb-safepoint)))
 675   (let ((to 0))
 676     (with-scratch-file (fifo)
 677            ;; Make a FIFO
 678            (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
 679            ;; Try to open it (which hangs), and interrupt ourselves with a timer,
 680            ;; continue (this used to result in an error due to open(2) returning with
 681            ;; EINTR, then interupt again and unwind.
 682            (handler-case
 683                (with-timeout 2
 684                  (handler-bind ((timeout (lambda (c)
 685                                            (when (eql 1 (incf to))
 686                                              (continue c)))))
 687                    (with-timeout 1
 688                      (with-open-file (f fifo :direction :input)
 689                        :open))))
 690              (timeout ()
 691                (if (eql 2 to)
 692                    :timeout
 693                    :wtf))
 694              (error (e)
 695                e)))))
 696
 697 ;; We used to not return from read on a named pipe unless the external-format
 698 ;; routine had filled an input buffer. Now we'll return as soon as a request
 699 ;; is satisfied, or on EOF. (https://bugs.launchpad.net/sbcl/+bug/643686)
 700 #-win32
 701 (with-test (:name :overeager-character-buffering :skipped-on :win32)
 702   (let ((use-threads #+sb-thread t)
 703         (proc nil)
 704         (sem (sb-thread:make-semaphore)))
 705     (sb-int:dovector (entry sb-impl::*external-formats*)
 706       (unless entry (return))
 707       (with-scratch-file (fifo)
 708         (unwind-protect
 709             (let ((format
 710                     (car (sb-impl::ef-names (car (sb-int:ensure-list entry))))))
 711               (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
 712               ;; KLUDGE: because we have both ends in the same process, we would
 713               ;; need to use O_NONBLOCK, but this works too.
 714               ;; Prefer to use threads rather than processes, as the test
 715               ;; execute significantly faster.
 716               ;; Note also that O_NONBLOCK would probably counteract the original
 717               ;; bug, so it's better that we eschew O_NONBLOCK.
 718               (cond (use-threads
 719                      (setf proc
 720                            (make-kill-thread
 721                             (lambda ()
 722                               (with-open-file (f fifo :direction :output
 723                                                       :if-exists :overwrite
 724                                                       :external-format format)
 725                                 (sb-thread:wait-on-semaphore sem)
 726                                 (write-line "foobar" f)
 727                                 (finish-output f)
 728                                 (sleep most-positive-fixnum))))))
 729                     (t
 730                      (setf proc
 731                            (run-program "/bin/sh"
 732                                    (list "-c"
 733                                          (format nil "cat > ~A" (native-namestring fifo)))
 734                                    :input :stream
 735                                    :wait nil
 736                                    :external-format format))
 737                      (write-line "foobar" (process-input proc))
 738                      (finish-output (process-input proc))))
 739               ;; Whether we're using threads or processes, the writer isn't
 740               ;; injecting any more input, but isn't indicating EOF either.
 741               (with-open-file (f fifo :direction :input :external-format format)
 742                 #+sb-thread
 743                 (sb-thread:signal-semaphore sem)
 744                 (assert (equal "foobar" (read-line f)))))
 745           (when proc
 746             (cond (use-threads (sb-thread:terminate-thread proc))
 747                   (t (ignore-errors
 748                       (close (process-input proc) :abort t)
 749                       (process-wait proc))
 750                      (ignore-errors (process-close proc))))
 751             (setf proc nil)))))))
 752
 753 (with-test (:name :bug-657183 :skipped-on (not :sb-unicode))
 754   #+sb-unicode
 755   (let ((name (scratch-file-name))
 756         (text '(#\GREEK_SMALL_LETTER_LAMDA
 757                 #\JAPANESE_BANK_SYMBOL
 758                 #\Space
 759                 #\HEAVY_BLACK_HEART))
 760         (positions '(2 5 6 9))
 761         (sb-impl::*default-external-format* :utf-8))
 762     (unwind-protect
 763          (progn
 764            (with-open-file (f name :external-format :default :direction :output
 765                               :if-exists :supersede)
 766              (assert (eql 0 (file-position f)))
 767              (mapc (lambda (char pos)
 768                      (write-char char f)
 769                      (assert (eql pos (file-position f))))
 770                    text
 771                    positions))
 772            (with-open-file (f name :external-format :default :direction :input)
 773              (assert (eql 0 (file-position f)))
 774              (assert (eql (pop text) (read-char f)))
 775              (assert (eql (file-position f) 2))
 776              (assert (eql (pop text) (read-char f)))
 777              (assert (eql (file-position f) 5))
 778              (assert (eql (pop text) (read-char f)))
 779              (assert (eql (file-position f) 6))
 780              (assert (eql (pop text) (read-char f)))
 781              (assert (eql (file-position f) 9))
 782              (assert (eql (file-length f) 9))))
 783       (ignore-errors (delete-file name)))))
 784
 785 (with-test (:name :bug-561642)
 786   (let ((p (scratch-file-name)))
 787     (unwind-protect
 788          (progn
 789            (with-open-file (f p
 790                               :if-exists :supersede
 791                               :if-does-not-exist :create
 792                               :direction :output)
 793              (write-line "FOOBAR" f))
 794            (with-open-file (f p
 795                               :if-exists :append
 796                               :direction :output)
 797              (let ((p0 (file-position f))
 798                    (p1 (progn
 799                          (write-char #\newline f)
 800                          (file-position f)))
 801                    (p2 (progn
 802                          (write-char #\newline f)
 803                          (finish-output f)
 804                          (file-position f))))
 805                (assert (eql 7 p0))
 806                (assert (eql 8 p1))
 807                (assert (eql 9 p2)))))
 808       (ignore-errors (delete-file p)))))
 809
 810 (defun mock-fd-stream-in-fun (stream eof-err-p eof-val)
 811   (sb-impl::eof-or-lose stream eof-err-p eof-val))
 812 (declaim (ftype function mock-fd-stream-n-bin-fun))
 813
 814 (defstruct (mock-fd-stream
 815             (:constructor %make-mock-fd-stream (buffer-chain))
 816             (:include sb-impl::ansi-stream
 817                       (in #'mock-fd-stream-in-fun)
 818                       (n-bin #'mock-fd-stream-n-bin-fun)
 819                       (cin-buffer
 820                        (make-array sb-impl::+ansi-stream-in-buffer-length+
 821                                    :element-type 'character))
 822                       (csize-buffer
 823                        (make-array sb-impl::+ansi-stream-in-buffer-length+
 824                                    :element-type '(unsigned-byte 8)))))
 825   buffer-chain)
 826
 827 (defun make-mock-fd-stream (buffer-chain)
 828   ;; For notational convenience, #\| becomes #\Newline.
 829   (%make-mock-fd-stream
 830    (mapcar (lambda (x) (substitute #\Newline #\| x)) buffer-chain)))
 831
 832 (defun mock-fd-stream-n-bin-fun (stream char-buf size-buf start count eof-err-p)
 833   (cond ((mock-fd-stream-buffer-chain stream)
 834          (let* ((chars (pop (mock-fd-stream-buffer-chain stream)))
 835                 (n-chars (length chars)))
 836            ;; make sure the mock object is being used as expected.
 837            (assert (>= count (length chars)))
 838            (replace char-buf chars :start1 start)
 839            (fill size-buf 1 :start start :end (+ start n-chars))
 840            n-chars))
 841         (t
 842          (sb-impl::eof-or-lose stream eof-err-p 0))))
 843
 844 (with-test (:name :read-chunk-from-frc-buffer)
 845   (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo|bar" "hi"))))
 846     (multiple-value-bind (line eofp)
 847         (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
 848       (assert (and (string= line "zabcdefghfoo") (not eofp))))
 849     (multiple-value-bind (line eofp)
 850         (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
 851       (assert (and (string= line "barhi") eofp)))
 852     (multiple-value-bind (line eofp)
 853         (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
 854       (assert (and (eq line 'woot) eofp))))
 855   (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo*bar" "hi")))
 856         (string (make-string 100)))
 857     (let ((endpos
 858            (sb-impl::ansi-stream-read-string-from-frc-buffer string s 10 nil)))
 859       (assert (and (= endpos 28)
 860                    (string= (subseq string 10 endpos) "zabcdefghfoo*barhi"))))
 861     (let ((endpos
 862            (sb-impl::ansi-stream-read-string-from-frc-buffer string s 0 nil)))
 863       (assert (= endpos 0)))))
 864
 865 (with-test (:name :named-pipe-wait-eof)
 866   (let* ((process (run-program "cat" '() :search t
 867                                :wait nil :input nil :output :stream))
 868          (out (process-output process)))
 869     (sb-sys:wait-until-fd-usable (sb-sys:fd-stream-fd out) :input)
 870     (assert (null (read-byte (process-output process) nil nil)))
 871     (process-close process)))
 872
 873 (with-test (:name :concatenated-stream-listen)
 874   (let ((file (scratch-file-name)))
 875     (with-open-file (stream file :direction :output :if-exists :supersede)
 876       (write-line "abc" stream))
 877     (with-open-file (stream file)
 878       (let ((cs (make-concatenated-stream stream)))
 879         (read-char-no-hang cs)
 880         (assert (listen cs))))
 881     (delete-file file)))