1 ;;;; tests related to Gray 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 (cl:in-package :cl-user)
16 ;;;; class precedence tests
18 (assert (subtypep 'fundamental-stream 'stream))
19 (assert (subtypep 'fundamental-stream 'standard-object))
21 (assert (subtypep 'fundamental-input-stream 'fundamental-stream))
22 (assert (subtypep 'fundamental-output-stream 'fundamental-stream))
23 (assert (subtypep 'fundamental-character-stream 'fundamental-stream))
24 (assert (subtypep 'fundamental-binary-stream 'fundamental-stream))
26 (assert (subtypep 'fundamental-character-input-stream
27 'fundamental-input-stream))
28 (assert (subtypep 'fundamental-character-input-stream
29 'fundamental-character-stream))
30 (assert (subtypep 'fundamental-character-output-stream
31 'fundamental-output-stream))
32 (assert (subtypep 'fundamental-character-output-stream
33 'fundamental-character-stream))
35 (assert (subtypep 'fundamental-binary-input-stream
36 'fundamental-input-stream))
37 (assert (subtypep 'fundamental-binary-input-stream
38 'fundamental-binary-stream))
39 (assert (subtypep 'fundamental-binary-output-stream
40 'fundamental-output-stream))
41 (assert (subtypep 'fundamental-binary-output-stream
42 'fundamental-binary-stream))
44 (defvar *fundamental-input-stream-instance*
45 (make-instance 'fundamental-input-stream))
47 (defvar *fundamental-output-stream-instance*
48 (make-instance 'fundamental-output-stream))
50 (defvar *fundamental-character-stream-instance*
51 (make-instance 'fundamental-character-stream))
53 (assert (input-stream-p *fundamental-input-stream-instance*))
54 (assert (output-stream-p *fundamental-output-stream-instance*))
55 (assert (eql (stream-element-type
56 *fundamental-character-stream-instance*)
59 ;;;; example character input and output streams
61 (defclass character-output-stream (fundamental-character-output-stream)
62 ((lisp-stream :initarg :lisp-stream
63 :accessor character-output-stream-lisp-stream)
64 (position :initform 42 :accessor character-output-stream-position)))
66 (defclass character-input-stream (fundamental-character-input-stream)
67 ((lisp-stream :initarg :lisp-stream
68 :accessor character-input-stream-lisp-stream)))
70 ;;;; example character output stream encapsulating a lisp-stream
72 (defun make-character-output-stream (lisp-stream)
73 (make-instance 'character-output-stream :lisp-stream lisp-stream))
75 (defmethod open-stream-p ((stream character-output-stream))
76 (open-stream-p (character-output-stream-lisp-stream stream)))
78 (defmethod close ((stream character-output-stream) &key abort)
79 (close (character-output-stream-lisp-stream stream) :abort abort))
81 (defmethod input-stream-p ((stream character-output-stream))
82 (input-stream-p (character-output-stream-lisp-stream stream)))
84 (defmethod output-stream-p ((stream character-output-stream))
85 (output-stream-p (character-output-stream-lisp-stream stream)))
87 (defmethod stream-write-char ((stream character-output-stream) character)
88 (write-char character (character-output-stream-lisp-stream stream)))
90 (defmethod stream-line-column ((stream character-output-stream))
91 (sb-kernel:charpos (character-output-stream-lisp-stream stream)))
93 (defmethod stream-line-length ((stream character-output-stream))
94 (sb-kernel:line-length (character-output-stream-lisp-stream stream)))
96 (defmethod stream-finish-output ((stream character-output-stream))
97 (finish-output (character-output-stream-lisp-stream stream)))
99 (defmethod stream-force-output ((stream character-output-stream))
100 (force-output (character-output-stream-lisp-stream stream)))
102 (defmethod stream-clear-output ((stream character-output-stream))
103 (clear-output (character-output-stream-lisp-stream stream)))
105 (defmethod stream-file-position ((stream character-output-stream) &optional new-value)
107 (setf (character-output-stream-position stream) new-value)
108 (character-output-stream-position stream)))
110 ;;;; example character input stream encapsulating a lisp-stream
112 (defun make-character-input-stream (lisp-stream)
113 (make-instance 'character-input-stream :lisp-stream lisp-stream))
115 (defmethod open-stream-p ((stream character-input-stream))
116 (open-stream-p (character-input-stream-lisp-stream stream)))
118 (defmethod close ((stream character-input-stream) &key abort)
119 (close (character-input-stream-lisp-stream stream) :abort abort))
121 (defmethod input-stream-p ((stream character-input-stream))
122 (input-stream-p (character-input-stream-lisp-stream stream)))
124 (defmethod output-stream-p ((stream character-input-stream))
125 (output-stream-p (character-input-stream-lisp-stream stream)))
127 (defmethod stream-read-char ((stream character-input-stream))
128 (read-char (character-input-stream-lisp-stream stream) nil :eof))
130 (defmethod stream-unread-char ((stream character-input-stream) character)
131 (unread-char character (character-input-stream-lisp-stream stream)))
133 (defmethod stream-read-char-no-hang ((stream character-input-stream))
134 (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
136 (defmethod stream-clear-input ((stream character-input-stream))
137 (clear-input (character-input-stream-lisp-stream stream)))
139 ;;;; tests for character i/o, using the above:
141 (let ((test-string (format nil
142 "~% This is a test.~& This is the second line.~
143 ~% This should be the third and last line.~%")))
144 (with-input-from-string (foo test-string)
146 (with-output-to-string (bar)
147 (let ((our-char-input (make-character-input-stream foo))
148 (our-char-output (make-character-output-stream bar)))
149 (assert (open-stream-p our-char-input))
150 (assert (open-stream-p our-char-output))
151 (assert (input-stream-p our-char-input))
152 (assert (output-stream-p our-char-output))
153 (let ((test-char (read-char our-char-input)))
154 (assert (char-equal test-char (char test-string 0)))
155 (unread-char test-char our-char-input))
156 (do ((line #1=(read-line our-char-input nil nil nil) #1#))
157 ((not (listen our-char-input))
158 (format our-char-output "~A~%" line))
159 (format our-char-output "~A~%" line))
160 (assert (null (peek-char nil our-char-input nil nil nil)))))
165 (with-output-to-string (foo)
166 (let ((our-char-output (make-character-output-stream foo)))
167 (write-char #\a our-char-output)
168 (finish-output our-char-output)
169 (write-char #\ our-char-output)
170 (force-output our-char-output)
171 (fresh-line our-char-output)
172 (write-char #\b our-char-output)
173 (clear-output our-char-output)
174 (terpri our-char-output)
175 (assert (null (fresh-line our-char-output)))
176 (write-char #\c our-char-output)))
177 (format nil "a ~%b~%c")))
179 ;;; Patches introduced in sbcl-0.6.11.5 made the pretty-print logic
180 ;;; test not only *PRINT-PRETTY* but also PRETTY-STREAM-P in some
181 ;;; cases. Try to verify that we don't end up doing tests like that on
182 ;;; bare Gray streams and thus bogusly omitting pretty-printing
185 (with-output-to-string (string)
186 (let ((gray-output-stream (make-character-output-stream string)))
187 (format gray-output-stream
188 "~@<testing: ~@:_pretty Gray line breaks~:>~%")))))
189 (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob)))))
190 (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob))))))
192 ;;; tests for STREAM-READ-SEQUENCE/STREAM-WRITE-SEQUENCE for
193 ;;; subclasses of FUNDAMENTAL-CHARACTER-INPUT-/OUTPUT-STREAM (i.e.,
194 ;;; where the default methods are available)
195 (let* ((test-string (format nil
196 "~% Testing for STREAM-*-SEQUENCE.~
197 ~& This is the second line.~
198 ~% This should be the third and last line.~%"))
199 (test-string-len (length test-string))
200 (output-test-string (make-string test-string-len)))
201 ;; test for READ-/WRITE-SEQUENCE on strings/vectors
202 (with-input-from-string (foo test-string)
204 (with-output-to-string (bar)
205 (let ((our-char-input (make-character-input-stream foo))
206 (our-char-output (make-character-output-stream bar)))
207 (read-sequence output-test-string our-char-input)
208 (assert (typep output-test-string 'string))
209 (write-sequence output-test-string our-char-output)
210 (assert (null (peek-char nil our-char-input nil nil nil)))))
212 ;; test for READ-/WRITE-SEQUENCE on lists
213 (let ((output-test-list (make-list test-string-len)))
214 (with-input-from-string (foo test-string)
216 (with-output-to-string (bar)
217 (let ((our-char-input (make-character-input-stream foo))
218 (our-char-output (make-character-output-stream bar)))
219 (read-sequence output-test-list our-char-input)
220 (assert (typep output-test-list 'list))
221 (write-sequence output-test-list our-char-output)
222 (assert (null (peek-char nil our-char-input nil nil nil)))))
225 ;;;; example classes for binary output
227 (defclass binary-to-char-output-stream (fundamental-binary-output-stream)
228 ((lisp-stream :initarg :lisp-stream
229 :accessor binary-to-char-output-stream-lisp-stream)))
231 (defclass binary-to-char-input-stream (fundamental-binary-input-stream)
232 ((lisp-stream :initarg :lisp-stream
233 :accessor binary-to-char-input-stream-lisp-stream)))
235 (defmethod stream-element-type ((stream binary-to-char-output-stream))
237 (defmethod stream-element-type ((stream binary-to-char-input-stream))
240 (defun make-binary-to-char-input-stream (lisp-stream)
241 (make-instance 'binary-to-char-input-stream
242 :lisp-stream lisp-stream))
244 (defun make-binary-to-char-output-stream (lisp-stream)
245 (make-instance 'binary-to-char-output-stream
246 :lisp-stream lisp-stream))
248 (defmethod stream-read-byte ((stream binary-to-char-input-stream))
249 (let ((char (read-char
250 (binary-to-char-input-stream-lisp-stream stream) nil :eof)))
255 (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer)
256 (let ((char (code-char integer)))
258 (binary-to-char-output-stream-lisp-stream stream))))
260 ;;;; tests using binary i/o, using the above
262 (let ((test-string (format nil
263 "~% This is a test.~& This is the second line.~
264 ~% This should be the third and last line.~%")))
265 (with-input-from-string (foo test-string)
267 (with-output-to-string (bar)
268 (let ((our-bin-to-char-input (make-binary-to-char-input-stream
270 (our-bin-to-char-output (make-binary-to-char-output-stream
272 (assert (open-stream-p our-bin-to-char-input))
273 (assert (open-stream-p our-bin-to-char-output))
274 (assert (input-stream-p our-bin-to-char-input))
275 (assert (output-stream-p our-bin-to-char-output))
276 (do ((byte #1=(read-byte our-bin-to-char-input nil :eof) #1#))
278 (write-byte byte our-bin-to-char-output))))
283 ;;; Minimal test of file-position
284 (let ((stream (make-instance 'character-output-stream)))
285 (assert (= (file-position stream) 42))
286 (assert (file-position stream 50))
287 (assert (= (file-position stream) 50)))
289 ;;; Using gray streams as parts of two-way-, concatenate-, and synonym-streams.
291 (defvar *gray-binary-data*
292 (let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0)))
293 (dotimes (i (length vector))
294 (setf (aref vector i) (random 256)))
297 (defun vector-hop-or-eof (vector)
298 (let ((pos (fill-pointer vector)))
299 (if (< pos (array-total-size vector))
302 (incf (fill-pointer vector)))
305 (defclass part-of-composite-stream (fundamental-binary-input-stream)
308 (defmethod stream-read-byte ((stream part-of-composite-stream))
309 (vector-hop-or-eof *gray-binary-data*))
311 (defmethod stream-element-type ((stream part-of-composite-stream))
314 (defvar *part-of-composite* (make-instance 'part-of-composite-stream))
316 (defun test-composite-reads (&rest streams)
317 (dolist (stream streams)
318 (setf (fill-pointer *gray-binary-data*) 0)
319 (let ((binary-buffer (make-array 1024 :element-type '(unsigned-byte 8))))
320 (assert (eql 1024 (read-sequence binary-buffer stream)))
322 (unless (eql (aref *gray-binary-data* i)
323 (aref binary-buffer i))
324 (error "wanted ~S at ~S, got ~S (~S)"
325 (aref *gray-binary-data* i)
327 (aref binary-buffer i)
330 (test-composite-reads
331 (make-two-way-stream *part-of-composite* *standard-output*)
332 (make-concatenated-stream *part-of-composite*)
333 (make-synonym-stream '*part-of-composite*))
335 ;;; Using STREAM-FILE-POSITION on an ANSI-STREAM
336 (with-output-to-string (s)
337 (assert (zerop (file-position s)))
338 (assert (zerop (stream-file-position s))))