1 ;;;; tests related to Lisp streams
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "assertoid.lisp")
15 (use-package "ASSERTOID")
17 ;;; type errors for inappropriate stream arguments, fixed in
20 (declare (optimize (safety 3)))
21 (assert (raises-error?
(make-two-way-stream (make-string-output-stream)
22 (make-string-output-stream))
24 (assert (raises-error?
(make-two-way-stream (make-string-input-stream "foo")
25 (make-string-input-stream "bar"))
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))
36 (assert (raises-error?
(make-echo-stream (make-string-input-stream "foo")
37 (make-string-input-stream "bar"))
39 (assert (raises-error?
(make-concatenated-stream
40 (make-string-output-stream)
41 (make-string-input-stream "foo"))
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
)))
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
)))
58 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
59 (let ((p "signed-byte-8-test.data"))
62 :element-type
'(unsigned-byte 8)
63 :if-exists
:supersede
)
65 (with-open-file (s p
:element-type
'(signed-byte 8))
66 (assert (= (read-byte s
) -
1)))
69 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
71 (let* ((p "this-file-will-exist")
72 (stream (open p
:direction
:output
:if-exists
:error
)))
73 (assert (null (with-open-file (s p
:direction
:output
:if-exists nil
) s
)))
74 (assert (raises-error?
75 (with-open-file (s p
:direction
:output
:if-exists
:error
))))
79 (assert (raises-error?
(read-byte (make-string-input-stream "abc"))
81 (assert (raises-error?
(with-open-file (s "/dev/zero")
84 ;;; bidirectional streams getting confused about their position
85 (let ((p "bidirectional-stream-test"))
86 (with-open-file (s p
:direction
:output
:if-exists
:supersede
)
87 (with-standard-io-syntax
88 (format s
"~S ~S ~S~%" 'these
'are
'symbols
)))
89 (with-open-file (s p
:direction
:io
:if-exists
:overwrite
)
91 (with-standard-io-syntax
94 (assert (string= (read-line s
) "THESE INSERTMBOLS")))
97 ;;; :DIRECTION :IO didn't work on non-existent pathnames
98 (let ((p "direction-io-test"))
99 (ignore-errors (delete-file p
))
100 (with-open-file (s p
:direction
:io
)
103 (file-position s
:start
)
104 (assert (char= (read-char s
) #\
1)))
107 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
108 (assert (= 0 (file-position (make-broadcast-stream))))
109 (assert (file-position (make-broadcast-stream) :start
))
110 (assert (file-position (make-broadcast-stream) 0))
111 (assert (not (file-position (make-broadcast-stream) 1)))
112 (let ((s (make-broadcast-stream)))
114 (assert (not (file-position s
1)))
115 (assert (= 0 (file-position s
))))
117 (let ((p "broadcast-stream-test"))
118 (ignore-errors (delete-file p
))
119 (with-open-file (f p
:direction
:output
)
120 (let ((s (make-broadcast-stream f
)))
121 (assert (= 0 (file-position s
)))
122 (assert (file-position s
:start
))
123 (assert (file-position s
0))
125 (assert (= 1 (file-position s
))) ; unicode...
126 (assert (file-position s
0))))
129 ;;; CLOSING a non-new streams should not delete them, and superseded
130 ;;; files should be restored.
131 (let ((test "test-file-for-close-should-not-delete"))
132 (macrolet ((test-mode (mode)
134 (catch :close-test-exit
135 (with-open-file (f test
:direction
:output
:if-exists
,mode
)
136 (write-line "test" f
)
137 (throw :close-test-exit t
)))
138 (assert (and (probe-file test
) ,mode
)))))
141 (with-open-file (f test
:direction
:output
)
142 (write-line "test" f
))
144 (test-mode :overwrite
)
145 ;; FIXME: We really should recover supersede files as well, according to
146 ;; CLOSE in CLHS, but at the moment we don't.
147 ;; (test-mode :supersede)
149 (test-mode :rename-and-delete
))
150 (when (probe-file test
)
151 (delete-file test
)))))
153 ;;; test for read-write invariance of signed bytes, from Bruno Haible
154 ;;; cmucl-imp 2004-09-06
155 (defun bin-stream-test (&key
(size (integer-length most-positive-fixnum
))
156 (type 'unsigned-byte
) (file-name "stream-impure.tmp")
158 (bytes (if (eq type
'signed-byte
)
159 (loop :repeat num-bytes
:collect
160 (- (random (ash 1 size
))
162 (loop :repeat num-bytes
:collect
163 (random (ash 1 size
))))))
164 (with-open-file (foo file-name
:direction
:output
:if-exists
:supersede
165 :element-type
(list type size
))
167 (write-byte byte foo
)))
169 (with-open-file (foo file-name
:direction
:input
170 :element-type
(list type size
))
171 (list (stream-element-type foo
) (file-length foo
) bytes
172 (loop :for byte
:in bytes
:for nb
= (read-byte foo
) :collect nb
173 :unless
(= nb byte
) :do
174 (flet ((by-out (sz by
)
175 (format nil
"~v,'0,' ,4:b"
176 (+ sz
(floor sz
4)) by
)))
177 (error "~& * [(~s ~s)] ~a != ~a~%" type size
178 (by-out size byte
) (by-out size nb
))))))
179 (delete-file file-name
)))
180 (loop for size from
2 to
40 do
(bin-stream-test :size size
:type
'signed-byte
))