Avoid forward references to PARSE-mumble-TYPE condition classes.
[sbcl.git] / tests / stream.impure.lisp
blobbd30ff781e7a3fa2b73b93282e17fbd15481a749
1 ;;;; tests related to Lisp streams
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.
14 (load "assertoid.lisp")
15 (use-package "ASSERTOID")
17 ;;; type errors for inappropriate stream arguments, fixed in
18 ;;; sbcl-0.7.8.19
19 (locally
20 (declare (optimize (safety 3)))
21 (assert-error (make-two-way-stream (make-string-output-stream)
22 (make-string-output-stream))
23 type-error)
24 (assert-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-error (make-echo-stream (make-string-output-stream)
34 (make-string-output-stream))
35 type-error)
36 (assert-error (make-echo-stream (make-string-input-stream "foo")
37 (make-string-input-stream "bar"))
38 type-error)
39 (assert-error (make-concatenated-stream
40 (make-string-output-stream)
41 (make-string-input-stream "foo"))
42 type-error))
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"))
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))
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 (open p :direction :output :if-exists :error)))
73 (assert (null (with-open-file (s p :direction :output :if-exists nil) s)))
74 (assert-error
75 (with-open-file (s p :direction :output :if-exists :error)))
76 (close stream)
77 (delete-file p))
79 (assert-error (read-byte (make-string-input-stream "abc"))
80 type-error)
81 (assert-error (with-open-file (s "/dev/zero")
82 (read-byte s))
83 #-win32 type-error
84 #+win32 sb-int:simple-file-error)
85 ;;; bidirectional streams getting confused about their position
86 (let ((p "bidirectional-stream-test"))
87 (with-open-file (s p :direction :output :if-exists :supersede)
88 (with-standard-io-syntax
89 (format s "~S ~S ~S~%" 'these 'are 'symbols)))
90 (with-open-file (s p :direction :io :if-exists :overwrite)
91 (read s)
92 (with-standard-io-syntax
93 (prin1 'insert s)))
94 (with-open-file (s p)
95 (let ((line (read-line s))
96 (want "THESE INSERTMBOLS"))
97 (unless (equal line want)
98 (error "wanted ~S, got ~S" want line))))
99 (delete-file p))
101 ;;; :DIRECTION :IO didn't work on non-existent pathnames
102 (let ((p "direction-io-test"))
103 (ignore-errors (delete-file p))
104 (with-open-file (s p :direction :io)
105 (format s "1")
106 (finish-output s)
107 (file-position s :start)
108 (assert (char= (read-char s) #\1)))
109 (delete-file p))
111 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
112 (assert (= 0 (file-position (make-broadcast-stream))))
113 (assert (file-position (make-broadcast-stream) :start))
114 (assert (file-position (make-broadcast-stream) 0))
115 (assert (not (file-position (make-broadcast-stream) 1)))
116 (let ((s (make-broadcast-stream)))
117 (write-char #\a s)
118 (assert (not (file-position s 1)))
119 (assert (= 0 (file-position s))))
121 (let ((p "broadcast-stream-test"))
122 (ignore-errors (delete-file p))
123 (with-open-file (f p :direction :output)
124 (let ((s (make-broadcast-stream f)))
125 (assert (= 0 (file-position s)))
126 (assert (file-position s :start))
127 (assert (file-position s 0))
128 (write-char #\a s)
129 (assert (= 1 (file-position s))) ; unicode...
130 (assert (file-position s 0))))
131 (delete-file p))
133 ;;; CLOSING a non-new streams should not delete them, and superseded
134 ;;; files should be restored.
135 (with-test (:name :test-file-for-close-should-not-delete :fails-on :win32)
136 (let ((test "test-file-for-close-should-not-delete"))
137 (macrolet ((test-mode (mode)
138 `(progn
139 (catch :close-test-exit
140 (with-open-file (f test :direction :output :if-exists ,mode)
141 (write-line "test" f)
142 (throw :close-test-exit t)))
143 (assert (and (probe-file test) ,mode)))))
144 (unwind-protect
145 (progn
146 (with-open-file (f test :direction :output)
147 (write-line "test" f))
148 (test-mode :append)
149 (test-mode :overwrite)
150 ;; FIXME: We really should recover supersede files as well, according to
151 ;; CLOSE in CLHS, but at the moment we don't.
152 ;; (test-mode :supersede)
153 (test-mode :rename)
154 (test-mode :rename-and-delete))
155 (when (probe-file test)
156 (delete-file test))))))
158 ;;; test for read-write invariance of signed bytes, from Bruno Haible
159 ;;; cmucl-imp 2004-09-06
160 (defun bin-stream-test (&key (size (integer-length most-positive-fixnum))
161 (type 'unsigned-byte) (file-name "stream-impure.tmp")
162 (num-bytes 10)
163 (bytes (if (eq type 'signed-byte)
164 (loop :repeat num-bytes :collect
165 (- (random (ash 1 size))
166 (ash 1 (1- size))))
167 (loop :repeat num-bytes :collect
168 (random (ash 1 size))))))
169 (with-open-file (foo file-name :direction :output :if-exists :supersede
170 :element-type (list type size))
171 (dolist (byte bytes)
172 (write-byte byte foo)))
173 (unwind-protect
174 (with-open-file (foo file-name :direction :input
175 :element-type (list type size))
176 (list (stream-element-type foo) (file-length foo) bytes
177 (loop :for byte :in bytes :for nb = (read-byte foo) :collect nb
178 :unless (= nb byte) :do
179 (flet ((by-out (sz by)
180 (format nil "~v,'0,' ,4:b"
181 (+ sz (floor sz 4)) by)))
182 (error "~& * [(~s ~s)] ~a != ~a~%" type size
183 (by-out size byte) (by-out size nb))))))
184 (delete-file file-name)))
185 (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte))
187 ;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
188 ;;; contain a stream element.
190 ;;; These tests check READ-SEQUENCE correctness, not whether the fast
191 ;;; or slow paths are being taken for each element type. To check the
192 ;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
193 ;;; READ-N-BYTES:
195 ;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
197 ;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
198 ;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
200 (let ((pathname "read-sequence.data"))
202 ;; Create the binary data.
203 (with-open-file (stream pathname
204 :direction :output
205 :if-exists :supersede
206 :element-type '(unsigned-byte 8))
207 (write-byte 255 stream))
209 ;; Check the slow path for generic vectors.
210 (let ((sequence (make-array 1)))
211 (with-open-file (stream pathname
212 :direction :input
213 :element-type '(unsigned-byte 8))
214 (read-sequence sequence stream)
215 (assert (equalp sequence #(255)))))
217 (let ((sequence (make-array 1)))
218 (with-open-file (stream pathname
219 :direction :input
220 :external-format :latin-1
221 :element-type 'character)
222 (read-sequence sequence stream)
223 (assert (equalp sequence #(#.(code-char 255))))))
225 ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
226 ;; 8) vectors.
227 (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
228 (with-open-file (stream pathname
229 :direction :input
230 :element-type '(unsigned-byte 8))
231 (read-sequence sequence stream)
232 (assert (equalp sequence #(255)))))
234 (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
235 (with-open-file (stream pathname
236 :direction :input
237 :element-type '(signed-byte 8))
238 (read-sequence sequence stream)
239 (assert (equalp sequence #(-1)))))
241 ;; A bivalent stream can be read to a unsigned-byte vector, a
242 ;; string, or a generic vector
244 (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
245 (with-open-file (stream pathname
246 :direction :input
247 :element-type :default)
248 (read-sequence sequence stream)
249 (assert (equalp sequence #(255)))))
251 (let ((sequence (make-array 1 :element-type 'character)))
252 (with-open-file (stream pathname
253 :direction :input
254 :external-format :latin-1
255 :element-type :default)
256 (read-sequence sequence stream)
257 (assert (equalp sequence #(#.(code-char 255))))))
259 (let ((sequence (make-array 1)))
260 (with-open-file (stream pathname
261 :direction :input
262 :external-format :latin-1
263 :element-type :default)
264 (read-sequence sequence stream)
265 (assert (equalp sequence #(#.(code-char 255))))))
267 ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
268 ;; stream) pairs.
270 (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
271 (with-open-file (stream pathname
272 :direction :input
273 :element-type '(unsigned-byte 8))
274 (handler-case (progn
275 (read-sequence sequence stream)
276 (error "READ-SEQUENCE didn't signal an error"))
277 (type-error (condition)
278 (assert (= (type-error-datum condition) 255))
279 (assert (subtypep (type-error-expected-type condition)
280 '(signed-byte 8)))))))
282 (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
283 (with-open-file (stream pathname
284 :direction :input
285 :element-type '(signed-byte 8))
286 (handler-case (progn
287 (read-sequence sequence stream)
288 (error "READ-SEQUENCE didn't signal an error"))
289 (type-error (condition)
290 (assert (= (type-error-datum condition) -1))
291 (assert (subtypep (type-error-expected-type condition)
292 '(unsigned-byte 8)))))))
294 ;; Can't read a signed-byte from a bivalent stream
296 (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
297 (with-open-file (stream pathname
298 :direction :input
299 :external-format :latin1
300 :element-type :default)
301 (handler-case (progn
302 (read-sequence sequence stream)
303 (error "READ-SEQUENCE didn't signal an error"))
304 (type-error (condition)
305 (assert (eql (type-error-datum condition) (code-char 255)))
306 (assert (subtypep (type-error-expected-type condition)
307 '(signed-byte 8)))))))
308 (delete-file pathname))
310 ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
311 ;;; write a sequence element.
313 ;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
314 ;;; or slow paths are being taken for each element type. See the
315 ;;; READ-SEQUENCE tests above for more information.
317 ;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
319 (let ((pathname "write-sequence.data")
320 (generic-sequence (make-array 1 :initial-contents '(255)))
321 (generic-character-sequence (make-array 1 :initial-element #\a))
322 (generic-mixed-sequence (make-array 2 :initial-element #\a))
323 (string (make-array 1 :element-type 'character
324 :initial-element (code-char 255)))
325 (unsigned-sequence (make-array 1
326 :element-type '(unsigned-byte 8)
327 :initial-contents '(255)))
328 (signed-sequence (make-array 1
329 :element-type '(signed-byte 8)
330 :initial-contents '(-1))))
332 (setf (aref generic-mixed-sequence 1) 255)
334 ;; Check the slow path for generic vectors.
335 (with-open-file (stream pathname
336 :direction :output
337 :if-exists :supersede
338 :element-type '(unsigned-byte 8))
339 (write-sequence generic-sequence stream))
341 (with-open-file (stream pathname
342 :direction :output
343 :if-exists :supersede
344 :element-type 'character)
345 (write-sequence generic-character-sequence stream))
347 ;; Check the fast path for unsigned and signed vectors.
348 (with-open-file (stream pathname
349 :direction :output
350 :if-exists :supersede
351 :element-type '(unsigned-byte 8))
352 (write-sequence unsigned-sequence stream))
354 (with-open-file (stream pathname
355 :direction :output
356 :if-exists :supersede
357 :element-type '(signed-byte 8))
358 (write-sequence signed-sequence stream))
360 ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
361 ;; vector with mixed characters and bytes
363 (with-open-file (stream pathname
364 :direction :output
365 :if-exists :supersede
366 :element-type :default)
367 (write-sequence unsigned-sequence stream))
369 (with-open-file (stream pathname
370 :direction :output
371 :external-format :latin-1
372 :if-exists :supersede
373 :element-type :default)
374 (write-sequence string stream))
376 (with-open-file (stream pathname
377 :direction :output
378 :external-format :latin-1
379 :if-exists :supersede
380 :element-type :default)
381 (write-sequence generic-mixed-sequence stream))
383 ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
384 ;; which are incompatible with the stream element type.
385 (with-open-file (stream pathname
386 :direction :output
387 :if-exists :supersede
388 :element-type '(signed-byte 8))
389 (handler-case (progn
390 (write-sequence unsigned-sequence stream)
391 (error "WRITE-SEQUENCE didn't signal an error"))
392 (type-error (condition)
393 (assert (= (type-error-datum condition) 255))
394 (assert (subtypep (type-error-expected-type condition)
395 '(signed-byte 8))))))
397 (with-open-file (stream pathname
398 :direction :output
399 :if-exists :supersede
400 :element-type '(unsigned-byte 8))
401 (handler-case (progn
402 (write-sequence signed-sequence stream)
403 (error "WRITE-SEQUENCE didn't signal an error"))
404 (type-error (condition)
405 (assert (= (type-error-datum condition) -1))
406 (assert (subtypep (type-error-expected-type condition)
407 '(unsigned-byte 8))))))
409 (with-open-file (stream pathname
410 :direction :output
411 :if-exists :supersede
412 :element-type :default)
413 (handler-case (progn
414 (write-sequence signed-sequence stream)
415 (error "WRITE-SEQUENCE didn't signal an error"))
416 (type-error (condition)
417 (assert (= (type-error-datum condition) -1))
418 (assert (subtypep (type-error-expected-type condition)
419 '(unsigned-byte 8))))))
421 (delete-file pathname))
423 ;;; writing looong lines. takes way too long and way too much space
424 ;;; to test on 64 bit platforms
425 #-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or))
426 (let ((test "long-lines-write-test.tmp"))
427 (unwind-protect
428 (with-open-file (f test
429 :direction :output
430 :external-format :ascii
431 :element-type 'character
432 :if-does-not-exist :create
433 :if-exists :supersede)
434 (let* ((n (truncate most-positive-fixnum 16))
435 (m 18)
436 (p (* n m))
437 (buffer (make-string n)))
438 (dotimes (i m)
439 (write-char #\.)
440 (finish-output)
441 (write-sequence buffer f))
442 (assert (= p (sb-impl::fd-stream-output-column f)))
443 (write-char #\! f)
444 (assert (= (+ 1 p) (sb-impl::fd-stream-output-column f)))
445 (assert (typep p 'bignum))))
446 (when (probe-file test)
447 (delete-file test))))
449 ;;; read-sequence misreported the amount read and lost position
450 (let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
451 :element-type 'character)))
452 (dotimes (i (length string))
453 (setf (char string i) (code-char (mod i char-code-limit))))
454 (with-open-file (f "read-sequence-character-test-data.tmp"
455 :if-exists :supersede
456 :direction :output
457 :external-format :utf-8)
458 (write-sequence string f))
459 (let ((copy
460 (with-open-file (f "read-sequence-character-test-data.tmp"
461 :if-does-not-exist :error
462 :direction :input
463 :external-format :utf-8)
464 (let ((buffer (make-array 128 :element-type 'character))
465 (total 0))
466 (with-output-to-string (datum)
467 (loop for n-read = (read-sequence buffer f)
468 do (write-sequence buffer datum :start 0 :end n-read)
469 (assert (<= (incf total n-read) (length string)))
470 while (and (= n-read 128))))))))
471 (assert (equal copy string)))
472 (delete-file "read-sequence-character-test-data.tmp"))
474 ;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
475 ;;; target was an ANSI stream, but it could be a user-defined stream,
476 ;;; e.g., a SLIME stream.
477 (defclass user-output-stream (fundamental-output-stream)
480 (let ((*stream* (make-instance 'user-output-stream)))
481 (declare (special *stream*))
482 (with-open-stream (stream (make-synonym-stream '*stream*))
483 (assert (output-stream-p stream))))
485 (defclass user-input-stream (fundamental-input-stream)
488 (let ((*stream* (make-instance 'user-input-stream)))
489 (declare (special *stream*))
490 (with-open-stream (stream (make-synonym-stream '*stream*))
491 (assert (input-stream-p stream))))
493 ;;; READ-LINE on ANSI-STREAM did not return T for the last line
494 ;;; (reported by Yoshinori Tahara)
495 (let ((pathname "test-read-line-eol"))
496 (with-open-file (out pathname :direction :output :if-exists :supersede)
497 (format out "a~%b"))
498 (let ((result (with-open-file (in pathname)
499 (list (multiple-value-list (read-line in nil nil))
500 (multiple-value-list (read-line in nil nil))
501 (multiple-value-list (read-line in nil nil))))))
502 (delete-file pathname)
503 (assert (equal result '(("a" nil) ("b" t) (nil t))))))
505 ;;; READ-LINE used to work on closed streams because input buffers were left in place
506 (with-test (:name :bug-425)
507 ;; Normal close
508 (let ((f (open "stream.impure.lisp" :direction :input)))
509 (assert (stringp (read-line f)))
510 (close f)
511 (assert (eq :fii
512 (handler-case
513 (read-line f)
514 (sb-int:closed-stream-error () :fii)))))
515 ;; Abort
516 (let ((f (open "stream.impure.lisp" :direction :input)))
517 (assert (stringp (read-line f nil nil)))
518 (close f :abort t)
519 (assert (eq :faa
520 (handler-case
521 (read-line f)
522 (sb-int:closed-stream-error () :faa))))))
524 (with-test (:name :regression-1.0.12.22)
525 (with-open-file (s "stream.impure.lisp" :direction :input)
526 (let ((buffer (make-string 20)))
527 (assert (= 2 (read-sequence buffer s :start 0 :end 2)))
528 (assert (= 3 (read-sequence buffer s :start 2 :end 3)))
529 (file-position s :end)
530 (assert (= 3 (read-sequence buffer s :start 3))))))
532 ;;; In 1.0.27 (and also 0.9.16; presumably in between, too), binary
533 ;;; input operations on a bivalent stream did something bad after
534 ;;; unread-char: READ-BYTE would return the character, and
535 ;;; READ-SEQUENCE into a byte buffer would lose when attempting to
536 ;;; store the character in the vector.
537 (let ((pathname "bivalent-stream-unread-char-test.tmp"))
538 (with-open-file (s pathname
539 :element-type :default
540 :direction :io :if-exists :rename)
541 (write-char #\a s)
542 (file-position s :start)
543 (unread-char (read-char s) s)
544 (assert (integerp (read-byte s))))
545 (delete-file pathname))
547 (let ((pathname "bivalent-stream-unread-char-test.tmp"))
548 (with-open-file (s pathname
549 :element-type :default
550 :direction :io :if-exists :rename)
551 (write-char #\a s)
552 (file-position s :start)
553 (unread-char (read-char s) s)
554 (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
555 (read-sequence buffer s))))
556 (delete-file pathname))
558 #+sb-unicode
559 (let ((pathname "bivalent-stream-unread-char-test.tmp"))
560 (with-open-file (s pathname
561 :element-type :default
562 :direction :io :if-exists :rename
563 :external-format :utf8)
564 (write-char (code-char 192) s)
565 (file-position s :start)
566 (unread-char (read-char s) s)
567 (assert (integerp (read-byte s))))
568 (delete-file pathname))
570 #+sb-unicode
571 (let ((pathname "bivalent-stream-unread-char-test.tmp"))
572 (with-open-file (s pathname
573 :element-type :default
574 :direction :io :if-exists :rename
575 :external-format :utf8)
576 (write-char (code-char 192) s)
577 (file-position s :start)
578 (unread-char (read-char s) s)
579 (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
580 (read-sequence buffer s))))
581 (delete-file pathname))
583 (with-test (:name :delete-file-on-streams)
584 (with-open-file (f "delete-file-on-stream-test.tmp"
585 :direction :io)
586 (delete-file f)
587 #-win32
588 (progn
589 (write-line "still open" f)
590 (file-position f :start)
591 (assert (equal "still open" (read-line f)))))
592 (assert (not (probe-file "delete-file-on-stream-test.tmp"))))
594 ;;; READ-CHAR-NO-HANG on bivalent streams (as returned by RUN-PROGRAM)
595 ;;; was wrong. CSR managed to promote the wrongness to all streams in
596 ;;; the 1.0.32.x series, breaking slime instantly.
597 (with-test (:name :read-char-no-hang-after-unread-char :skipped-on :win32)
598 (let* ((process (run-program "/bin/sh" '("-c" "echo a && sleep 10")
599 :output :stream :wait nil))
600 (stream (process-output process))
601 (char (read-char stream)))
602 (assert (char= char #\a))
603 (unread-char char stream)
604 (assert (char= (read-char stream) #\a))
605 (assert (char= (read-char stream) #\Newline))
606 (let ((time (get-universal-time)))
607 ;; no input, not yet known to be at EOF: should return
608 ;; immediately
609 (read-char-no-hang stream)
610 (assert (< (- (get-universal-time) time) 2)))))
612 (require :sb-posix)
613 #-win32
614 (with-test (:name :interrupt-open :skipped-on :win32)
615 (let ((fifo nil)
616 (to 0))
617 (unwind-protect
618 (progn
619 ;; Make a FIFO
620 (setf fifo (sb-posix:mktemp "SBCL-fifo.XXXXXXX"))
621 (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
622 ;; Try to open it (which hangs), and interrupt ourselves with a timer,
623 ;; continue (this used to result in an error due to open(2) returning with
624 ;; EINTR, then interupt again and unwind.
625 (handler-case
626 (with-timeout 2
627 (handler-bind ((timeout (lambda (c)
628 (when (eql 1 (incf to))
629 (continue c)))))
630 (with-timeout 1
631 (with-open-file (f fifo :direction :input)
632 :open))))
633 (timeout ()
634 (if (eql 2 to)
635 :timeout
636 :wtf))
637 (error (e)
638 e)))
639 (when fifo
640 (ignore-errors (delete-file fifo))))))
642 #-win32
643 (with-test (:name :overeager-character-buffering :skipped-on :win32)
644 (let ((fifo nil)
645 (proc nil))
646 (maphash
647 (lambda (format _)
648 (declare (ignore _))
649 (format t "trying ~A~%" format)
650 (finish-output t)
651 (unwind-protect
652 (progn
653 (setf fifo (sb-posix:mktemp "SBCL-fifo-XXXXXXX"))
654 (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
655 ;; KLUDGE: because we have both ends in the same process, we would
656 ;; need to use O_NONBLOCK, but this works too.
657 (setf proc
658 (run-program "/bin/sh"
659 (list "-c"
660 (format nil "cat > ~A" (native-namestring fifo)))
661 :input :stream
662 :wait nil
663 :external-format format))
664 (write-line "foobar" (process-input proc))
665 (finish-output (process-input proc))
666 (with-open-file (f fifo :direction :input :external-format format)
667 (assert (equal "foobar" (read-line f)))))
668 (when proc
669 (ignore-errors
670 (close (process-input proc) :abort t)
671 (process-wait proc))
672 (ignore-errors (process-close proc))
673 (setf proc nil))
674 (when fifo
675 (ignore-errors (delete-file fifo))
676 (setf fifo nil))))
677 sb-impl::*external-formats*)))
679 (with-test (:name :bug-657183 :skipped-on '(not :sb-unicode))
680 #+sb-unicode
681 (let ((name (merge-pathnames "stream-impure.temp-test"))
682 (text '(#\GREEK_SMALL_LETTER_LAMDA
683 #\JAPANESE_BANK_SYMBOL
684 #\Space
685 #\HEAVY_BLACK_HEART))
686 (positions '(2 5 6 9))
687 (sb-impl::*default-external-format* :utf-8))
688 (unwind-protect
689 (progn
690 (with-open-file (f name :external-format :default :direction :output
691 :if-exists :supersede)
692 (assert (eql 0 (file-position f)))
693 (mapc (lambda (char pos)
694 (write-char char f)
695 (assert (eql pos (file-position f))))
696 text
697 positions))
698 (with-open-file (f name :external-format :default :direction :input)
699 (assert (eql 0 (file-position f)))
700 (assert (eql (pop text) (read-char f)))
701 (assert (eql (file-position f) 2))
702 (assert (eql (pop text) (read-char f)))
703 (assert (eql (file-position f) 5))
704 (assert (eql (pop text) (read-char f)))
705 (assert (eql (file-position f) 6))
706 (assert (eql (pop text) (read-char f)))
707 (assert (eql (file-position f) 9))
708 (assert (eql (file-length f) 9))))
709 (ignore-errors (delete-file name)))))
711 (with-test (:name :bug-561642)
712 (let ((p "bug-561642-test.tmp"))
713 (unwind-protect
714 (progn
715 (with-open-file (f p
716 :if-exists :supersede
717 :if-does-not-exist :create
718 :direction :output)
719 (write-line "FOOBAR" f))
720 (with-open-file (f p
721 :if-exists :append
722 :direction :output)
723 (let ((p0 (file-position f))
724 (p1 (progn
725 (write-char #\newline f)
726 (file-position f)))
727 (p2 (progn
728 (write-char #\newline f)
729 (finish-output f)
730 (file-position f))))
731 (assert (eql 7 p0))
732 (assert (eql 8 p1))
733 (assert (eql 9 p2)))))
734 (ignore-errors (delete-file p)))))
736 (defstruct (mock-fd-stream
737 (:constructor %make-mock-fd-stream (buffer-chain))
738 (:include sb-impl::ansi-stream
739 (in #'mock-fd-stream-in)
740 (n-bin #'mock-fd-stream-n-bin)
741 (cin-buffer
742 (make-array sb-impl::+ansi-stream-in-buffer-length+
743 :element-type 'character))))
744 buffer-chain)
746 (defun make-mock-fd-stream (buffer-chain)
747 ;; For notational convenience, #\| becomes #\Newline.
748 (%make-mock-fd-stream
749 (mapcar (lambda (x) (substitute #\Newline #\| x)) buffer-chain)))
751 (defun mock-fd-stream-in (stream eof-err-p eof-val)
752 (sb-impl::eof-or-lose stream eof-err-p eof-val))
754 (defun mock-fd-stream-n-bin (stream char-buf start count eof-err-p)
755 (cond ((mock-fd-stream-buffer-chain stream)
756 (let* ((chars (pop (mock-fd-stream-buffer-chain stream)))
757 (n-chars (length chars)))
758 ;; make sure the mock object is being used as expected.
759 (assert (>= count (length chars)))
760 (replace char-buf chars :start1 start)
761 n-chars))
763 (sb-impl::eof-or-lose stream eof-err-p 0))))
765 (with-test (:name :read-chunk-from-frc-buffer)
766 (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo|bar" "hi"))))
767 (multiple-value-bind (line eofp)
768 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
769 (assert (and (string= line "zabcdefghfoo") (not eofp))))
770 (multiple-value-bind (line eofp)
771 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
772 (assert (and (string= line "barhi") eofp)))
773 (multiple-value-bind (line eofp)
774 (sb-impl::ansi-stream-read-line-from-frc-buffer s nil 'woot)
775 (assert (and (eq line 'woot) eofp))))
776 (let ((s (make-mock-fd-stream '("zabc" "d" "efgh" "foo*bar" "hi")))
777 (string (make-string 100)))
778 (let ((endpos
779 (sb-impl::ansi-stream-read-string-from-frc-buffer string s 10 nil)))
780 (assert (and (= endpos 28)
781 (string= (subseq string 10 endpos) "zabcdefghfoo*barhi"))))
782 (let ((endpos
783 (sb-impl::ansi-stream-read-string-from-frc-buffer string s 0 nil)))
784 (assert (= endpos 0)))))
786 ;;; success