1 ;;;; This file is for testing external-format functionality, using
2 ;;;; test machinery which might have side effects (e.g. executing
3 ;;;; DEFUN, writing files). Note that the tests here reach into
4 ;;;; unexported functionality, and should not be used as a guide for
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
18 (defmacro do-external-formats ((xf &optional result) &body body)
20 `(dolist (,nxf sb-impl::*external-formats* ,result)
21 (let ((,xf (first (first ,nxf))))
24 (do-external-formats (xf)
25 (with-open-file (s "/dev/null" :direction :input :external-format xf)
26 (assert (eq (read-char s nil s) s))))
28 ;;; Test standard character read-write equivalency over all external formats.
29 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
30 (do-external-formats (xf)
31 (with-open-file (s "external-format-test.txt" :direction :output
32 :if-exists :supersede :external-format xf)
33 (loop for character across standard-characters
34 do (write-char character s)))
35 (with-open-file (s "external-format-test.txt" :direction :input
37 (loop for character across standard-characters
38 do (assert (eql (read-char s) character))))))
40 (delete-file "external-format-test.txt")
43 (test-util:report-test-status)
44 (sb-ext:quit :unix-status 104))
46 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
47 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
50 (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
51 (dotimes (offset (+ width-1 1))
52 (with-open-file (s "external-format-test.txt" :direction :output
53 :if-exists :supersede :external-format :utf-8)
57 (write-char character s)))
58 (with-open-file (s "external-format-test.txt" :direction :input
59 :external-format :utf-8)
61 (assert (eql (read-char s) #\a)))
63 (assert (eql (read-char s) character)))
64 (assert (eql (read-char s nil s) s))))))
66 ;;; Test character decode restarts.
67 (with-open-file (s "external-format-test.txt" :direction :output
68 :if-exists :supersede :element-type '(unsigned-byte 8))
73 (with-open-file (s "external-format-test.txt" :direction :input
74 :external-format :utf-8)
76 ((sb-int:character-decoding-error #'(lambda (decoding-error)
77 (declare (ignore decoding-error))
79 'sb-int:attempt-resync))))
80 (assert (equal (read-line s nil s) "ABC"))
81 (assert (equal (read-line s nil s) s))))
82 (with-open-file (s "external-format-test.txt" :direction :input
83 :external-format :utf-8)
85 ((sb-int:character-decoding-error #'(lambda (decoding-error)
86 (declare (ignore decoding-error))
88 'sb-int:force-end-of-file))))
89 (assert (equal (read-line s nil s) "AB"))
90 (assert (equal (read-line s nil s) s))))
92 ;;; And again with more data to account for buffering (this was briefly)
93 ;;; broken in early 0.9.6.
94 (with-open-file (s "external-format-test.txt" :direction :output
95 :if-exists :supersede :element-type '(unsigned-byte 8))
96 (let ((a (make-array 50
97 :element-type '(unsigned-byte 64)
98 :initial-contents (map 'list #'char-code
99 "1234567890123456789012345678901234567890123456789."))))
100 (setf (aref a 49) (char-code #\Newline))
102 (write-sequence a s))
105 (write-sequence a s))))
106 (with-test (:name (:character-decode-large :attempt-resync))
107 (with-open-file (s "external-format-test.txt" :direction :input
108 :external-format :utf-8)
110 ((sb-int:character-decoding-error #'(lambda (decoding-error)
111 (declare (ignore decoding-error))
113 'sb-int:attempt-resync)))
114 ;; The failure mode is an infinite loop, add a timeout to detetct it.
115 (sb-ext:timeout (lambda () (error "Timeout"))))
116 (sb-ext:with-timeout 5
118 (assert (equal (read-line s nil s)
119 "1234567890123456789012345678901234567890123456789")))))))
120 (with-test (:name (:character-decode-large :force-end-of-file)
122 (with-open-file (s "external-format-test.txt" :direction :input
123 :external-format :utf-8)
125 ((sb-int:character-decoding-error #'(lambda (decoding-error)
126 (declare (ignore decoding-error))
128 'sb-int:force-end-of-file)))
129 ;; The failure mode is an infinite loop, add a timeout to detetct it.
130 (sb-ext:timeout (lambda () (error "Timeout"))))
131 (sb-ext:with-timeout 5
133 (assert (equal (read-line s nil s)
134 "1234567890123456789012345678901234567890123456789")))
135 (assert (equal (read-line s nil s) s))))))
137 ;;; Test character encode restarts.
138 (with-open-file (s "external-format-test.txt" :direction :output
139 :if-exists :supersede :external-format :latin-1)
141 ((sb-int:character-encoding-error #'(lambda (encoding-error)
142 (declare (ignore encoding-error))
144 'sb-impl::output-nothing))))
147 (write-char (code-char 322) s)
149 (with-open-file (s "external-format-test.txt" :direction :input
150 :external-format :latin-1)
151 (assert (equal (read-line s nil s) "ABC"))
152 (assert (equal (read-line s nil s) s)))
154 (with-open-file (s "external-format-test.txt" :direction :output
155 :if-exists :supersede :external-format :latin-1)
157 ((sb-int:character-encoding-error #'(lambda (encoding-error)
158 (declare (ignore encoding-error))
160 'sb-impl::output-nothing))))
161 (let ((string (make-array 4 :element-type 'character
162 :initial-contents `(#\A #\B ,(code-char 322)
164 (write-string string s))))
165 (with-open-file (s "external-format-test.txt" :direction :input
166 :external-format :latin-1)
167 (assert (equal (read-line s nil s) "ABC"))
168 (assert (equal (read-line s nil s) s)))
170 ;;; Test skipping character-decode-errors in comments.
171 (let ((s (open "external-format-test.lisp" :direction :output
172 :if-exists :supersede :external-format :latin-1)))
175 (write-string ";;; ABCD" s)
176 (write-char (code-char 233) s)
179 (compile-file "external-format-test.lisp" :external-format :utf-8))
181 (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
186 ;;;; KOI8-R external format
187 (with-open-file (s "external-format-test.txt" :direction :output
188 :if-exists :supersede :external-format :koi8-r)
189 (write-char (code-char #xB0) s)
193 (write-char (code-char #xBAAD) s)
195 (sb-int:character-encoding-error ()
198 (with-open-file (s "external-format-test.txt" :direction :input
199 :element-type '(unsigned-byte 8))
200 (let ((byte (read-byte s)))
201 (assert (= (eval byte) #x9C))))
202 (with-open-file (s "external-format-test.txt" :direction :input
203 :external-format :koi8-r)
204 (let ((char (read-char s)))
205 (assert (= (char-code (eval char)) #xB0))))
206 (delete-file "external-format-test.txt")
208 ;;; tests of FILE-STRING-LENGTH
209 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
210 (do-external-formats (xf)
211 (with-open-file (s "external-format-test.txt" :direction :output
213 (loop for x across standard-characters
214 for position = (file-position s)
215 for char-length = (file-string-length s x)
217 do (assert (= (file-position s) (+ position char-length))))
218 (let ((position (file-position s))
219 (string-length (file-string-length s standard-characters)))
220 (write-string standard-characters s)
221 (assert (= (file-position s) (+ position string-length)))))
222 (delete-file "external-format-test.txt")))
224 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
225 8191 8192 16383 16384 32767 32768 65535 65536 131071
226 131072 262143 262144)))
227 (with-open-file (s "external-format-test.txt" :direction :output
228 :external-format :utf-8)
229 (dolist (code char-codes)
230 (let* ((char (code-char code))
231 (position (file-position s))
232 (char-length (file-string-length s char)))
234 (assert (= (file-position s) (+ position char-length)))))
235 (let* ((string (map 'string #'code-char char-codes))
236 (position (file-position s))
237 (string-length (file-string-length s string)))
238 (write-string string s)
239 (assert (= (file-position s) (+ position string-length))))))