;;;; tests related to Lisp streams ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. ;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (load "assertoid.lisp") (use-package "ASSERTOID") ;;; type errors for inappropriate stream arguments, fixed in ;;; sbcl-0.7.8.19 (locally (declare (optimize (safety 3))) (assert (raises-error? (make-two-way-stream (make-string-output-stream) (make-string-output-stream)) type-error)) (assert (raises-error? (make-two-way-stream (make-string-input-stream "foo") (make-string-input-stream "bar")) type-error)) ;; the following two aren't actually guaranteed, because ANSI, as it ;; happens, doesn't say "should signal an error" for ;; MAKE-ECHO-STREAM. It's still good to have, but if future ;; maintenance work causes this test to fail because of these ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses ;; from the test. -- CSR, 2002-10-06 (assert (raises-error? (make-echo-stream (make-string-output-stream) (make-string-output-stream)) type-error)) (assert (raises-error? (make-echo-stream (make-string-input-stream "foo") (make-string-input-stream "bar")) type-error)) (assert (raises-error? (make-concatenated-stream (make-string-output-stream) (make-string-input-stream "foo")) type-error))) ;;; bug 225: STRING-STREAM was not a class (eval `(defgeneric bug225 (s) ,@(mapcar (lambda (class) `(:method :around ((s ,class)) (cons ',class (call-next-method)))) '(stream string-stream sb-impl::string-input-stream sb-impl::string-output-stream)) (:method (class) nil))) (assert (equal (bug225 (make-string-input-stream "hello")) '(sb-impl::string-input-stream string-stream stream))) (assert (equal (bug225 (make-string-output-stream)) '(sb-impl::string-output-stream string-stream stream))) ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau): (let ((p "signed-byte-8-test.data")) (with-open-file (s p :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (write-byte 255 s)) (with-open-file (s p :element-type '(signed-byte 8)) (assert (= (read-byte s) -1))) (delete-file p)) ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by ;;; Milan Zamazal) (let* ((p "this-file-will-exist") (stream (open p :direction :output :if-exists :error))) (assert (null (with-open-file (s p :direction :output :if-exists nil) s))) (assert (raises-error? (with-open-file (s p :direction :output :if-exists :error)))) (close stream) (delete-file p)) (assert (raises-error? (read-byte (make-string-input-stream "abc")) type-error)) (assert (raises-error? (with-open-file (s "/dev/zero") (read-byte s)) type-error)) ;;; bidirectional streams getting confused about their position (let ((p "bidirectional-stream-test")) (with-open-file (s p :direction :output :if-exists :supersede) (with-standard-io-syntax (format s "~S ~S ~S~%" 'these 'are 'symbols))) (with-open-file (s p :direction :io :if-exists :overwrite) (read s) (with-standard-io-syntax (prin1 'insert s))) (with-open-file (s p) (let ((line (read-line s)) (want "THESE INSERTMBOLS")) (unless (equal line want) (error "wanted ~S, got ~S" want line)))) (delete-file p)) ;;; :DIRECTION :IO didn't work on non-existent pathnames (let ((p "direction-io-test")) (ignore-errors (delete-file p)) (with-open-file (s p :direction :io) (format s "1") (finish-output s) (file-position s :start) (assert (char= (read-char s) #\1))) (delete-file p)) ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial (assert (= 0 (file-position (make-broadcast-stream)))) (assert (file-position (make-broadcast-stream) :start)) (assert (file-position (make-broadcast-stream) 0)) (assert (not (file-position (make-broadcast-stream) 1))) (let ((s (make-broadcast-stream))) (write-char #\a s) (assert (not (file-position s 1))) (assert (= 0 (file-position s)))) (let ((p "broadcast-stream-test")) (ignore-errors (delete-file p)) (with-open-file (f p :direction :output) (let ((s (make-broadcast-stream f))) (assert (= 0 (file-position s))) (assert (file-position s :start)) (assert (file-position s 0)) (write-char #\a s) (assert (= 1 (file-position s))) ; unicode... (assert (file-position s 0)))) (delete-file p)) ;;; CLOSING a non-new streams should not delete them, and superseded ;;; files should be restored. (let ((test "test-file-for-close-should-not-delete")) (macrolet ((test-mode (mode) `(progn (catch :close-test-exit (with-open-file (f test :direction :output :if-exists ,mode) (write-line "test" f) (throw :close-test-exit t))) (assert (and (probe-file test) ,mode))))) (unwind-protect (progn (with-open-file (f test :direction :output) (write-line "test" f)) (test-mode :append) (test-mode :overwrite) ;; FIXME: We really should recover supersede files as well, according to ;; CLOSE in CLHS, but at the moment we don't. ;; (test-mode :supersede) (test-mode :rename) (test-mode :rename-and-delete)) (when (probe-file test) (delete-file test))))) ;;; test for read-write invariance of signed bytes, from Bruno Haible ;;; cmucl-imp 2004-09-06 (defun bin-stream-test (&key (size (integer-length most-positive-fixnum)) (type 'unsigned-byte) (file-name "stream-impure.tmp") (num-bytes 10) (bytes (if (eq type 'signed-byte) (loop :repeat num-bytes :collect (- (random (ash 1 size)) (ash 1 (1- size)))) (loop :repeat num-bytes :collect (random (ash 1 size)))))) (with-open-file (foo file-name :direction :output :if-exists :supersede :element-type (list type size)) (dolist (byte bytes) (write-byte byte foo))) (unwind-protect (with-open-file (foo file-name :direction :input :element-type (list type size)) (list (stream-element-type foo) (file-length foo) bytes (loop :for byte :in bytes :for nb = (read-byte foo) :collect nb :unless (= nb byte) :do (flet ((by-out (sz by) (format nil "~v,'0,' ,4:b" (+ sz (floor sz 4)) by))) (error "~& * [(~s ~s)] ~a != ~a~%" type size (by-out size byte) (by-out size nb)))))) (delete-file file-name))) (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte)) ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't ;;; contain a stream element. ;;; ;;; These tests check READ-SEQUENCE correctness, not whether the fast ;;; or slow paths are being taken for each element type. To check the ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or ;;; READ-N-BYTES: ;;; ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes) ;;; ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES, ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE. (let ((pathname "read-sequence.data")) ;; Create the binary data. (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-byte 255 stream)) ;; Check the slow path for generic vectors. (let ((sequence (make-array 1))) (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8)) (read-sequence sequence stream) (assert (equalp sequence #(255))))) (let ((sequence (make-array 1))) (with-open-file (stream pathname :direction :input :external-format :latin-1 :element-type 'character) (read-sequence sequence stream) (assert (equalp sequence #(#.(code-char 255)))))) ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE ;; 8) vectors. (let ((sequence (make-array 1 :element-type '(unsigned-byte 8)))) (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8)) (read-sequence sequence stream) (assert (equalp sequence #(255))))) (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) (with-open-file (stream pathname :direction :input :element-type '(signed-byte 8)) (read-sequence sequence stream) (assert (equalp sequence #(-1))))) ;; A bivalent stream can be read to a unsigned-byte vector, a ;; string, or a generic vector (let ((sequence (make-array 1 :element-type '(unsigned-byte 8)))) (with-open-file (stream pathname :direction :input :element-type :default) (read-sequence sequence stream) (assert (equalp sequence #(255))))) (let ((sequence (make-array 1 :element-type 'character))) (with-open-file (stream pathname :direction :input :external-format :latin-1 :element-type :default) (read-sequence sequence stream) (assert (equalp sequence #(#.(code-char 255)))))) (let ((sequence (make-array 1))) (with-open-file (stream pathname :direction :input :external-format :latin-1 :element-type :default) (read-sequence sequence stream) (assert (equalp sequence #(#.(code-char 255)))))) ;; Check that a TYPE-ERROR is signalled for incompatible (sequence, ;; stream) pairs. (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8)) (handler-case (progn (read-sequence sequence stream) (error "READ-SEQUENCE didn't signal an error")) (type-error (condition) (assert (= (type-error-datum condition) 255)) (assert (subtypep (type-error-expected-type condition) '(signed-byte 8))))))) (let ((sequence (make-array 1 :element-type '(unsigned-byte 8)))) (with-open-file (stream pathname :direction :input :element-type '(signed-byte 8)) (handler-case (progn (read-sequence sequence stream) (error "READ-SEQUENCE didn't signal an error")) (type-error (condition) (assert (= (type-error-datum condition) -1)) (assert (subtypep (type-error-expected-type condition) '(unsigned-byte 8))))))) ;; Can't read a signed-byte from a bivalent stream (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) (with-open-file (stream pathname :direction :input :external-format :latin1 :element-type :default) (handler-case (progn (read-sequence sequence stream) (error "READ-SEQUENCE didn't signal an error")) (type-error (condition) (assert (eql (type-error-datum condition) (code-char 255))) (assert (subtypep (type-error-expected-type condition) '(signed-byte 8))))))) (delete-file pathname)) ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't ;;; write a sequence element. ;;; ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast ;;; or slow paths are being taken for each element type. See the ;;; READ-SEQUENCE tests above for more information. ;;; ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes) (let ((pathname "write-sequence.data") (generic-sequence (make-array 1 :initial-contents '(255))) (generic-character-sequence (make-array 1 :initial-element #\a)) (generic-mixed-sequence (make-array 2 :initial-element #\a)) (string (make-array 1 :element-type 'character :initial-element (code-char 255))) (unsigned-sequence (make-array 1 :element-type '(unsigned-byte 8) :initial-contents '(255))) (signed-sequence (make-array 1 :element-type '(signed-byte 8) :initial-contents '(-1)))) (setf (aref generic-mixed-sequence 1) 255) ;; Check the slow path for generic vectors. (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-sequence generic-sequence stream)) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type 'character) (write-sequence generic-character-sequence stream)) ;; Check the fast path for unsigned and signed vectors. (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (write-sequence unsigned-sequence stream)) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(signed-byte 8)) (write-sequence signed-sequence stream)) ;; Bivalent streams on unsigned-byte vectors, strings, and a simple ;; vector with mixed characters and bytes (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type :default) (write-sequence unsigned-sequence stream)) (with-open-file (stream pathname :direction :output :external-format :latin-1 :if-exists :supersede :element-type :default) (write-sequence string stream)) (with-open-file (stream pathname :direction :output :external-format :latin-1 :if-exists :supersede :element-type :default) (write-sequence generic-mixed-sequence stream)) ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors ;; which are incompatible with the stream element type. (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(signed-byte 8)) (handler-case (progn (write-sequence unsigned-sequence stream) (error "WRITE-SEQUENCE didn't signal an error")) (type-error (condition) (assert (= (type-error-datum condition) 255)) (assert (subtypep (type-error-expected-type condition) '(signed-byte 8)))))) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (handler-case (progn (write-sequence signed-sequence stream) (error "WRITE-SEQUENCE didn't signal an error")) (type-error (condition) (assert (= (type-error-datum condition) -1)) (assert (subtypep (type-error-expected-type condition) '(unsigned-byte 8)))))) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type :default) (handler-case (progn (write-sequence signed-sequence stream) (error "WRITE-SEQUENCE didn't signal an error")) (type-error (condition) (assert (= (type-error-datum condition) -1)) (assert (subtypep (type-error-expected-type condition) '(unsigned-byte 8)))))) (delete-file pathname)) ;;; writing looong lines. takes way too long and way too much space ;;; to test on 64 bit platforms #-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or)) (progn (defun write-n-chars (n stream) (format t "~&/writing ~D chars on a single line~%" n) (finish-output t) (loop repeat n do (write-char #\x stream)) (terpri stream) n) (let ((test "long-lines-write-test.tmp")) (unwind-protect (with-open-file (f test :direction :output :external-format :ascii :element-type 'character :if-does-not-exist :create :if-exists :supersede) (write-n-chars (+ most-positive-fixnum 7) f)) (when (probe-file test) (delete-file test))))) ;;; read-sequence misreported the amount read and lost position (let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+) :element-type 'character))) (dotimes (i (length string)) (setf (char string i) (code-char (mod i char-code-limit)))) (with-open-file (f "read-sequence-character-test-data.tmp" :if-exists :supersede :direction :output :external-format :utf-8) (write-sequence string f)) (let ((copy (with-open-file (f "read-sequence-character-test-data.tmp" :if-does-not-exist :error :direction :input :external-format :utf-8) (let ((buffer (make-array 128 :element-type 'character)) (total 0)) (with-output-to-string (datum) (loop for n-read = (read-sequence buffer f) do (write-sequence buffer datum :start 0 :end n-read) (assert (<= (incf total n-read) (length string))) while (and (= n-read 128)))))))) (assert (equal copy string))) (delete-file "read-sequence-character-test-data.tmp")) ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's ;;; target was an ANSI stream, but it could be a user-defined stream, ;;; e.g., a SLIME stream. (defclass user-output-stream (fundamental-output-stream) ()) (let ((*stream* (make-instance 'user-output-stream))) (declare (special *stream*)) (with-open-stream (stream (make-synonym-stream '*stream*)) (assert (output-stream-p stream)))) (defclass user-input-stream (fundamental-input-stream) ()) (let ((*stream* (make-instance 'user-input-stream))) (declare (special *stream*)) (with-open-stream (stream (make-synonym-stream '*stream*)) (assert (input-stream-p stream)))) ;;; success