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