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 `(loop for ,nxf being the hash-values of sb-impl::*external-formats*
21 do (let ((,xf (first (sb-impl::ef-names ,nxf))))
24 (defvar *test-path* "external-format-test.tmp")
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)))))
31 ;;; Test standard character read-write equivalency over all external formats.
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
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))
52 (delete-file *test-path*)
55 (test-util:report-test-status)
56 (sb-ext:exit :code 104))
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
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)
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)
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))))))
80 ;;; Test character decode restarts.
81 (with-open-file (s *test-path* :direction :output
82 :if-exists :supersede :element-type '(unsigned-byte 8))
87 (with-open-file (s *test-path* :direction :input
88 :external-format :utf-8)
91 ((sb-int:character-decoding-error #'(lambda (decoding-error)
92 (declare (ignore decoding-error))
93 (when (> (incf count) 1)
94 (error "too many errors"))
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)
103 ((sb-int:character-decoding-error #'(lambda (decoding-error)
104 (declare (ignore decoding-error))
105 (when (> (incf count) 1)
106 (error "too many errors"))
108 'sb-int:force-end-of-file))))
109 (assert (equal (read-line s nil s) "AB"))
111 (assert (equal (read-line s nil s) s)))))
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))
123 (write-sequence a s))
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)
132 ((sb-int:character-decoding-error (lambda (decoding-error)
133 (declare (ignore decoding-error))
134 (when (> (incf count) 1)
135 (error "too many errors"))
137 'sb-int:attempt-resync)))
138 ;; The failure mode is an infinite loop, add a timeout to
140 (sb-ext:timeout (lambda () (error "Timeout"))))
141 (sb-ext:with-timeout 5
143 (assert (equal (read-line s nil s)
144 "1234567890123456789012345678901234567890123456789"))))))))
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)
151 ((sb-int:character-decoding-error (lambda (decoding-error)
152 (declare (ignore decoding-error))
153 (when (> (incf count) 1)
154 (error "too many errors"))
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
161 (assert (equal (read-line s nil s)
162 "1234567890123456789012345678901234567890123456789")))
164 (assert (equal (read-line s nil s) s)))))))
166 ;;; Test character encode restarts.
167 (with-open-file (s *test-path* :direction :output
168 :if-exists :supersede :external-format :latin-1)
170 ((sb-int:character-encoding-error #'(lambda (encoding-error)
171 (declare (ignore encoding-error))
173 'sb-impl::output-nothing))))
176 (write-char (code-char 322) 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)))
183 (with-open-file (s *test-path* :direction :output
184 :if-exists :supersede :external-format :latin-1)
186 ((sb-int:character-encoding-error #'(lambda (encoding-error)
187 (declare (ignore encoding-error))
189 'sb-impl::output-nothing))))
190 (let ((string (make-array 4 :element-type 'character
191 :initial-contents `(#\A #\B ,(code-char 322)
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)))
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)))
204 (write-string ";;; ABCD" s)
205 (write-char (code-char 233) s)
208 (compile-file "external-format-test.lisp" :external-format :utf-8))
210 (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
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)
222 (write-char (code-char #xBAAD) s)
224 (sb-int:character-encoding-error ()
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*)
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))
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))
244 (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
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
252 (loop for x across standard-characters
253 for position = (file-position s)
254 for char-length = (file-string-length s x)
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*)))
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)))
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))))))
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
287 :if-exists :supersede
288 :element-type '(unsigned-byte 8))
289 ;; Write #\*, encoded in UTF-8, to the file.
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)
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)))))
304 (delete-file *test-path*)
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*
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*)
323 ;;; External format support in SB-ALIEN
325 (with-test (:name (:sb-alien :vanilla))
326 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
329 (assert (equal "foo" (strdup "foo"))))
331 (with-test (:name (:sb-alien :utf-8 :utf-8))
332 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
333 (c-string :external-format :utf-8)
334 (str (c-string :external-format :utf-8)))
335 (assert (equal "foo" (strdup "foo"))))
337 (with-test (:name (:sb-alien :latin-1 :utf-8))
338 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
339 (c-string :external-format :latin-1)
340 (str (c-string :external-format :utf-8)))
341 (assert (= (length (strdup (string (code-char 246))))
344 (with-test (:name (:sb-alien :utf-8 :latin-1))
345 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
346 (c-string :external-format :utf-8)
347 (str (c-string :external-format :latin-1)))
348 (assert (equal (string (code-char 228))
349 (strdup (concatenate 'string
350 (list (code-char 195))
351 (list (code-char 164)))))))
353 (with-test (:name (:sb-alien :ebcdic :ebcdic))
354 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
355 (c-string :external-format :ebcdic-us)
356 (str (c-string :external-format :ebcdic-us)))
357 (assert (equal "foo" (strdup "foo"))))
359 (with-test (:name (:sb-alien :latin-1 :ebcdic))
360 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
361 (c-string :external-format :latin-1)
362 (str (c-string :external-format :ebcdic-us)))
363 (assert (not (equal "foo" (strdup "foo")))))
365 (with-test (:name (:sb-alien :simple-base-string))
366 (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
367 (c-string :external-format :ebcdic-us
368 :element-type base-char)
369 (str (c-string :external-format :ebcdic-us)))
370 (assert (typep (strdup "foo") 'simple-base-string)))
372 (with-test (:name (:input-replacement :at-end-of-file))
374 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
376 (handler-bind ((sb-int:character-decoding-error
378 (invoke-restart 'sb-impl::input-replacement #\?))))
379 (with-open-file (s *test-path* :external-format :utf-8)
381 ((char= (read-char s) #\?)
382 (assert (or (= i (char-code #\?)) (> i 127))))
383 (t (assert (and (not (= i (char-code #\?))) (< i 128)))))))))
385 (with-test (:name (:unibyte-invalid-codepoints :cp857))
387 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
389 (with-open-file (s *test-path* :external-format :cp857)
390 (handler-case (read-char s)
391 (error () (assert (member i '(#xd5 #xe7 #xf2))))
392 (:no-error (char) (assert (not (member i '(#xd5 #xe7 #xf2)))))))))
393 (delete-file *test-path*)
395 (with-test (:name (:unibyte-input-replacement :cp857))
397 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
399 (with-open-file (s *test-path* :external-format '(:cp857 :replacement #\?))
400 (let ((char (read-char s)))
403 (assert (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))
404 (t (assert (not (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))))))))
405 (delete-file *test-path*)
407 (with-test (:name (:unibyte-output-replacement :cp857))
408 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:cp857 :replacement #\?))
410 (write-char (code-char i) s)))
411 (with-open-file (s *test-path* :external-format '(:cp857))
412 (let ((string (make-string 256)))
413 (read-sequence string s)
415 (assert (= (char-code (char string i)) i)))
416 (assert (= 38 (count #\? string :start 128))))))
417 (delete-file *test-path*)
419 (with-test (:name (:unibyte-input-replacement :ascii))
421 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
423 (with-open-file (s *test-path* :external-format '(:ascii :replacement #\?))
424 (let ((char (read-char s)))
427 (assert (or (= i (char-code #\?)) (> i 127))))
428 (t (assert (and (< i 128) (not (= i (char-code #\?)))))))))))
429 (delete-file *test-path*)
431 (with-test (:name (:unibyte-output-replacement :ascii))
432 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ascii :replacement #\?))
434 (write-char (code-char i) s)))
435 (with-open-file (s *test-path* :external-format '(:ascii))
436 (let ((string (make-string 256)))
437 (read-sequence string s)
439 (assert (= (char-code (char string i)) i)))
440 (assert (= 128 (count #\? string :start 128))))))
441 (delete-file *test-path*)
443 (with-test (:name (:unibyte-input-replacement :latin-1))
445 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
447 (with-open-file (s *test-path* :external-format '(:latin-1 :replacement #\?))
448 (let ((char (read-char s)))
449 (assert (= (char-code char) i))))))
450 (delete-file *test-path*)
452 (with-test (:name (:unibyte-output-replacement :latin-1))
453 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-1 :replacement #\?))
455 (write-char (code-char i) s)))
456 (with-open-file (s *test-path* :external-format '(:latin-1))
457 (let ((string (make-string 257)))
458 (read-sequence string s)
460 (assert (= (char-code (char string i)) i)))
461 (assert (char= #\? (char string 256))))))
462 (delete-file *test-path*)
465 (with-test (:name (:unibyte-input-replacement :latin-2))
467 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
469 (with-open-file (s *test-path* :external-format '(:latin-2 :replacement #\?))
470 (let ((char (read-char s)))
472 ((< i #xa1) (assert (= (char-code char) i)))
475 (delete-file *test-path*)
477 (with-test (:name (:unibyte-output-replacement :latin-2))
478 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-2 :replacement #\?))
480 (write-char (code-char i) s)))
481 (with-open-file (s *test-path* :external-format '(:latin-2))
482 (let ((string (make-string 256)))
483 (read-sequence string s)
485 (assert (= (char-code (char string i)) i)))
486 (assert (= 57 (count #\? string :start #xa1))))))
487 (delete-file *test-path*)
490 (with-test (:name (:unibyte-input-replacement :latin-3))
492 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
494 (with-open-file (s *test-path* :external-format '(:latin-3 :replacement #\?))
495 (let ((char (read-char s)))
498 (assert #1=(or (= i (char-code #\?))
499 (member i '(#xa5 #xae #xbe #xc3 #xd0 #xe3 #xf0)))))
500 (t (assert (not #1#))))))))
501 (delete-file *test-path*)
503 (with-test (:name (:unibyte-output-replacement :latin-3))
504 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-3 :replacement #\?))
506 (write-char (code-char i) s)))
507 (with-open-file (s *test-path* :external-format '(:latin-3))
508 (let ((string (make-string 256)))
509 (read-sequence string s)
511 (assert (= (char-code (char string i)) i)))
512 (assert (= 35 (count #\? string :start #xa1))))))
513 (delete-file *test-path*)
516 (with-test (:name (:unibyte-input-replacement :latin-4))
518 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
520 (with-open-file (s *test-path* :external-format '(:latin-4 :replacement #\?))
521 (let ((char (read-char s)))
523 ((< i #xa1) (assert (= (char-code char) i)))
526 (delete-file *test-path*)
528 (with-test (:name (:unibyte-output-replacement :latin-4))
529 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-4 :replacement #\?))
531 (write-char (code-char i) s)))
532 (with-open-file (s *test-path* :external-format '(:latin-4))
533 (let ((string (make-string 256)))
534 (read-sequence string s)
536 (assert (= (char-code (char string i)) i)))
537 (assert (= 50 (count #\? string :start #xa1))))))
538 (delete-file *test-path*)
541 (with-test (:name (:unibyte-input-replacement :iso-8859-5))
543 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
545 (with-open-file (s *test-path* :external-format '(:iso-8859-5 :replacement #\?))
546 (let ((char (read-char s)))
548 ((= (char-code char) i)
549 (assert (or (< i #xa1) (= i #xad))))
550 (t (assert (and (>= i #xa1) (/= i #xad)))))))))
551 (delete-file *test-path*)
553 (with-test (:name (:unibyte-output-replacement :iso-8859-5))
554 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-5 :replacement #\?))
556 (write-char (code-char i) s)))
557 (with-open-file (s *test-path* :external-format '(:iso-8859-5))
558 (let ((string (make-string 256)))
559 (read-sequence string s)
561 (assert (= (char-code (char string i)) i)))
562 (assert (= 93 (count #\? string :start #xa1))))))
563 (delete-file *test-path*)
566 (with-test (:name (:unibyte-input-replacement :iso-8859-6))
568 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
570 (with-open-file (s *test-path* :external-format '(:iso-8859-6 :replacement #\?))
571 (let ((char (read-char s)))
574 (assert #1=(or (= i (char-code #\?))
575 (<= #xa1 i #xa3) (<= #xa5 i #xab) (<= #xae i #xba)
576 (<= #xbc i #xbe) (= i #xc0) (<= #xdb i #xdf)
578 (t (assert (not #1#))))))))
579 (delete-file *test-path*)
581 (with-test (:name (:unibyte-output-replacement :iso-8859-6))
582 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-6 :replacement #\?))
584 (write-char (code-char i) s)))
585 (with-open-file (s *test-path* :external-format '(:iso-8859-6))
586 (let ((string (make-string 256)))
587 (read-sequence string s)
589 (assert (= (char-code (char string i)) i)))
590 (assert (= 93 (count #\? string :start #xa1))))))
591 (delete-file *test-path*)
594 (with-test (:name (:unibyte-input-replacement :iso-8859-7))
596 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
598 (with-open-file (s *test-path* :external-format '(:iso-8859-7 :replacement #\?))
599 (let ((char (read-char s)))
602 (assert #1=(or (= i (char-code #\?))
603 (member i '(#xa4 #xa5 #xaa #xae #xd2 #xff)))))
604 (t (assert (not #1#))))))))
605 (delete-file *test-path*)
607 (with-test (:name (:unibyte-output-replacement :iso-8859-7))
608 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-7 :replacement #\?))
610 (write-char (code-char i) s)))
611 (with-open-file (s *test-path* :external-format '(:iso-8859-7))
612 (let ((string (make-string 256)))
613 (read-sequence string s)
615 (assert (= (char-code (char string i)) i)))
616 (assert (= 80 (count #\? string :start #xa1))))))
617 (delete-file *test-path*)
620 (with-test (:name (:unibyte-input-replacement :iso-8859-8))
622 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
624 (with-open-file (s *test-path* :external-format '(:iso-8859-8 :replacement #\?))
625 (let ((char (read-char s)))
628 (assert #1=(or (= i (char-code #\?))
629 (= i #xa1) (<= #xbf i #xde) (>= i #xfb))))
630 (t (assert (not #1#))))))))
631 (delete-file *test-path*)
633 (with-test (:name (:unibyte-output-replacement :iso-8859-8))
634 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-8 :replacement #\?))
636 (write-char (code-char i) s)))
637 (with-open-file (s *test-path* :external-format '(:iso-8859-8))
638 (let ((string (make-string 256)))
639 (read-sequence string s)
641 (assert (= (char-code (char string i)) i)))
642 (assert (= 67 (count #\? string :start #xa1))))))
643 (delete-file *test-path*)
646 (with-test (:name (:unibyte-input-replacement :latin-5))
648 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
650 (with-open-file (s *test-path* :external-format '(:latin-5 :replacement #\?))
651 (let ((char (read-char s)))
652 (assert (or (and (= (char-code char) i)
653 (not (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))))
654 (and (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))
655 (not (char= char #\?)))))))))
656 (delete-file *test-path*)
658 (with-test (:name (:unibyte-output-replacement :latin-5))
659 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-5 :replacement #\?))
661 (write-char (code-char i) s)))
662 (with-open-file (s *test-path* :external-format '(:latin-5))
663 (let ((string (make-string 256)))
664 (read-sequence string s)
666 (assert (= (char-code (char string i)) i)))
667 (assert (= 6 (count #\? string :start #xd0))))))
668 (delete-file *test-path*)
671 (with-test (:name (:unibyte-input-replacement :latin-6))
673 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
675 (with-open-file (s *test-path* :external-format '(:latin-6 :replacement #\?))
676 (let ((char (read-char s)))
677 (assert (or (= (char-code char) i)
678 (and (<= #xa1 i #xff)
679 (not (char= char #\?)))))))))
680 (delete-file *test-path*)
682 (with-test (:name (:unibyte-output-replacement :latin-6))
683 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-6 :replacement #\?))
685 (write-char (code-char i) s)))
686 (with-open-file (s *test-path* :external-format '(:latin-6))
687 (let ((string (make-string 256)))
688 (read-sequence string s)
690 (assert (= (char-code (char string i)) i)))
691 (assert (= 46 (count #\? string :start #xa1))))))
692 (delete-file *test-path*)
694 ;;; iso-8859-11 tests
695 (with-test (:name (:unibyte-input-replacement :iso-8859-11))
697 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
699 (with-open-file (s *test-path* :external-format '(:iso-8859-11 :replacement #\?))
700 (let ((char (read-char s)))
703 (assert (member i #1=`(,(char-code #\?) #xdb #xdc #xdd #xde #xfc #xfd #xfe #xff))))
704 (t (assert (not (member i #1#)))))))))
705 (delete-file *test-path*)
707 (with-test (:name (:unibyte-output-replacement :iso-8859-11))
708 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-11 :replacement #\?))
710 (write-char (code-char i) s)))
711 (with-open-file (s *test-path* :external-format '(:iso-8859-11))
712 (let ((string (make-string 256)))
713 (read-sequence string s)
715 (assert (= (char-code (char string i)) i)))
716 (assert (= 95 (count #\? string :start #xa1))))))
717 (delete-file *test-path*)
720 (with-test (:name (:unibyte-input-replacement :latin-7))
722 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
724 (with-open-file (s *test-path* :external-format '(:latin-7 :replacement #\?))
725 (let ((char (read-char s)))
726 (assert (or (= (char-code char) i)
727 (and (<= #xa1 i #xff)
728 (not (char= char #\?)))))))))
729 (delete-file *test-path*)
731 (with-test (:name (:unibyte-output-replacement :latin-7))
732 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-7 :replacement #\?))
734 (write-char (code-char i) s)))
735 (with-open-file (s *test-path* :external-format '(:latin-7))
736 (let ((string (make-string 256)))
737 (read-sequence string s)
739 (assert (= (char-code (char string i)) i)))
740 (dolist (i '(#xd8 #xc6 #xf8 #xe6))
741 (assert (char/= (char string i) #\?)))
742 (assert (= 52 (count #\? string :start #xa1))))))
743 (delete-file *test-path*)
746 (with-test (:name (:unibyte-input-replacement :latin-8))
748 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
750 (with-open-file (s *test-path* :external-format '(:latin-8 :replacement #\?))
751 (let ((char (read-char s)))
752 (assert (or (= (char-code char) i)
753 (and (<= #xa1 i #xfe)
754 (not (char= char #\?)))))))))
755 (delete-file *test-path*)
757 (with-test (:name (:unibyte-output-replacement :latin-8))
758 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-8 :replacement #\?))
760 (write-char (code-char i) s)))
761 (with-open-file (s *test-path* :external-format '(:latin-8))
762 (let ((string (make-string 256)))
763 (read-sequence string s)
765 (assert (= (char-code (char string i)) i)))
766 (assert (= 31 (count #\? string :start #xa1))))))
767 (delete-file *test-path*)
770 (with-test (:name (:unibyte-input-replacement :latin-9))
772 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
774 (with-open-file (s *test-path* :external-format '(:latin-9 :replacement #\?))
775 (let ((char (read-char s)))
776 (assert (or (and (= (char-code char) i)
777 (not (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))))
778 (and (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))
779 (not (char= char #\?)))))))))
780 (delete-file *test-path*)
782 (with-test (:name (:unibyte-output-replacement :latin-9))
783 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-9 :replacement #\?))
785 (write-char (code-char i) s)))
786 (with-open-file (s *test-path* :external-format '(:latin-9))
787 (let ((string (make-string 256)))
788 (read-sequence string s)
790 (assert (= (char-code (char string i)) i)))
791 (assert (= 8 (count #\? string :start #xa4))))))
792 (delete-file *test-path*)
795 (with-test (:name (:unibyte-input-replacement :koi8-r))
797 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
799 (with-open-file (s *test-path* :external-format '(:koi8-r :replacement #\?))
800 (let ((char (read-char s)))
801 (cond ((= (char-code char) i)
803 (t (assert (> i 127))))))))
804 (delete-file *test-path*)
806 (with-test (:name (:unibyte-output-replacement :koi8-r))
807 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-r :replacement #\?))
809 (write-char (code-char i) s)))
810 (with-open-file (s *test-path* :external-format '(:koi8-r))
811 (let ((string (make-string 256)))
812 (read-sequence string s)
814 (assert (= (char-code (char string i)) i)))
815 (assert (= 122 (count #\? string :start #x80))))))
816 (delete-file *test-path*)
819 (with-test (:name (:unibyte-input-replacement :koi8-u))
821 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
823 (with-open-file (s *test-path* :external-format '(:koi8-u :replacement #\?))
824 (let ((char (read-char s)))
825 (cond ((= (char-code char) i)
827 (t (assert (> i 127))))))))
828 (delete-file *test-path*)
830 (with-test (:name (:unibyte-output-replacement :koi8-u))
831 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-u :replacement #\?))
833 (write-char (code-char i) s)))
834 (with-open-file (s *test-path* :external-format '(:koi8-u))
835 (let ((string (make-string 256)))
836 (read-sequence string s)
838 (assert (= (char-code (char string i)) i)))
839 (assert (= 122 (count #\? string :start #x80))))))
840 (delete-file *test-path*)
842 ;;; x-mac-cyrillic tests
843 (with-test (:name (:unibyte-input-replacement :x-mac-cyrillic))
845 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
847 (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic :replacement #\?))
848 (let ((char (read-char s)))
849 (cond ((= (char-code char) i)
850 (assert (or (< i 128) (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))
851 (t (assert (and (> i 127)
852 (not (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))))))))
853 (delete-file *test-path*)
855 (with-test (:name (:unibyte-output-replacement :x-mac-cyrillic))
856 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:x-mac-cyrillic :replacement #\?))
858 (write-char (code-char i) s)))
859 (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic))
860 (let ((string (make-string 256)))
861 (read-sequence string s)
863 (assert (= (char-code (char string i)) i)))
864 (assert (= 113 (count #\? string :start #x80))))))
865 (delete-file *test-path*)
868 (with-test (:name (:multibyte :ucs2le))
870 (array (map-into (make-array size :element-type '(unsigned-byte 16))
871 (lambda () (random #x10000)))))
872 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
874 (write-byte (ldb (byte 8 0) (aref array i)) s)
875 (write-byte (ldb (byte 8 8) (aref array i)) s)))
876 (with-open-file (s *test-path* :external-format :ucs2le)
877 (let ((string (make-string size)))
878 (read-sequence string s)
880 (assert (= (char-code (char string i)) (aref array i))))))))
882 (with-test (:name (:multibyte :ucs2be))
884 (array (map-into (make-array size :element-type '(unsigned-byte 16))
885 (lambda () (random #x10000)))))
886 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
888 (write-byte (ldb (byte 8 8) (aref array i)) s)
889 (write-byte (ldb (byte 8 0) (aref array i)) s)))
890 (with-open-file (s *test-path* :external-format :ucs2be)
891 (let ((string (make-string size)))
892 (read-sequence string s)
894 (assert (= (char-code (char string i)) (aref array i))))))))
896 (with-test (:name (:multibyte :output-replacement :ucs2le))
898 (string (map-into (make-string size)
899 (lambda () (code-char (random #x10000))))))
900 (setf (char string 0) (code-char #x10001)
901 (char string (1- size)) (code-char #x10002))
902 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
903 (write-string string s))
904 (with-open-file (s *test-path* :external-format :ucs2le)
905 (let ((new (make-string size)))
906 (read-sequence new s)
907 (assert (char= (char new 0) #\replacement_character))
908 (assert (char= (char new (1- size)) #\replacement_character))
909 (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
911 (with-test (:name (:multibyte :output-replacement :ucs2be))
913 (string (map-into (make-string size)
914 (lambda () (code-char (random #x10000))))))
915 (setf (char string 0) (code-char #x10001)
916 (char string (1- size)) (code-char #x10002))
917 (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
918 (write-string string s))
919 (with-open-file (s *test-path* :external-format :ucs2be)
920 (let ((new (make-string size)))
921 (read-sequence new s)
922 (assert (char= (char new 0) #\replacement_character))
923 (assert (char= (char new (1- size)) #\replacement_character))
924 (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
926 (with-test (:name (:multibyte :input-replacement :ucs4le))
927 (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
928 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
929 (write-sequence octets s))
930 (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
931 (let ((string (read-line s)))
932 (assert (char= (char string 0) (code-char #x10100)))
933 (assert (char= (char string 1) #\replacement_character))))))
935 (with-test (:name (:multibyte :input-replacement :ucs4le))
936 (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
937 (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
938 (write-sequence octets s))
939 (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
940 (let ((string (read-line s)))
941 (assert (char= (char string 0) (code-char #x10100)))
942 (assert (char= (char string 1) #\replacement_character))))))
945 (with-test (:name (:utf-16le :roundtrip))
946 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
947 (with-open-file (s *test-path* :direction :output :if-exists :supersede
948 :external-format :utf-16le)
949 (write-string string s))
950 (with-open-file (s *test-path* :external-format :utf-16le)
951 (assert (string= string (read-line s))))))
952 (with-test (:name (:utf-16be :roundtrip))
953 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
954 (with-open-file (s *test-path* :direction :output :if-exists :supersede
955 :external-format :utf-16be)
956 (write-string string s))
957 (with-open-file (s *test-path* :external-format :utf-16be)
958 (assert (string= string (read-line s))))))
959 (with-test (:name (:utf-16le :encoding-error))
960 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
961 (with-open-file (s *test-path* :direction :output :if-exists :supersede
962 :external-format '(:utf-16le :replacement #\?))
963 (write-string string s))
964 (with-open-file (s *test-path* :external-format :utf-16le)
965 (assert (string= " ???? " (read-line s))))))
966 (with-test (:name (:utf-16be :encoding-error))
967 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
968 (with-open-file (s *test-path* :direction :output :if-exists :supersede
969 :external-format '(:utf-16be :replacement #\?))
970 (write-string string s))
971 (with-open-file (s *test-path* :external-format :utf-16be)
972 (assert (string= " ???? " (read-line s))))))
974 (with-test (:name (:utf-32le :roundtrip))
975 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
976 (with-open-file (s *test-path* :direction :output :if-exists :supersede
977 :external-format :utf-32le)
978 (write-string string s))
979 (with-open-file (s *test-path* :external-format :utf-32le)
980 (assert (string= string (read-line s))))))
981 (with-test (:name (:utf-32be :roundtrip))
982 (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
983 (with-open-file (s *test-path* :direction :output :if-exists :supersede
984 :external-format :utf-32be)
985 (write-string string s))
986 (with-open-file (s *test-path* :external-format :utf-32be)
987 (assert (string= string (read-line s))))))
988 (with-test (:name (:utf-32le :encoding-error))
989 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
990 (with-open-file (s *test-path* :direction :output :if-exists :supersede
991 :external-format '(:utf-32le :replacement #\?))
992 (write-string string s))
993 (with-open-file (s *test-path* :external-format :utf-32le)
994 (assert (string= " ???? " (read-line s))))))
995 (with-test (:name (:utf-32be :encoding-error))
996 (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
997 (with-open-file (s *test-path* :direction :output :if-exists :supersede
998 :external-format '(:utf-32be :replacement #\?))
999 (write-string string s))
1000 (with-open-file (s *test-path* :external-format :utf-32be)
1001 (assert (string= " ???? " (read-line s))))))
1003 (with-test (:name :invalid-external-format :fails-on :win32)
1004 (labels ((test-error (e)
1005 (assert (typep e 'error))
1006 (unless (equal "Undefined external-format: :BAD-FORMAT"
1007 (princ-to-string e))
1008 (error "Bad error:~% ~A" e)))
1012 (open "/dev/null" :direction direction :external-format :bad-format
1013 :if-exists :overwrite)
1020 (run-program "sh" '() :input :stream :external-format :bad-format)
1024 (string-to-octets "foobar" :external-format :bad-format)
1027 (let ((octets (string-to-octets "foobar" :external-format :latin1)))
1029 (octets-to-string octets :external-format :bad-format)
1032 (with-test (:name :lp713063)
1033 (with-open-file (f *test-path*
1035 :external-format '(:euc-jp :replacement #\?)
1036 :if-exists :supersede)
1037 (write-string (make-string 3 :initial-element #\horizontal_bar) f))
1038 (assert (equal "???"
1039 (with-open-file (f *test-path*
1041 :external-format :euc-jp)
1043 (delete-file *test-path*))