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 ;;; 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"))
19 (let ((dir (posix-getenv "TMPDIR")))
20 (setq *default-pathname-defaults
*
22 (parse-native-namestring dir nil
#P
"" :as-directory t
)
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
*)))
46 ;;; type errors for inappropriate stream arguments, fixed in
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))
53 (assert-error (make-two-way-stream (make-string-input-stream "foo")
54 (make-string-input-stream "bar"))
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))
68 (assert-error (make-echo-stream (make-string-input-stream "foo")
69 (make-string-input-stream "bar"))
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"))
79 ;;; bug 225: STRING-STREAM was not a class
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
))))
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
))))
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)))
104 :element-type
'(unsigned-byte 8)
105 :if-exists
:supersede
)
107 (with-open-file (s p
:element-type
'(signed-byte 8))
108 (assert (= (read-byte s
) -
1)))
111 ;;; :IF-EXISTS got :ERROR and NIL the wrong way round (reported by
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
)))
118 (with-open-file (s p
:direction
:output
:if-exists
:error
)))
122 (with-test (:name
(read-byte make-string-input-stream type-error
))
123 (assert-error (read-byte (make-string-input-stream "abc"))
126 (with-test (:name
(:default
:element-type read-byte error
))
127 (assert-error (with-open-file (s "/dev/zero")
130 #+win32 sb-int
:simple-file-error
))
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
)
140 (with-standard-io-syntax
142 (with-open-file (s p
)
143 (let ((line (read-line s
))
144 (want "THESE INSERTMBOLS"))
145 (assert (equal line want
))))
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
)
155 (file-position s
:start
)
156 (assert (char= (read-char s
) #\
1)))
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)))
167 (assert (not (file-position s
1)))
168 (assert (= 0 (file-position s
)))))
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))
179 (assert (= 1 (file-position s
))) ; unicode...
180 (assert (file-position s
0))))
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)
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
)))))
196 (with-open-file (f test
:direction
:output
)
197 (write-line "test" f
))
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)
204 (test-mode :rename-and-delete
))
205 (when (probe-file test
)
206 (delete-file test
))))))
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))
214 (bytes (if (eq type
'signed-byte
)
215 (loop :repeat num-bytes
:collect
216 (- (random (ash 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
))
223 (write-byte byte foo
)))
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
)))
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
)))
241 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
242 ;;; contain a stream element.
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
249 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
251 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
252 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
254 (with-test (:name
(read-sequence type-error
))
255 (let ((pathname (scratch-file-name)))
257 ;; Create the binary data.
258 (with-open-file (stream pathname
260 :if-exists
:supersede
261 :element-type
'(unsigned-byte 8))
262 (write-byte 255 stream
))
264 ;; Check the slow path for generic vectors.
265 (let ((sequence (make-array 1)))
266 (with-open-file (stream pathname
268 :element-type
'(unsigned-byte 8))
269 (read-sequence sequence stream
)
270 (assert (equalp sequence
#(255)))))
272 (let ((sequence (make-array 1)))
273 (with-open-file (stream pathname
275 :external-format
:latin-1
276 :element-type
'character
)
277 (read-sequence sequence stream
)
278 (assert (equalp sequence
#(#.
(code-char 255))))))
280 ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
282 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
283 (with-open-file (stream pathname
285 :element-type
'(unsigned-byte 8))
286 (read-sequence sequence stream
)
287 (assert (equalp sequence
#(255)))))
289 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
290 (with-open-file (stream pathname
292 :element-type
'(signed-byte 8))
293 (read-sequence sequence stream
)
294 (assert (equalp sequence
#(-1)))))
296 ;; A bivalent stream can be read to a unsigned-byte vector, a
297 ;; string, or a generic vector
299 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
300 (with-open-file (stream pathname
302 :element-type
:default
)
303 (read-sequence sequence stream
)
304 (assert (equalp sequence
#(255)))))
306 (let ((sequence (make-array 1 :element-type
'character
)))
307 (with-open-file (stream pathname
309 :external-format
:latin-1
310 :element-type
:default
)
311 (read-sequence sequence stream
)
312 (assert (equalp sequence
#(#.
(code-char 255))))))
314 (let ((sequence (make-array 1)))
315 (with-open-file (stream pathname
317 :external-format
:latin-1
318 :element-type
:default
)
319 (read-sequence sequence stream
)
320 (assert (equalp sequence
#(#.
(code-char 255))))))
322 ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
325 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
326 (with-open-file (stream pathname
328 :element-type
'(unsigned-byte 8))
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)))))))
337 (let ((sequence (make-array 1 :element-type
'(unsigned-byte 8))))
338 (with-open-file (stream pathname
340 :element-type
'(signed-byte 8))
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)))))))
349 ;; Can't read a signed-byte from a bivalent stream
351 (let ((sequence (make-array 1 :element-type
'(signed-byte 8))))
352 (with-open-file (stream pathname
354 :external-format
:latin1
355 :element-type
:default
)
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
)))
365 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
366 ;;; write a sequence element.
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.
372 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered)
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))))
388 (setf (aref generic-mixed-sequence
1) 255)
390 ;; Check the slow path for generic vectors.
391 (with-open-file (stream pathname
393 :if-exists
:supersede
394 :element-type
'(unsigned-byte 8))
395 (write-sequence generic-sequence stream
))
397 (with-open-file (stream pathname
399 :if-exists
:supersede
400 :element-type
'character
)
401 (write-sequence generic-character-sequence stream
))
403 ;; Check the fast path for unsigned and signed vectors.
404 (with-open-file (stream pathname
406 :if-exists
:supersede
407 :element-type
'(unsigned-byte 8))
408 (write-sequence unsigned-sequence stream
))
410 (with-open-file (stream pathname
412 :if-exists
:supersede
413 :element-type
'(signed-byte 8))
414 (write-sequence signed-sequence stream
))
416 ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
417 ;; vector with mixed characters and bytes
419 (with-open-file (stream pathname
421 :if-exists
:supersede
422 :element-type
:default
)
423 (write-sequence unsigned-sequence stream
))
425 (with-open-file (stream pathname
427 :external-format
:latin-1
428 :if-exists
:supersede
429 :element-type
:default
)
430 (write-sequence string stream
))
432 (with-open-file (stream pathname
434 :external-format
:latin-1
435 :if-exists
:supersede
436 :element-type
:default
)
437 (write-sequence generic-mixed-sequence stream
))
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
443 :if-exists
:supersede
444 :element-type
'(signed-byte 8))
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))))))
453 (with-open-file (stream pathname
455 :if-exists
:supersede
456 :element-type
'(unsigned-byte 8))
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))))))
465 (with-open-file (stream pathname
467 :if-exists
:supersede
468 :element-type
:default
)
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))))))
477 (delete-file pathname
)))
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
)
483 (let ((test (scratch-file-name)))
485 (with-open-file (f test
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))
494 (buffer (make-string n
)))
498 (write-sequence buffer f
))
499 (assert (= p
(sb-impl::fd-stream-output-column 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
)))))
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
516 :external-format
:utf-8
)
517 (write-sequence string f
))
519 (with-open-file (f file
520 :if-does-not-exist
:error
522 :external-format
:utf-8
)
523 (let ((buffer (make-array 128 :element-type
'character
))
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
)))
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)
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
)))))
545 (defclass user-input-stream
(fundamental-input-stream)
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
)))))
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
)
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
)))))))
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
))
570 (let ((f (open *this-file
* :direction
:input
)))
571 (assert (stringp (read-line f
)))
573 (assert-error (read-line f
) sb-int
:closed-stream-error
))
575 (let ((f (open *this-file
* :direction
:input
)))
576 (assert (stringp (read-line f nil nil
)))
578 (assert-error (read-line f
) sb-int
:closed-stream-error
)))
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))))))
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
)
599 (file-position s
:start
)
600 (unread-char (read-char s
) s
)
601 (assert (integerp (read-byte s
))))
602 (delete-file pathname
)))
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
)
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
)))
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
)))
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
)))
643 (with-test (:name
(delete-file :on stream
))
644 (with-open-file (f (scratch-file-name)
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"))))
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
669 (read-char-no-hang stream
)
670 (assert (< (- (get-universal-time) time
) 2)))))
673 (with-test (:name
(open :interrupt
)
674 :skipped-on
(or :win32
(:and
:darwin
:sb-safepoint
)))
676 (with-scratch-file (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.
684 (handler-bind ((timeout (lambda (c)
685 (when (eql 1 (incf to
))
688 (with-open-file (f fifo
:direction
:input
)
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)
701 (with-test (:name
:overeager-character-buffering
:skipped-on
:win32
)
702 (let ((use-threads #+sb-thread t
)
704 (sb-int:dovector
(entry sb-impl
::*external-formats
*)
705 (unless entry
(return))
706 (with-scratch-file (fifo)
709 (car (sb-impl::ef-names
(car (sb-int:ensure-list entry
))))))
710 (sb-posix:mkfifo fifo
(logior sb-posix
:s-iwusr sb-posix
:s-irusr
))
711 ;; KLUDGE: because we have both ends in the same process, we would
712 ;; need to use O_NONBLOCK, but this works too.
713 ;; Prefer to use threads rather than processes, as the test
714 ;; execute significantly faster.
715 ;; Note also that O_NONBLOCK would probably counteract the original
716 ;; bug, so it's better that we eschew O_NONBLOCK.
721 (with-open-file (f fifo
:direction
:output
722 :if-exists
:overwrite
723 :external-format format
)
724 (write-line "foobar" f
)
726 (sleep most-positive-fixnum
))))))
729 (run-program "/bin/sh"
731 (format nil
"cat > ~A" (native-namestring fifo
)))
734 :external-format format
))
735 (write-line "foobar" (process-input proc
))
736 (finish-output (process-input proc
))))
737 ;; Whether we're using threads or processes, the writer isn't
738 ;; injecting any more input, but isn't indicating EOF either.
739 (with-open-file (f fifo
:direction
:input
:external-format format
)
740 (assert (equal "foobar" (read-line f
)))))
742 (cond (use-threads (sb-thread:terminate-thread proc
))
744 (close (process-input proc
) :abort t
)
746 (ignore-errors (process-close proc
))))
747 (setf proc nil
)))))))
749 (with-test (:name
:bug-657183
:skipped-on
(not :sb-unicode
))
751 (let ((name (scratch-file-name))
752 (text '(#\GREEK_SMALL_LETTER_LAMDA
753 #\JAPANESE_BANK_SYMBOL
755 #\HEAVY_BLACK_HEART
))
756 (positions '(2 5 6 9))
757 (sb-impl::*default-external-format
* :utf-8
))
760 (with-open-file (f name
:external-format
:default
:direction
:output
761 :if-exists
:supersede
)
762 (assert (eql 0 (file-position f
)))
763 (mapc (lambda (char pos
)
765 (assert (eql pos
(file-position f
))))
768 (with-open-file (f name
:external-format
:default
:direction
:input
)
769 (assert (eql 0 (file-position f
)))
770 (assert (eql (pop text
) (read-char f
)))
771 (assert (eql (file-position f
) 2))
772 (assert (eql (pop text
) (read-char f
)))
773 (assert (eql (file-position f
) 5))
774 (assert (eql (pop text
) (read-char f
)))
775 (assert (eql (file-position f
) 6))
776 (assert (eql (pop text
) (read-char f
)))
777 (assert (eql (file-position f
) 9))
778 (assert (eql (file-length f
) 9))))
779 (ignore-errors (delete-file name
)))))
781 (with-test (:name
:bug-561642
)
782 (let ((p (scratch-file-name)))
786 :if-exists
:supersede
787 :if-does-not-exist
:create
789 (write-line "FOOBAR" f
))
793 (let ((p0 (file-position f
))
795 (write-char #\newline f
)
798 (write-char #\newline f
)
803 (assert (eql 9 p2
)))))
804 (ignore-errors (delete-file p
)))))
806 (defun mock-fd-stream-in-fun (stream eof-err-p eof-val
)
807 (sb-impl::eof-or-lose stream eof-err-p eof-val
))
808 (declaim (ftype function mock-fd-stream-n-bin-fun
))
810 (defstruct (mock-fd-stream
811 (:constructor %make-mock-fd-stream
(buffer-chain))
812 (:include sb-impl
::ansi-stream
813 (in #'mock-fd-stream-in-fun
)
814 (n-bin #'mock-fd-stream-n-bin-fun
)
816 (make-array sb-impl
::+ansi-stream-in-buffer-length
+
817 :element-type
'character
))
819 (make-array sb-impl
::+ansi-stream-in-buffer-length
+
820 :element-type
'(unsigned-byte 8)))))
823 (defun make-mock-fd-stream (buffer-chain)
824 ;; For notational convenience, #\| becomes #\Newline.
825 (%make-mock-fd-stream
826 (mapcar (lambda (x) (substitute #\Newline
#\| x
)) buffer-chain
)))
828 (defun mock-fd-stream-n-bin-fun (stream char-buf size-buf start count eof-err-p
)
829 (cond ((mock-fd-stream-buffer-chain stream
)
830 (let* ((chars (pop (mock-fd-stream-buffer-chain stream
)))
831 (n-chars (length chars
)))
832 ;; make sure the mock object is being used as expected.
833 (assert (>= count
(length chars
)))
834 (replace char-buf chars
:start1 start
)
835 (fill size-buf
1 :start start
:end
(+ start n-chars
))
838 (sb-impl::eof-or-lose stream eof-err-p
0))))
840 (with-test (:name
:read-chunk-from-frc-buffer
)
841 (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo|bar" "hi"))))
842 (multiple-value-bind (line eofp
)
843 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil
'woot
)
844 (assert (and (string= line
"zabcdefghfoo") (not eofp
))))
845 (multiple-value-bind (line eofp
)
846 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil
'woot
)
847 (assert (and (string= line
"barhi") eofp
)))
848 (multiple-value-bind (line eofp
)
849 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil
'woot
)
850 (assert (and (eq line
'woot
) eofp
))))
851 (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo*bar" "hi")))
852 (string (make-string 100)))
854 (sb-impl::ansi-stream-read-string-from-frc-buffer string s
10 nil
)))
855 (assert (and (= endpos
28)
856 (string= (subseq string
10 endpos
) "zabcdefghfoo*barhi"))))
858 (sb-impl::ansi-stream-read-string-from-frc-buffer string s
0 nil
)))
859 (assert (= endpos
0)))))
861 (with-test (:name
:named-pipe-wait-eof
)
862 (let* ((process (run-program "cat" '() :search t
863 :wait nil
:input nil
:output
:stream
))
864 (out (process-output process
)))
865 (sb-sys:wait-until-fd-usable
(sb-sys:fd-stream-fd out
) :input
)
866 (assert (null (read-byte (process-output process
) nil nil
)))
867 (process-close process
)))
869 (with-test (:name
:concatenated-stream-listen
)
870 (let ((file (scratch-file-name)))
871 (with-open-file (stream file
:direction
:output
:if-exists
:supersede
)
872 (write-line "abc" stream
))
873 (with-open-file (stream file
)
874 (let ((cs (make-concatenated-stream stream
)))
875 (read-char-no-hang cs
)
876 (assert (listen cs
))))