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 (load "assertoid.lisp")
  15 (use-package "ASSERTOID")
  16
  17 ;;; type errors for inappropriate stream arguments, fixed in
  18 ;;; sbcl-0.7.8.19
  19 (locally
  20     (declare (optimize (safety 3)))
  21   (assert (raises-error? (make-two-way-stream (make-string-output-stream)
  22                                               (make-string-output-stream))
  23                          type-error))
  24   (assert (raises-error? (make-two-way-stream (make-string-input-stream "foo")
  25                                               (make-string-input-stream "bar"))
  26                          type-error))
  27   ;; the following two aren't actually guaranteed, because ANSI, as it
  28   ;; happens, doesn't say "should signal an error" for
  29   ;; MAKE-ECHO-STREAM. It's still good to have, but if future
  30   ;; maintenance work causes this test to fail because of these
  31   ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses
  32   ;; from the test. -- CSR, 2002-10-06
  33   (assert (raises-error? (make-echo-stream (make-string-output-stream)
  34                                            (make-string-output-stream))
  35                          type-error))
  36   (assert (raises-error? (make-echo-stream (make-string-input-stream "foo")
  37                                            (make-string-input-stream "bar"))
  38                          type-error))
  39   (assert (raises-error? (make-concatenated-stream
  40                           (make-string-output-stream)
  41                           (make-string-input-stream "foo"))
  42                          type-error)))
  43
  44 ;;; bug 225: STRING-STREAM was not a class
  45 (eval `(defgeneric bug225 (s)
  46          ,@(mapcar (lambda (class)
  47                      `(:method :around ((s ,class)) (cons ',class (call-next-method))))
  48                    '(stream string-stream sb-impl::string-input-stream
  49                      sb-impl::string-output-stream))
  50          (:method (class) nil)))
  51
  52 (assert (equal (bug225 (make-string-input-stream "hello"))
  53                '(sb-impl::string-input-stream string-stream stream)))
  54 (assert (equal (bug225 (make-string-output-stream))
  55                '(sb-impl::string-output-stream string-stream stream)))
  56
  57 \f
  58 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
  59 (let ((p "signed-byte-8-test.data"))
  60   (with-open-file (s p
  61                      :direction :output
  62                      :element-type '(unsigned-byte 8)
  63                      :if-exists :supersede)
  64     (write-byte 255 s))
  65   (with-open-file (s p :element-type '(signed-byte 8))
  66     (assert (= (read-byte s) -1)))
  67   (delete-file p))
  68 \f
  69 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
  70 ;;; Milan Zamazal)
  71 (let* ((p "this-file-will-exist")
  72        (stream (close (open p :direction :output :if-exists :error))))
  73   (unwind-protect
  74        (progn
  75          (assert
  76           (null (with-open-file (s p :direction :output :if-exists nil) s)))
  77          (assert
  78           (raises-error?
  79            (with-open-file (s p :direction :output :if-exists :error)))))
  80       (delete-file p)))
  81 \f
  82 (assert (raises-error? (read-byte (make-string-input-stream "abc"))
  83                        type-error))
  84 (assert (raises-error? (with-open-file (s "/dev/zero")
  85                          (read-byte s))
  86                        type-error))
  87 ;;; bidirectional streams getting confused about their position
  88 (let ((p "bidirectional-stream-test"))
  89   (with-open-file (s p :direction :output :if-exists :supersede)
  90     (with-standard-io-syntax
  91       (format s "~S ~S ~S~%" 'these 'are 'symbols)))
  92   (with-open-file (s p :direction :io :if-exists :overwrite)
  93     (read s)
  94     (with-standard-io-syntax
  95       (prin1 'insert s)))
  96   (with-open-file (s p)
  97     (let ((line (read-line s))
  98           (want "THESE INSERTMBOLS"))
  99       (unless (equal line want)
 100         (error "wanted ~S, got ~S" want line))))
 101   (delete-file p))
 102 \f
 103 ;;; :DIRECTION :IO didn't work on non-existent pathnames
 104 (let ((p "direction-io-test"))
 105   (ignore-errors (delete-file p))
 106   (with-open-file (s p :direction :io)
 107     (format s "1")
 108     (finish-output s)
 109     (file-position s :start)
 110     (assert (char= (read-char s) #\1)))
 111   (delete-file p))
 112 \f
 113 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
 114 (assert (= 0 (file-position (make-broadcast-stream))))
 115 (assert (file-position (make-broadcast-stream) :start))
 116 (assert (file-position (make-broadcast-stream) 0))
 117 (assert (not (file-position (make-broadcast-stream) 1)))
 118 (let ((s (make-broadcast-stream)))
 119   (write-char #\a s)
 120   (assert (not (file-position s 1)))
 121   (assert (= 0 (file-position s))))
 122
 123 (let ((p "broadcast-stream-test"))
 124   (ignore-errors (delete-file p))
 125   (with-open-file (f p :direction :output)
 126     (let ((s (make-broadcast-stream f)))
 127       (assert (= 0 (file-position s)))
 128       (assert (file-position s :start))
 129       (assert (file-position s 0))
 130       (write-char #\a s)
 131       (assert (= 1 (file-position s))) ; unicode...
 132       (assert (file-position s 0))))
 133   (delete-file p))
 134
 135 ;;; CLOSING a non-new streams should not delete them, and superseded
 136 ;;; files should be restored.
 137 (let ((test "test-file-for-close-should-not-delete"))
 138   (macrolet ((test-mode (mode)
 139                `(progn
 140                  (catch :close-test-exit
 141                    (with-open-file (f test :direction :output :if-exists ,mode)
 142                      (write-line "test" f)
 143                      (throw :close-test-exit t)))
 144                  (assert (and (probe-file test) ,mode)))))
 145     (unwind-protect
 146          (progn
 147            (with-open-file (f test :direction :output)
 148              (write-line "test" f))
 149            (test-mode :append)
 150            (test-mode :overwrite)
 151            ;; FIXME: We really should recover supersede files as well, according to
 152            ;; CLOSE in CLHS, but at the moment we don't.
 153            ;; (test-mode :supersede)
 154            (test-mode :rename)
 155            (test-mode :rename-and-delete))
 156       (when (probe-file test)
 157         (delete-file test)))))
 158
 159 ;;; test for read-write invariance of signed bytes, from Bruno Haible
 160 ;;; cmucl-imp 2004-09-06
 161 (defun bin-stream-test (&key (size (integer-length most-positive-fixnum))
 162                         (type 'unsigned-byte) (file-name "stream-impure.tmp")
 163                         (num-bytes 10)
 164                         (bytes (if (eq type 'signed-byte)
 165                                    (loop :repeat num-bytes :collect
 166                                          (- (random (ash 1 size))
 167                                             (ash 1 (1- size))))
 168                                    (loop :repeat num-bytes :collect
 169                                          (random (ash 1 size))))))
 170   (with-open-file (foo file-name :direction :output :if-exists :supersede
 171                        :element-type (list type size))
 172     (dolist (byte bytes)
 173       (write-byte byte foo)))
 174   (unwind-protect
 175        (with-open-file (foo file-name :direction :input
 176                             :element-type (list type size))
 177          (list (stream-element-type foo) (file-length foo) bytes
 178                (loop :for byte :in bytes :for nb = (read-byte foo) :collect nb
 179                      :unless (= nb byte) :do
 180                      (flet ((by-out (sz by)
 181                               (format nil "~v,'0,' ,4:b"
 182                                       (+ sz (floor sz 4)) by)))
 183                        (error "~& * [(~s ~s)] ~a != ~a~%" type size
 184                               (by-out size byte) (by-out size nb))))))
 185     (delete-file file-name)))
 186 (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte))
 187 \f
 188 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
 189 ;;; contain a stream element.
 190 ;;;
 191 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
 192 ;;; or slow paths are being taken for each element type.  To check the
 193 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
 194 ;;; READ-N-BYTES:
 195 ;;;
 196 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
 197 ;;;
 198 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
 199 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
 200
 201 (let ((pathname "read-sequence.data"))
 202
 203   ;; Create the binary data.
 204   (with-open-file (stream pathname
 205                           :direction :output
 206                           :if-exists :supersede
 207                           :element-type '(unsigned-byte 8))
 208     (write-byte 255 stream))
 209
 210   ;; Check the slow path for generic vectors.
 211   (let ((sequence (make-array 1)))
 212     (with-open-file (stream pathname
 213                             :direction :input
 214                             :element-type '(unsigned-byte 8))
 215     (read-sequence sequence stream)
 216     (assert (equalp sequence #(255)))))
 217
 218   (let ((sequence (make-array 1)))
 219     (with-open-file (stream pathname
 220                             :direction :input
 221                             :external-format :latin-1
 222                             :element-type 'character)
 223       (read-sequence sequence stream)
 224       (assert (equalp sequence #(#.(code-char 255))))))
 225
 226   ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
 227   ;; 8) vectors.
 228   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 229     (with-open-file (stream pathname
 230                             :direction :input
 231                             :element-type '(unsigned-byte 8))
 232       (read-sequence sequence stream)
 233       (assert (equalp sequence #(255)))))
 234
 235   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 236     (with-open-file (stream pathname
 237                             :direction :input
 238                             :element-type '(signed-byte 8))
 239     (read-sequence sequence stream)
 240     (assert (equalp sequence #(-1)))))
 241
 242   ;; A bivalent stream can be read to a unsigned-byte vector, a
 243   ;; string, or a generic vector
 244
 245   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 246     (with-open-file (stream pathname
 247                             :direction :input
 248                             :element-type :default)
 249       (read-sequence sequence stream)
 250       (assert (equalp sequence #(255)))))
 251
 252   (let ((sequence (make-array 1 :element-type 'character)))
 253     (with-open-file (stream pathname
 254                             :direction :input
 255                             :external-format :latin-1
 256                             :element-type :default)
 257       (read-sequence sequence stream)
 258       (assert (equalp sequence #(#.(code-char 255))))))
 259
 260   (let ((sequence (make-array 1)))
 261     (with-open-file (stream pathname
 262                             :direction :input
 263                             :external-format :latin-1
 264                             :element-type :default)
 265       (read-sequence sequence stream)
 266       (assert (equalp sequence #(#.(code-char 255))))))
 267
 268   ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
 269   ;; stream) pairs.
 270
 271   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 272     (with-open-file (stream pathname
 273                             :direction :input
 274                             :element-type '(unsigned-byte 8))
 275       (handler-case (progn
 276                       (read-sequence sequence stream)
 277                       (error "READ-SEQUENCE didn't signal an error"))
 278         (type-error (condition)
 279           (assert (= (type-error-datum condition) 255))
 280           (assert (subtypep (type-error-expected-type condition)
 281                             '(signed-byte 8)))))))
 282
 283   (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
 284     (with-open-file (stream pathname
 285                             :direction :input
 286                             :element-type '(signed-byte 8))
 287       (handler-case (progn
 288                       (read-sequence sequence stream)
 289                       (error "READ-SEQUENCE didn't signal an error"))
 290         (type-error (condition)
 291           (assert (= (type-error-datum condition) -1))
 292           (assert (subtypep (type-error-expected-type condition)
 293                             '(unsigned-byte 8)))))))
 294
 295   ;; Can't read a signed-byte from a bivalent stream
 296
 297   (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
 298     (with-open-file (stream pathname
 299                             :direction :input
 300                             :external-format :latin1
 301                             :element-type :default)
 302       (handler-case (progn
 303                       (read-sequence sequence stream)
 304                       (error "READ-SEQUENCE didn't signal an error"))
 305         (type-error (condition)
 306           (assert (eql (type-error-datum condition) (code-char 255)))
 307           (assert (subtypep (type-error-expected-type condition)
 308                             '(signed-byte 8)))))))
 309   (delete-file pathname))
 310 \f
 311 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
 312 ;;; write a sequence element.
 313 ;;;
 314 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
 315 ;;; or slow paths are being taken for each element type.  See the
 316 ;;; READ-SEQUENCE tests above for more information.
 317 ;;;
 318 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
 319
 320 (let ((pathname "write-sequence.data")
 321       (generic-sequence (make-array 1 :initial-contents '(255)))
 322       (generic-character-sequence (make-array 1 :initial-element #\a))
 323       (generic-mixed-sequence (make-array 2 :initial-element #\a))
 324       (string (make-array 1 :element-type 'character
 325                           :initial-element (code-char 255)))
 326       (unsigned-sequence (make-array 1
 327                                      :element-type '(unsigned-byte 8)
 328                                      :initial-contents '(255)))
 329       (signed-sequence (make-array 1
 330                                    :element-type '(signed-byte 8)
 331                                    :initial-contents '(-1))))
 332
 333   (setf (aref generic-mixed-sequence 1) 255)
 334
 335   ;; Check the slow path for generic vectors.
 336   (with-open-file (stream pathname
 337                            :direction :output
 338                            :if-exists :supersede
 339                            :element-type '(unsigned-byte 8))
 340     (write-sequence generic-sequence stream))
 341
 342   (with-open-file (stream pathname
 343                           :direction :output
 344                           :if-exists :supersede
 345                           :element-type 'character)
 346     (write-sequence generic-character-sequence stream))
 347
 348   ;; Check the fast path for unsigned and signed vectors.
 349   (with-open-file (stream pathname
 350                           :direction :output
 351                           :if-exists :supersede
 352                           :element-type '(unsigned-byte 8))
 353     (write-sequence unsigned-sequence stream))
 354
 355   (with-open-file (stream pathname
 356                           :direction :output
 357                           :if-exists :supersede
 358                           :element-type '(signed-byte 8))
 359     (write-sequence signed-sequence stream))
 360
 361   ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
 362   ;; vector with mixed characters and bytes
 363
 364   (with-open-file (stream pathname
 365                           :direction :output
 366                           :if-exists :supersede
 367                           :element-type :default)
 368     (write-sequence unsigned-sequence stream))
 369
 370   (with-open-file (stream pathname
 371                           :direction :output
 372                           :external-format :latin-1
 373                           :if-exists :supersede
 374                           :element-type :default)
 375     (write-sequence string stream))
 376
 377   (with-open-file (stream pathname
 378                           :direction :output
 379                           :external-format :latin-1
 380                           :if-exists :supersede
 381                           :element-type :default)
 382     (write-sequence generic-mixed-sequence stream))
 383
 384   ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
 385   ;; which are incompatible with the stream element type.
 386   (with-open-file (stream pathname
 387                           :direction :output
 388                           :if-exists :supersede
 389                           :element-type '(signed-byte 8))
 390     (handler-case (progn
 391                     (write-sequence unsigned-sequence stream)
 392                     (error "WRITE-SEQUENCE didn't signal an error"))
 393       (type-error (condition)
 394         (assert (= (type-error-datum condition) 255))
 395         (assert (subtypep (type-error-expected-type condition)
 396                           '(signed-byte 8))))))
 397
 398   (with-open-file (stream pathname
 399                           :direction :output
 400                           :if-exists :supersede
 401                           :element-type '(unsigned-byte 8))
 402     (handler-case (progn
 403                     (write-sequence signed-sequence stream)
 404                     (error "WRITE-SEQUENCE didn't signal an error"))
 405       (type-error (condition)
 406         (assert (= (type-error-datum condition) -1))
 407         (assert (subtypep (type-error-expected-type condition)
 408                           '(unsigned-byte 8))))))
 409
 410   (with-open-file (stream pathname
 411                           :direction :output
 412                           :if-exists :supersede
 413                           :element-type :default)
 414     (handler-case (progn
 415                     (write-sequence signed-sequence stream)
 416                     (error "WRITE-SEQUENCE didn't signal an error"))
 417       (type-error (condition)
 418         (assert (= (type-error-datum condition) -1))
 419         (assert (subtypep (type-error-expected-type condition)
 420                           '(unsigned-byte 8))))))
 421
 422   (delete-file pathname))
 423
 424 ;;; writing looong lines. takes way too long and way too much space
 425 ;;; to test on 64 bit platforms
 426 #-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or))
 427 (progn
 428   (defun write-n-chars (n stream)
 429     (format t "~&/writing ~D chars on a single line~%" n)
 430     (finish-output t)
 431     (loop repeat n
 432        do (write-char #\x stream))
 433     (terpri stream)
 434     n)
 435
 436   (let ((test "long-lines-write-test.tmp"))
 437     (unwind-protect
 438          (with-open-file (f test
 439                             :direction :output
 440                             :external-format :ascii
 441                             :element-type 'character
 442                             :if-does-not-exist :create
 443                             :if-exists :supersede)
 444          (write-n-chars (+ most-positive-fixnum 7) f))
 445       (when (probe-file test)
 446         (delete-file test)))))
 447
 448 ;;; read-sequence misreported the amount read and lost position
 449 (let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
 450                           :element-type 'character)))
 451   (dotimes (i (length string))
 452     (setf (char string i) (code-char (mod i char-code-limit))))
 453   (with-open-file (f "read-sequence-character-test-data.tmp"
 454                      :if-exists :supersede
 455                      :direction :output
 456                      :external-format :utf-8)
 457     (write-sequence string f))
 458   (let ((copy
 459          (with-open-file (f "read-sequence-character-test-data.tmp"
 460                             :if-does-not-exist :error
 461                             :direction :input
 462                             :external-format :utf-8)
 463            (let ((buffer (make-array 128 :element-type 'character))
 464                  (total 0))
 465              (with-output-to-string (datum)
 466                (loop for n-read = (read-sequence buffer f)
 467                      do (write-sequence buffer datum :start 0 :end n-read)
 468                         (assert (<= (incf total n-read) (length string)))
 469                      while (and (= n-read 128))))))))
 470     (assert (equal copy string)))
 471   (delete-file "read-sequence-character-test-data.tmp"))
 472
 473 ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
 474 ;;; target was an ANSI stream, but it could be a user-defined stream,
 475 ;;; e.g., a SLIME stream.
 476 (defclass user-output-stream (fundamental-output-stream)
 477   ())
 478
 479 (let ((*stream* (make-instance 'user-output-stream)))
 480   (declare (special *stream*))
 481   (with-open-stream (stream (make-synonym-stream '*stream*))
 482     (assert (output-stream-p stream))))
 483
 484 (defclass user-input-stream (fundamental-input-stream)
 485   ())
 486
 487 (let ((*stream* (make-instance 'user-input-stream)))
 488   (declare (special *stream*))
 489   (with-open-stream (stream (make-synonym-stream '*stream*))
 490     (assert (input-stream-p stream))))
 491
 492
 493 ;;; success