0.8.12.15:
[sbcl.git] / tests / stream.impure.lisp
1 ;;;; tests related to Lisp streams
2
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.
13
14 (load "assertoid.lisp")
15 (use-package "ASSERTOID")
16
17 ;;; type errors for inappropriate stream arguments, fixed in
18 ;;; sbcl-0.7.8.19
19 (locally
20     (declare (optimize (safety 3)))
21   (assert (raises-error? (make-two-way-stream (make-string-output-stream)
22                                               (make-string-output-stream))
23                          type-error))
24   (assert (raises-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 (raises-error? (make-echo-stream (make-string-output-stream)
34                                            (make-string-output-stream))
35                          type-error))
36   (assert (raises-error? (make-echo-stream (make-string-input-stream "foo")
37                                            (make-string-input-stream "bar"))
38                          type-error))
39   (assert (raises-error? (make-concatenated-stream
40                           (make-string-output-stream)
41                           (make-string-input-stream "foo"))
42                          type-error)))
43
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)))
51
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)))
56
57 \f
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))
68 \f
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 (raises-error?
75            (with-open-file (s p :direction :output :if-exists :error))))
76   (close stream)
77   (delete-file p))
78 \f
79 (assert (raises-error? (read-byte (make-string-input-stream "abc"))
80                        type-error))
81 (assert (raises-error? (with-open-file (s "/dev/zero")
82                          (read-byte s))
83                        type-error))
84 ;;; bidirectional streams getting confused about their position
85 (let ((p "bidirectional-stream-test"))
86   (with-open-file (s p :direction :output :if-exists :supersede)
87     (with-standard-io-syntax
88       (format s "~S ~S ~S~%" 'these 'are 'symbols)))
89   (with-open-file (s p :direction :io :if-exists :overwrite)
90     (read s)
91     (with-standard-io-syntax
92       (prin1 'insert s)))
93   (with-open-file (s p)
94     (assert (string= (read-line s) "THESE INSERTMBOLS")))
95   (delete-file p))
96 \f
97 ;;; :DIRECTION :IO didn't work on non-existent pathnames
98 (let ((p "direction-io-test"))
99   (ignore-errors (delete-file p))
100   (with-open-file (s p :direction :io)
101     (format s "1")
102     (finish-output s)
103     (file-position s :start)
104     (assert (char= (read-char s) #\1)))
105   (delete-file p))
106 \f
107 ;;; FILE-POSITION on broadcast-streams is mostly uncontroversial
108 (assert (= 0 (file-position (make-broadcast-stream))))
109 (assert (file-position (make-broadcast-stream) :start))
110 (assert (file-position (make-broadcast-stream) 0))
111 (assert (not (file-position (make-broadcast-stream) 1)))
112 (let ((s (make-broadcast-stream)))
113   (write-char #\a s)
114   (assert (not (file-position s 1)))
115   (assert (= 0 (file-position s))))
116
117 (let ((p "broadcast-stream-test"))
118   (ignore-errors (delete-file p))
119   (with-open-file (f p :direction :output)
120     (let ((s (make-broadcast-stream f)))
121       (assert (= 0 (file-position s)))
122       (assert (file-position s :start))
123       (assert (file-position s 0))
124       (write-char #\a s)
125       (assert (= 1 (file-position s))) ; unicode...
126       (assert (file-position s 0))))
127   (delete-file p))
128
129 ;;; CLOSING a non-new streams should not delete them, and superseded
130 ;;; files should be restored.
131 (let ((test "test-file-for-close-should-not-delete"))
132   (macrolet ((test-mode (mode)
133                `(progn
134                  (catch :close-test-exit
135                    (with-open-file (f test :direction :output :if-exists ,mode)
136                      (write-line "test" f)
137                      (throw :close-test-exit t)))
138                  (assert (and (probe-file test) ,mode)))))
139     (unwind-protect
140          (progn
141            (with-open-file (f test :direction :output)
142              (write-line "test" f))
143            (test-mode :append)
144            ;; FIXME: We really should recover supersede files as well, according to
145            ;; CLOSE in CLHS, but at the moment we don't.
146            ;; (test-mode :supersede)
147            (test-mode :rename)
148            (test-mode :rename-and-delete))
149       (when (probe-file test)
150         (delete-file test)))))
151
152 ;;; success
153 (quit :unix-status 104)