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