1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / tests / external-format.impure.lisp
blob96c86082569dd9113b7043db656df5a3535bf5a8
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
5 ;;;; users.
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
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
12 ;;;; from CMU CL.
13 ;;;;
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)
19 (let ((nxf (gensym)))
20 `(loop for ,nxf being the hash-values of sb-impl::*external-formats*
21 do (let ((,xf (first (sb-impl::ef-names ,nxf))))
22 ,@body))))
24 (defvar *test-path* "external-format-test.tmp")
26 (do-external-formats (xf)
27 (with-open-file (s #-win32 "/dev/null" #+win32 "nul" :direction :input :external-format xf)
28 (assert (eq (read-char s nil s) s))))
30 ;;; Test standard character read-write equivalency over all external formats.
31 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
32 (do-external-formats (xf)
33 (with-open-file (s *test-path* :direction :output
34 :if-exists :supersede :external-format xf)
35 (loop for character across standard-characters
36 do (write-char character s)))
37 (with-open-file (s *test-path* :direction :input
38 :external-format xf)
39 (loop for character across standard-characters
40 do (let ((got (read-char s)))
41 (unless (eql character got)
42 (error "wanted ~S, got ~S" character got)))))))
44 (delete-file *test-path*)
45 #-sb-unicode
46 (progn
47 (test-util:report-test-status)
48 (sb-ext:quit :unix-status 104))
50 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
51 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
52 ;;; 4096 wide.
53 (dotimes (width-1 4)
54 (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
55 (dotimes (offset (+ width-1 1))
56 (with-open-file (s *test-path* :direction :output
57 :if-exists :supersede :external-format :utf-8)
58 (dotimes (n offset)
59 (write-char #\a s))
60 (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
61 (write-char character s)))
62 (with-open-file (s *test-path* :direction :input
63 :external-format :utf-8)
64 (dotimes (n offset)
65 (assert (eql (read-char s) #\a)))
66 (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
67 (let ((got (read-char s)))
68 (unless (eql got character)
69 (error "wanted ~S, got ~S (~S)" character got n))))
70 (assert (eql (read-char s nil s) s))))))
72 ;;; Test character decode restarts.
73 (with-open-file (s *test-path* :direction :output
74 :if-exists :supersede :element-type '(unsigned-byte 8))
75 (write-byte 65 s)
76 (write-byte 66 s)
77 (write-byte #xe0 s)
78 (write-byte 67 s))
79 (with-open-file (s *test-path* :direction :input
80 :external-format :utf-8)
81 (let ((count 0))
82 (handler-bind
83 ((sb-int:character-decoding-error #'(lambda (decoding-error)
84 (declare (ignore decoding-error))
85 (when (> (incf count) 1)
86 (error "too many errors"))
87 (invoke-restart
88 'sb-int:attempt-resync))))
89 (assert (equal (read-line s nil s) "ABC"))
90 (assert (equal (read-line s nil s) s)))))
91 (with-open-file (s *test-path* :direction :input
92 :external-format :utf-8)
93 (let ((count 0))
94 (handler-bind
95 ((sb-int:character-decoding-error #'(lambda (decoding-error)
96 (declare (ignore decoding-error))
97 (when (> (incf count) 1)
98 (error "too many errors"))
99 (invoke-restart
100 'sb-int:force-end-of-file))))
101 (assert (equal (read-line s nil s) "AB"))
102 (setf count 0)
103 (assert (equal (read-line s nil s) s)))))
105 ;;; And again with more data to account for buffering (this was briefly)
106 ;;; broken in early 0.9.6.
107 (with-open-file (s *test-path* :direction :output
108 :if-exists :supersede :element-type '(unsigned-byte 8))
109 (let ((a (make-array 50
110 :element-type '(unsigned-byte 64)
111 :initial-contents (map 'list #'char-code
112 "1234567890123456789012345678901234567890123456789."))))
113 (setf (aref a 49) (char-code #\Newline))
114 (dotimes (i 40)
115 (write-sequence a s))
116 (write-byte #xe0 s)
117 (dotimes (i 40)
118 (write-sequence a s))))
119 (with-test (:name (:character-decode-large :attempt-resync))
120 (with-open-file (s *test-path* :direction :input
121 :external-format :utf-8)
122 (let ((count 0))
123 (handler-bind
124 ((sb-int:character-decoding-error (lambda (decoding-error)
125 (declare (ignore decoding-error))
126 (when (> (incf count) 1)
127 (error "too many errors"))
128 (invoke-restart
129 'sb-int:attempt-resync)))
130 ;; The failure mode is an infinite loop, add a timeout to
131 ;; detetct it.
132 (sb-ext:timeout (lambda () (error "Timeout"))))
133 (sb-ext:with-timeout 5
134 (dotimes (i 80)
135 (assert (equal (read-line s nil s)
136 "1234567890123456789012345678901234567890123456789"))))))))
138 (with-test (:name (:character-decode-large :force-end-of-file))
139 (with-open-file (s *test-path* :direction :input
140 :external-format :utf-8)
141 (let ((count 0))
142 (handler-bind
143 ((sb-int:character-decoding-error (lambda (decoding-error)
144 (declare (ignore decoding-error))
145 (when (> (incf count) 1)
146 (error "too many errors"))
147 (invoke-restart
148 'sb-int:force-end-of-file)))
149 ;; The failure mode is an infinite loop, add a timeout to detetct it.
150 (sb-ext:timeout (lambda () (error "Timeout"))))
151 (sb-ext:with-timeout 5
152 (dotimes (i 40)
153 (assert (equal (read-line s nil s)
154 "1234567890123456789012345678901234567890123456789")))
155 (setf count 0)
156 (assert (equal (read-line s nil s) s)))))))
158 ;;; Test character encode restarts.
159 (with-open-file (s *test-path* :direction :output
160 :if-exists :supersede :external-format :latin-1)
161 (handler-bind
162 ((sb-int:character-encoding-error #'(lambda (encoding-error)
163 (declare (ignore encoding-error))
164 (invoke-restart
165 'sb-impl::output-nothing))))
166 (write-char #\A s)
167 (write-char #\B s)
168 (write-char (code-char 322) s)
169 (write-char #\C s)))
170 (with-open-file (s *test-path* :direction :input
171 :external-format :latin-1)
172 (assert (equal (read-line s nil s) "ABC"))
173 (assert (equal (read-line s nil s) s)))
175 (with-open-file (s *test-path* :direction :output
176 :if-exists :supersede :external-format :latin-1)
177 (handler-bind
178 ((sb-int:character-encoding-error #'(lambda (encoding-error)
179 (declare (ignore encoding-error))
180 (invoke-restart
181 'sb-impl::output-nothing))))
182 (let ((string (make-array 4 :element-type 'character
183 :initial-contents `(#\A #\B ,(code-char 322)
184 #\C))))
185 (write-string string s))))
186 (with-open-file (s *test-path* :direction :input
187 :external-format :latin-1)
188 (assert (equal (read-line s nil s) "ABC"))
189 (assert (equal (read-line s nil s) s)))
191 ;;; Test skipping character-decode-errors in comments.
192 (let ((s (open "external-format-test.lisp" :direction :output
193 :if-exists :supersede :external-format :latin-1)))
194 (unwind-protect
195 (progn
196 (write-string ";;; ABCD" s)
197 (write-char (code-char 233) s)
198 (terpri s)
199 (close s)
200 (compile-file "external-format-test.lisp" :external-format :utf-8))
201 (delete-file s)
202 (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
203 (when p
204 (delete-file p)))))
207 ;;;; KOI8-R external format
208 (with-open-file (s *test-path* :direction :output
209 :if-exists :supersede :external-format :koi8-r)
210 (write-char (code-char #xB0) s)
211 (assert (eq
212 (handler-case
213 (progn
214 (write-char (code-char #xBAAD) s)
215 :bad)
216 (sb-int:character-encoding-error ()
217 :good))
218 :good)))
219 (with-open-file (s *test-path* :direction :input
220 :element-type '(unsigned-byte 8))
221 (let ((byte (read-byte s)))
222 (assert (= (eval byte) #x9C))))
223 (with-open-file (s *test-path* :direction :input
224 :external-format :koi8-r)
225 (let ((char (read-char s)))
226 (assert (= (char-code (eval char)) #xB0))))
227 (delete-file *test-path*)
229 (let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8))))
230 (uni-codes #(1055 1088 1080 1074 1077 1090 33))
232 (string (octets-to-string koi8-r-codes :external-format :koi8-r))
233 (uni-decoded (map 'vector #'char-code string)))
234 (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r))
235 uni-codes))
236 (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
237 koi8-r-codes)))
239 ;;; tests of FILE-STRING-LENGTH
240 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
241 (do-external-formats (xf)
242 (with-open-file (s *test-path* :direction :output
243 :external-format xf)
244 (loop for x across standard-characters
245 for position = (file-position s)
246 for char-length = (file-string-length s x)
247 do (write-char x s)
248 do (assert (= (file-position s) (+ position char-length))))
249 (let ((position (file-position s))
250 (string-length (file-string-length s standard-characters)))
251 (write-string standard-characters s)
252 (assert (= (file-position s) (+ position string-length)))))
253 (delete-file *test-path*)))
255 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
256 8191 8192 16383 16384 32767 32768 65535 65536 131071
257 131072 262143 262144)))
258 (with-open-file (s *test-path* :direction :output
259 :external-format :utf-8)
260 (dolist (code char-codes)
261 (let* ((char (code-char code))
262 (position (file-position s))
263 (char-length (file-string-length s char)))
264 (write-char char s)
265 (assert (= (file-position s) (+ position char-length)))))
266 (let* ((string (map 'string #'code-char char-codes))
267 (position (file-position s))
268 (string-length (file-string-length s string)))
269 (write-string string s)
270 (assert (= (file-position s) (+ position string-length))))))
273 ;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files"
274 ;;; by Lutz Euler on 2006-03-05 for more details.
275 (with-test (:name (:file-position :utf-8))
276 (let ((path *test-path*))
277 (with-open-file (s path
278 :direction :output
279 :if-exists :supersede
280 :element-type '(unsigned-byte 8))
281 ;; Write #\*, encoded in UTF-8, to the file.
282 (write-byte 42 s)
283 ;; Append #\adiaeresis, encoded in UTF-8, to the file.
284 (write-sequence '(195 164) s))
285 (with-open-file (s path :external-format :utf-8)
286 (read-char s)
287 (let ((pos (file-position s))
288 (char (read-char s)))
289 (format t "read character with code ~a successfully from file position ~a~%"
290 (char-code char) pos)
291 (file-position s pos)
292 (format t "set file position back to ~a, trying to read-char again~%" pos)
293 (let ((new-char (read-char s)))
294 (assert (char= char new-char)))))
295 (values)))
296 (delete-file *test-path*)
298 ;;; We used to call STREAM-EXTERNAL-FORMAT on the stream in the error
299 ;;; when printing a coding error, but that didn't work if the stream
300 ;;; was closed by the time the error was printed. See sbcl-devel
301 ;;; "Subject: Printing coding errors for closed streams" by Zach Beane
302 ;;; on 2008-10-16 for more info.
303 (with-test (:name (:character-coding-error-stream-external-format))
304 (flet ((first-file-character ()
305 (with-open-file (stream *test-path* :external-format :utf-8)
306 (read-char stream))))
307 (with-open-file (stream *test-path*
308 :direction :output
309 :if-exists :supersede
310 :element-type '(unsigned-byte 8))
311 (write-byte 192 stream))
312 (princ-to-string (nth-value 1 (ignore-errors (first-file-character))))))
313 (delete-file *test-path*)
315 ;;; External format support in SB-ALIEN
317 (with-test (:name (:sb-alien :vanilla))
318 (define-alien-routine strdup c-string (str c-string))
319 (assert (equal "foo" (strdup "foo"))))
321 (with-test (:name (:sb-alien :utf-8 :utf-8))
322 (define-alien-routine strdup (c-string :external-format :utf-8)
323 (str (c-string :external-format :utf-8)))
324 (assert (equal "foo" (strdup "foo"))))
326 (with-test (:name (:sb-alien :latin-1 :utf-8))
327 (define-alien-routine strdup (c-string :external-format :latin-1)
328 (str (c-string :external-format :utf-8)))
329 (assert (= (length (strdup (string (code-char 246))))
330 2)))
332 (with-test (:name (:sb-alien :utf-8 :latin-1))
333 (define-alien-routine strdup (c-string :external-format :utf-8)
334 (str (c-string :external-format :latin-1)))
335 (assert (equal (string (code-char 228))
336 (strdup (concatenate 'string
337 (list (code-char 195))
338 (list (code-char 164)))))))
340 (with-test (:name (:sb-alien :ebcdic :ebcdic))
341 (define-alien-routine strdup (c-string :external-format :ebcdic-us)
342 (str (c-string :external-format :ebcdic-us)))
343 (assert (equal "foo" (strdup "foo"))))
345 (with-test (:name (:sb-alien :latin-1 :ebcdic))
346 (define-alien-routine strdup (c-string :external-format :latin-1)
347 (str (c-string :external-format :ebcdic-us)))
348 (assert (not (equal "foo" (strdup "foo")))))
350 (with-test (:name (:sb-alien :simple-base-string))
351 (define-alien-routine strdup (c-string :external-format :ebcdic-us
352 :element-type base-char)
353 (str (c-string :external-format :ebcdic-us)))
354 (assert (typep (strdup "foo") 'simple-base-string)))
356 (with-test (:name (:input-replacement :at-end-of-file))
357 (dotimes (i 256)
358 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
359 (write-byte i s))
360 (handler-bind ((sb-int:character-decoding-error
361 (lambda (c)
362 (invoke-restart 'sb-impl::input-replacement #\?))))
363 (with-open-file (s *test-path* :external-format :utf-8)
364 (cond
365 ((char= (read-char s) #\?)
366 (assert (or (= i (char-code #\?)) (> i 127))))
367 (t (assert (and (not (= i (char-code #\?))) (< i 128)))))))))
369 (with-test (:name (:unibyte-invalid-codepoints :cp857))
370 (dotimes (i 256)
371 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
372 (write-byte i s))
373 (with-open-file (s *test-path* :external-format :cp857)
374 (handler-case (read-char s)
375 (error () (assert (member i '(#xd5 #xe7 #xf2))))
376 (:no-error (char) (assert (not (member i '(#xd5 #xe7 #xf2)))))))))
377 (delete-file *test-path*)
379 (with-test (:name (:unibyte-input-replacement :cp857))
380 (dotimes (i 256)
381 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
382 (write-byte i s))
383 (with-open-file (s *test-path* :external-format '(:cp857 :replacement #\?))
384 (let ((char (read-char s)))
385 (cond
386 ((eq char #\?)
387 (assert (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))
388 (t (assert (not (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))))))))
389 (delete-file *test-path*)
391 (with-test (:name (:unibyte-output-replacement :cp857))
392 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:cp857 :replacement #\?))
393 (dotimes (i 256)
394 (write-char (code-char i) s)))
395 (with-open-file (s *test-path* :external-format '(:cp857))
396 (let ((string (make-string 256)))
397 (read-sequence string s)
398 (dotimes (i 128)
399 (assert (= (char-code (char string i)) i)))
400 (assert (= 38 (count #\? string :start 128))))))
401 (delete-file *test-path*)
403 (with-test (:name (:unibyte-input-replacement :ascii))
404 (dotimes (i 256)
405 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
406 (write-byte i s))
407 (with-open-file (s *test-path* :external-format '(:ascii :replacement #\?))
408 (let ((char (read-char s)))
409 (cond
410 ((eq char #\?)
411 (assert (or (= i (char-code #\?)) (> i 127))))
412 (t (assert (and (< i 128) (not (= i (char-code #\?)))))))))))
413 (delete-file *test-path*)
415 (with-test (:name (:unibyte-output-replacement :ascii))
416 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ascii :replacement #\?))
417 (dotimes (i 256)
418 (write-char (code-char i) s)))
419 (with-open-file (s *test-path* :external-format '(:ascii))
420 (let ((string (make-string 256)))
421 (read-sequence string s)
422 (dotimes (i 128)
423 (assert (= (char-code (char string i)) i)))
424 (assert (= 128 (count #\? string :start 128))))))
425 (delete-file *test-path*)
427 (with-test (:name (:unibyte-input-replacement :latin-1))
428 (dotimes (i 256)
429 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
430 (write-byte i s))
431 (with-open-file (s *test-path* :external-format '(:latin-1 :replacement #\?))
432 (let ((char (read-char s)))
433 (assert (= (char-code char) i))))))
434 (delete-file *test-path*)
436 (with-test (:name (:unibyte-output-replacement :latin-1))
437 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-1 :replacement #\?))
438 (dotimes (i 257)
439 (write-char (code-char i) s)))
440 (with-open-file (s *test-path* :external-format '(:latin-1))
441 (let ((string (make-string 257)))
442 (read-sequence string s)
443 (dotimes (i 256)
444 (assert (= (char-code (char string i)) i)))
445 (assert (char= #\? (char string 256))))))
446 (delete-file *test-path*)
448 ;;; latin-2 tests
449 (with-test (:name (:unibyte-input-replacement :latin-2))
450 (dotimes (i 256)
451 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
452 (write-byte i s))
453 (with-open-file (s *test-path* :external-format '(:latin-2 :replacement #\?))
454 (let ((char (read-char s)))
455 (cond
456 ((< i #xa1) (assert (= (char-code char) i)))
457 ;; FIXME: more tests
458 )))))
459 (delete-file *test-path*)
461 (with-test (:name (:unibyte-output-replacement :latin-2))
462 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-2 :replacement #\?))
463 (dotimes (i 256)
464 (write-char (code-char i) s)))
465 (with-open-file (s *test-path* :external-format '(:latin-2))
466 (let ((string (make-string 256)))
467 (read-sequence string s)
468 (dotimes (i #xa1)
469 (assert (= (char-code (char string i)) i)))
470 (assert (= 57 (count #\? string :start #xa1))))))
471 (delete-file *test-path*)
473 ;;; latin-3 tests
474 (with-test (:name (:unibyte-input-replacement :latin-3))
475 (dotimes (i 256)
476 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
477 (write-byte i s))
478 (with-open-file (s *test-path* :external-format '(:latin-3 :replacement #\?))
479 (let ((char (read-char s)))
480 (cond
481 ((eq char #\?)
482 (assert #1=(or (= i (char-code #\?))
483 (member i '(#xa5 #xae #xbe #xc3 #xd0 #xe3 #xf0)))))
484 (t (assert (not #1#))))))))
485 (delete-file *test-path*)
487 (with-test (:name (:unibyte-output-replacement :latin-3))
488 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-3 :replacement #\?))
489 (dotimes (i 256)
490 (write-char (code-char i) s)))
491 (with-open-file (s *test-path* :external-format '(:latin-3))
492 (let ((string (make-string 256)))
493 (read-sequence string s)
494 (dotimes (i #xa1)
495 (assert (= (char-code (char string i)) i)))
496 (assert (= 35 (count #\? string :start #xa1))))))
497 (delete-file *test-path*)
499 ;;; latin-4 tests
500 (with-test (:name (:unibyte-input-replacement :latin-4))
501 (dotimes (i 256)
502 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
503 (write-byte i s))
504 (with-open-file (s *test-path* :external-format '(:latin-4 :replacement #\?))
505 (let ((char (read-char s)))
506 (cond
507 ((< i #xa1) (assert (= (char-code char) i)))
508 ;; FIXME: more tests
509 )))))
510 (delete-file *test-path*)
512 (with-test (:name (:unibyte-output-replacement :latin-4))
513 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-4 :replacement #\?))
514 (dotimes (i 256)
515 (write-char (code-char i) s)))
516 (with-open-file (s *test-path* :external-format '(:latin-4))
517 (let ((string (make-string 256)))
518 (read-sequence string s)
519 (dotimes (i #xa1)
520 (assert (= (char-code (char string i)) i)))
521 (assert (= 50 (count #\? string :start #xa1))))))
522 (delete-file *test-path*)
524 ;;; iso-8859-5 tests
525 (with-test (:name (:unibyte-input-replacement :iso-8859-5))
526 (dotimes (i 256)
527 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
528 (write-byte i s))
529 (with-open-file (s *test-path* :external-format '(:iso-8859-5 :replacement #\?))
530 (let ((char (read-char s)))
531 (cond
532 ((= (char-code char) i)
533 (assert (or (< i #xa1) (= i #xad))))
534 (t (assert (and (>= i #xa1) (/= i #xad)))))))))
535 (delete-file *test-path*)
537 (with-test (:name (:unibyte-output-replacement :iso-8859-5))
538 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-5 :replacement #\?))
539 (dotimes (i 256)
540 (write-char (code-char i) s)))
541 (with-open-file (s *test-path* :external-format '(:iso-8859-5))
542 (let ((string (make-string 256)))
543 (read-sequence string s)
544 (dotimes (i #xa1)
545 (assert (= (char-code (char string i)) i)))
546 (assert (= 93 (count #\? string :start #xa1))))))
547 (delete-file *test-path*)
549 ;;; iso-8859-6 tests
550 (with-test (:name (:unibyte-input-replacement :iso-8859-6))
551 (dotimes (i 256)
552 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
553 (write-byte i s))
554 (with-open-file (s *test-path* :external-format '(:iso-8859-6 :replacement #\?))
555 (let ((char (read-char s)))
556 (cond
557 ((eq char #\?)
558 (assert #1=(or (= i (char-code #\?))
559 (<= #xa1 i #xa3) (<= #xa5 i #xab) (<= #xae i #xba)
560 (<= #xbc i #xbe) (= i #xc0) (<= #xdb i #xdf)
561 (<= #xf3 i))))
562 (t (assert (not #1#))))))))
563 (delete-file *test-path*)
565 (with-test (:name (:unibyte-output-replacement :iso-8859-6))
566 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-6 :replacement #\?))
567 (dotimes (i 256)
568 (write-char (code-char i) s)))
569 (with-open-file (s *test-path* :external-format '(:iso-8859-6))
570 (let ((string (make-string 256)))
571 (read-sequence string s)
572 (dotimes (i #xa1)
573 (assert (= (char-code (char string i)) i)))
574 (assert (= 93 (count #\? string :start #xa1))))))
575 (delete-file *test-path*)
577 ;;; iso-8859-7 tests
578 (with-test (:name (:unibyte-input-replacement :iso-8859-7))
579 (dotimes (i 256)
580 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
581 (write-byte i s))
582 (with-open-file (s *test-path* :external-format '(:iso-8859-7 :replacement #\?))
583 (let ((char (read-char s)))
584 (cond
585 ((eq char #\?)
586 (assert #1=(or (= i (char-code #\?))
587 (member i '(#xa4 #xa5 #xaa #xae #xd2 #xff)))))
588 (t (assert (not #1#))))))))
589 (delete-file *test-path*)
591 (with-test (:name (:unibyte-output-replacement :iso-8859-7))
592 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-7 :replacement #\?))
593 (dotimes (i 256)
594 (write-char (code-char i) s)))
595 (with-open-file (s *test-path* :external-format '(:iso-8859-7))
596 (let ((string (make-string 256)))
597 (read-sequence string s)
598 (dotimes (i #xa1)
599 (assert (= (char-code (char string i)) i)))
600 (assert (= 80 (count #\? string :start #xa1))))))
601 (delete-file *test-path*)
603 ;;; iso-8859-8 tests
604 (with-test (:name (:unibyte-input-replacement :iso-8859-8))
605 (dotimes (i 256)
606 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
607 (write-byte i s))
608 (with-open-file (s *test-path* :external-format '(:iso-8859-8 :replacement #\?))
609 (let ((char (read-char s)))
610 (cond
611 ((eq char #\?)
612 (assert #1=(or (= i (char-code #\?))
613 (= i #xa1) (<= #xbf i #xde) (>= i #xfb))))
614 (t (assert (not #1#))))))))
615 (delete-file *test-path*)
617 (with-test (:name (:unibyte-output-replacement :iso-8859-8))
618 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-8 :replacement #\?))
619 (dotimes (i 256)
620 (write-char (code-char i) s)))
621 (with-open-file (s *test-path* :external-format '(:iso-8859-8))
622 (let ((string (make-string 256)))
623 (read-sequence string s)
624 (dotimes (i #xa1)
625 (assert (= (char-code (char string i)) i)))
626 (assert (= 67 (count #\? string :start #xa1))))))
627 (delete-file *test-path*)
629 ;;; latin-5 tests
630 (with-test (:name (:unibyte-input-replacement :latin-5))
631 (dotimes (i 256)
632 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
633 (write-byte i s))
634 (with-open-file (s *test-path* :external-format '(:latin-5 :replacement #\?))
635 (let ((char (read-char s)))
636 (assert (or (and (= (char-code char) i)
637 (not (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))))
638 (and (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))
639 (not (char= char #\?)))))))))
640 (delete-file *test-path*)
642 (with-test (:name (:unibyte-output-replacement :latin-5))
643 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-5 :replacement #\?))
644 (dotimes (i 256)
645 (write-char (code-char i) s)))
646 (with-open-file (s *test-path* :external-format '(:latin-5))
647 (let ((string (make-string 256)))
648 (read-sequence string s)
649 (dotimes (i #xd0)
650 (assert (= (char-code (char string i)) i)))
651 (assert (= 6 (count #\? string :start #xd0))))))
652 (delete-file *test-path*)
654 ;;; latin-6 tests
655 (with-test (:name (:unibyte-input-replacement :latin-6))
656 (dotimes (i 256)
657 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
658 (write-byte i s))
659 (with-open-file (s *test-path* :external-format '(:latin-6 :replacement #\?))
660 (let ((char (read-char s)))
661 (assert (or (= (char-code char) i)
662 (and (<= #xa1 i #xff)
663 (not (char= char #\?)))))))))
664 (delete-file *test-path*)
666 (with-test (:name (:unibyte-output-replacement :latin-6))
667 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-6 :replacement #\?))
668 (dotimes (i 256)
669 (write-char (code-char i) s)))
670 (with-open-file (s *test-path* :external-format '(:latin-6))
671 (let ((string (make-string 256)))
672 (read-sequence string s)
673 (dotimes (i #xa1)
674 (assert (= (char-code (char string i)) i)))
675 (assert (= 46 (count #\? string :start #xa1))))))
676 (delete-file *test-path*)
678 ;;; iso-8859-11 tests
679 (with-test (:name (:unibyte-input-replacement :iso-8859-11))
680 (dotimes (i 256)
681 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
682 (write-byte i s))
683 (with-open-file (s *test-path* :external-format '(:iso-8859-11 :replacement #\?))
684 (let ((char (read-char s)))
685 (cond
686 ((eq char #\?)
687 (assert (member i #1=`(,(char-code #\?) #xdb #xdc #xdd #xde #xfc #xfd #xfe #xff))))
688 (t (assert (not (member i #1#)))))))))
689 (delete-file *test-path*)
691 (with-test (:name (:unibyte-output-replacement :iso-8859-11))
692 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-11 :replacement #\?))
693 (dotimes (i 256)
694 (write-char (code-char i) s)))
695 (with-open-file (s *test-path* :external-format '(:iso-8859-11))
696 (let ((string (make-string 256)))
697 (read-sequence string s)
698 (dotimes (i #xa1)
699 (assert (= (char-code (char string i)) i)))
700 (assert (= 95 (count #\? string :start #xa1))))))
701 (delete-file *test-path*)
703 ;;; latin-7 tests
704 (with-test (:name (:unibyte-input-replacement :latin-7))
705 (dotimes (i 256)
706 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
707 (write-byte i s))
708 (with-open-file (s *test-path* :external-format '(:latin-7 :replacement #\?))
709 (let ((char (read-char s)))
710 (assert (or (= (char-code char) i)
711 (and (<= #xa1 i #xff)
712 (not (char= char #\?)))))))))
713 (delete-file *test-path*)
715 (with-test (:name (:unibyte-output-replacement :latin-7))
716 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-7 :replacement #\?))
717 (dotimes (i 256)
718 (write-char (code-char i) s)))
719 (with-open-file (s *test-path* :external-format '(:latin-7))
720 (let ((string (make-string 256)))
721 (read-sequence string s)
722 (dotimes (i #xa1)
723 (assert (= (char-code (char string i)) i)))
724 (dolist (i '(#xd8 #xc6 #xf8 #xe6))
725 (assert (char/= (char string i) #\?)))
726 (assert (= 52 (count #\? string :start #xa1))))))
727 (delete-file *test-path*)
729 ;;; latin-8 tests
730 (with-test (:name (:unibyte-input-replacement :latin-8))
731 (dotimes (i 256)
732 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
733 (write-byte i s))
734 (with-open-file (s *test-path* :external-format '(:latin-8 :replacement #\?))
735 (let ((char (read-char s)))
736 (assert (or (= (char-code char) i)
737 (and (<= #xa1 i #xfe)
738 (not (char= char #\?)))))))))
739 (delete-file *test-path*)
741 (with-test (:name (:unibyte-output-replacement :latin-8))
742 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-8 :replacement #\?))
743 (dotimes (i 256)
744 (write-char (code-char i) s)))
745 (with-open-file (s *test-path* :external-format '(:latin-8))
746 (let ((string (make-string 256)))
747 (read-sequence string s)
748 (dotimes (i #xa1)
749 (assert (= (char-code (char string i)) i)))
750 (assert (= 31 (count #\? string :start #xa1))))))
751 (delete-file *test-path*)
753 ;;; latin-9 tests
754 (with-test (:name (:unibyte-input-replacement :latin-9))
755 (dotimes (i 256)
756 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
757 (write-byte i s))
758 (with-open-file (s *test-path* :external-format '(:latin-9 :replacement #\?))
759 (let ((char (read-char s)))
760 (assert (or (and (= (char-code char) i)
761 (not (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))))
762 (and (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))
763 (not (char= char #\?)))))))))
764 (delete-file *test-path*)
766 (with-test (:name (:unibyte-output-replacement :latin-9))
767 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-9 :replacement #\?))
768 (dotimes (i 256)
769 (write-char (code-char i) s)))
770 (with-open-file (s *test-path* :external-format '(:latin-9))
771 (let ((string (make-string 256)))
772 (read-sequence string s)
773 (dotimes (i #xa4)
774 (assert (= (char-code (char string i)) i)))
775 (assert (= 8 (count #\? string :start #xa4))))))
776 (delete-file *test-path*)
778 ;;; koi8-r tests
779 (with-test (:name (:unibyte-input-replacement :koi8-r))
780 (dotimes (i 256)
781 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
782 (write-byte i s))
783 (with-open-file (s *test-path* :external-format '(:koi8-r :replacement #\?))
784 (let ((char (read-char s)))
785 (cond ((= (char-code char) i)
786 (assert (< i 128)))
787 (t (assert (> i 127))))))))
788 (delete-file *test-path*)
790 (with-test (:name (:unibyte-output-replacement :koi8-r))
791 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-r :replacement #\?))
792 (dotimes (i 256)
793 (write-char (code-char i) s)))
794 (with-open-file (s *test-path* :external-format '(:koi8-r))
795 (let ((string (make-string 256)))
796 (read-sequence string s)
797 (dotimes (i #x80)
798 (assert (= (char-code (char string i)) i)))
799 (assert (= 122 (count #\? string :start #x80))))))
800 (delete-file *test-path*)
802 ;;; koi8-u tests
803 (with-test (:name (:unibyte-input-replacement :koi8-u))
804 (dotimes (i 256)
805 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
806 (write-byte i s))
807 (with-open-file (s *test-path* :external-format '(:koi8-u :replacement #\?))
808 (let ((char (read-char s)))
809 (cond ((= (char-code char) i)
810 (assert (< i 128)))
811 (t (assert (> i 127))))))))
812 (delete-file *test-path*)
814 (with-test (:name (:unibyte-output-replacement :koi8-u))
815 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-u :replacement #\?))
816 (dotimes (i 256)
817 (write-char (code-char i) s)))
818 (with-open-file (s *test-path* :external-format '(:koi8-u))
819 (let ((string (make-string 256)))
820 (read-sequence string s)
821 (dotimes (i #x80)
822 (assert (= (char-code (char string i)) i)))
823 (assert (= 122 (count #\? string :start #x80))))))
824 (delete-file *test-path*)
826 ;;; x-mac-cyrillic tests
827 (with-test (:name (:unibyte-input-replacement :x-mac-cyrillic))
828 (dotimes (i 256)
829 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
830 (write-byte i s))
831 (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic :replacement #\?))
832 (let ((char (read-char s)))
833 (cond ((= (char-code char) i)
834 (assert (or (< i 128) (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))
835 (t (assert (and (> i 127)
836 (not (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))))))))
837 (delete-file *test-path*)
839 (with-test (:name (:unibyte-output-replacement :x-mac-cyrillic))
840 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:x-mac-cyrillic :replacement #\?))
841 (dotimes (i 256)
842 (write-char (code-char i) s)))
843 (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic))
844 (let ((string (make-string 256)))
845 (read-sequence string s)
846 (dotimes (i #x80)
847 (assert (= (char-code (char string i)) i)))
848 (assert (= 113 (count #\? string :start #x80))))))
849 (delete-file *test-path*)
851 ;;; ucs-2 tests
852 (with-test (:name (:multibyte :ucs2le))
853 (let* ((size 120)
854 (array (map-into (make-array size :element-type '(unsigned-byte 16))
855 (lambda () (random #x10000)))))
856 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
857 (dotimes (i size)
858 (write-byte (ldb (byte 8 0) (aref array i)) s)
859 (write-byte (ldb (byte 8 8) (aref array i)) s)))
860 (with-open-file (s *test-path* :external-format :ucs2le)
861 (let ((string (make-string size)))
862 (read-sequence string s)
863 (dotimes (i size)
864 (assert (= (char-code (char string i)) (aref array i))))))))
866 (with-test (:name (:multibyte :ucs2be))
867 (let* ((size 120)
868 (array (map-into (make-array size :element-type '(unsigned-byte 16))
869 (lambda () (random #x10000)))))
870 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
871 (dotimes (i size)
872 (write-byte (ldb (byte 8 8) (aref array i)) s)
873 (write-byte (ldb (byte 8 0) (aref array i)) s)))
874 (with-open-file (s *test-path* :external-format :ucs2be)
875 (let ((string (make-string size)))
876 (read-sequence string s)
877 (dotimes (i size)
878 (assert (= (char-code (char string i)) (aref array i))))))))
880 (with-test (:name (:multibyte :output-replacement :ucs2le))
881 (let* ((size 1200)
882 (string (map-into (make-string size)
883 (lambda () (code-char (random #x10000))))))
884 (setf (char string 0) (code-char #x10001)
885 (char string (1- size)) (code-char #x10002))
886 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
887 (write-string string s))
888 (with-open-file (s *test-path* :external-format :ucs2le)
889 (let ((new (make-string size)))
890 (read-sequence new s)
891 (assert (char= (char new 0) #\replacement_character))
892 (assert (char= (char new (1- size)) #\replacement_character))
893 (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
895 (with-test (:name (:multibyte :output-replacement :ucs2be))
896 (let* ((size 1200)
897 (string (map-into (make-string size)
898 (lambda () (code-char (random #x10000))))))
899 (setf (char string 0) (code-char #x10001)
900 (char string (1- size)) (code-char #x10002))
901 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
902 (write-string string s))
903 (with-open-file (s *test-path* :external-format :ucs2be)
904 (let ((new (make-string size)))
905 (read-sequence new s)
906 (assert (char= (char new 0) #\replacement_character))
907 (assert (char= (char new (1- size)) #\replacement_character))
908 (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
910 (with-test (:name (:multibyte :input-replacement :ucs4le))
911 (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
912 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
913 (write-sequence octets s))
914 (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
915 (let ((string (read-line s)))
916 (assert (char= (char string 0) (code-char #x10100)))
917 (assert (char= (char string 1) #\replacement_character))))))
919 (with-test (:name (:multibyte :input-replacement :ucs4le))
920 (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
921 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
922 (write-sequence octets s))
923 (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
924 (let ((string (read-line s)))
925 (assert (char= (char string 0) (code-char #x10100)))
926 (assert (char= (char string 1) #\replacement_character))))))
928 ;;; utf tests
929 (with-test (:name (:utf-16le :roundtrip))
930 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
931 (with-open-file (s *test-path* :direction :output :if-exists :supersede
932 :external-format :utf-16le)
933 (write-string string s))
934 (with-open-file (s *test-path* :external-format :utf-16le)
935 (assert (string= string (read-line s))))))
936 (with-test (:name (:utf-16be :roundtrip))
937 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
938 (with-open-file (s *test-path* :direction :output :if-exists :supersede
939 :external-format :utf-16be)
940 (write-string string s))
941 (with-open-file (s *test-path* :external-format :utf-16be)
942 (assert (string= string (read-line s))))))
943 (with-test (:name (:utf-16le :encoding-error))
944 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
945 (with-open-file (s *test-path* :direction :output :if-exists :supersede
946 :external-format '(:utf-16le :replacement #\?))
947 (write-string string s))
948 (with-open-file (s *test-path* :external-format :utf-16le)
949 (assert (string= " ???? " (read-line s))))))
950 (with-test (:name (:utf-16be :encoding-error))
951 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
952 (with-open-file (s *test-path* :direction :output :if-exists :supersede
953 :external-format '(:utf-16be :replacement #\?))
954 (write-string string s))
955 (with-open-file (s *test-path* :external-format :utf-16be)
956 (assert (string= " ???? " (read-line s))))))
958 (with-test (:name (:utf-32le :roundtrip))
959 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
960 (with-open-file (s *test-path* :direction :output :if-exists :supersede
961 :external-format :utf-32le)
962 (write-string string s))
963 (with-open-file (s *test-path* :external-format :utf-32le)
964 (assert (string= string (read-line s))))))
965 (with-test (:name (:utf-32be :roundtrip))
966 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
967 (with-open-file (s *test-path* :direction :output :if-exists :supersede
968 :external-format :utf-32be)
969 (write-string string s))
970 (with-open-file (s *test-path* :external-format :utf-32be)
971 (assert (string= string (read-line s))))))
972 (with-test (:name (:utf-32le :encoding-error))
973 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
974 (with-open-file (s *test-path* :direction :output :if-exists :supersede
975 :external-format '(:utf-32le :replacement #\?))
976 (write-string string s))
977 (with-open-file (s *test-path* :external-format :utf-32le)
978 (assert (string= " ???? " (read-line s))))))
979 (with-test (:name (:utf-32be :encoding-error))
980 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
981 (with-open-file (s *test-path* :direction :output :if-exists :supersede
982 :external-format '(:utf-32be :replacement #\?))
983 (write-string string s))
984 (with-open-file (s *test-path* :external-format :utf-32be)
985 (assert (string= " ???? " (read-line s))))))
987 ;;;; success