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) &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:exit :code 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          (let ((*error-output* (make-broadcast-stream)))
 209            (compile-file "external-format-test.lisp"
 210                          :external-format :utf-8 :verbose nil)))
 211     (delete-file s)
 212     (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
 213       (when p
 214         (delete-file p)))))
 215
 216 \f
 217 ;;;; KOI8-R external format
 218 (with-open-file (s *test-path* :direction :output
 219                  :if-exists :supersede :external-format :koi8-r)
 220   (write-char (code-char #xB0) s)
 221   (assert (eq
 222            (handler-case
 223                (progn
 224                  (write-char (code-char #xBAAD) s)
 225                  :bad)
 226              (sb-int:character-encoding-error ()
 227                :good))
 228            :good)))
 229 (with-open-file (s *test-path* :direction :input
 230                  :element-type '(unsigned-byte 8))
 231   (let ((byte (read-byte s)))
 232     (assert (= (eval byte) #x9C))))
 233 (with-open-file (s *test-path* :direction :input
 234                  :external-format :koi8-r)
 235   (let ((char (read-char s)))
 236     (assert (= (char-code (eval char)) #xB0))))
 237 (delete-file *test-path*)
 238
 239 (let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8))))
 240        (uni-codes #(1055 1088 1080 1074 1077 1090 33))
 241
 242        (string (octets-to-string koi8-r-codes :external-format :koi8-r))
 243        (uni-decoded (map 'vector #'char-code string)))
 244   (declare (ignore uni-decoded))
 245   (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r))
 246                   uni-codes))
 247   (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
 248                   koi8-r-codes)))
 249 \f
 250 ;;; tests of FILE-STRING-LENGTH
 251 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
 252   (do-external-formats (xf)
 253     (with-open-file (s *test-path* :direction :output
 254                        :external-format xf)
 255       (loop for x across standard-characters
 256             for position = (file-position s)
 257             for char-length = (file-string-length s x)
 258             do (write-char x s)
 259             do (assert (= (file-position s) (+ position char-length))))
 260       (let ((position (file-position s))
 261             (string-length (file-string-length s standard-characters)))
 262         (write-string standard-characters s)
 263         (assert (= (file-position s) (+ position string-length)))))
 264     (delete-file *test-path*)))
 265
 266 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
 267                     8191 8192 16383 16384 32767 32768 65535 65536 131071
 268                     131072 262143 262144)))
 269   (with-open-file (s *test-path* :direction :output
 270                      :external-format :utf-8)
 271     (dolist (code char-codes)
 272       (let* ((char (code-char code))
 273              (position (file-position s))
 274              (char-length (file-string-length s char)))
 275         (write-char char s)
 276         (assert (= (file-position s) (+ position char-length)))))
 277     (let* ((string (map 'string #'code-char char-codes))
 278            (position (file-position s))
 279            (string-length (file-string-length s string)))
 280       (write-string string s)
 281       (assert (= (file-position s) (+ position string-length))))))
 282 \f
 283
 284 ;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files"
 285 ;;; by Lutz Euler on 2006-03-05 for more details.
 286 (with-test (:name (:file-position :utf-8))
 287   (let ((path *test-path*))
 288     (with-open-file (s path
 289                        :direction :output
 290                        :if-exists :supersede
 291                        :element-type '(unsigned-byte 8))
 292       ;; Write #\*, encoded in UTF-8, to the file.
 293       (write-byte 42 s)
 294       ;; Append #\adiaeresis, encoded in UTF-8, to the file.
 295       (write-sequence '(195 164) s))
 296     (with-open-file (s path :external-format :utf-8)
 297       (read-char s)
 298       (let ((pos (file-position s))
 299             (char (read-char s)))
 300         #+nil
 301         (format t "read character with code ~a successfully from file position ~a~%"
 302                 (char-code char) pos)
 303         (file-position s pos)
 304         #+nil
 305         (format t "set file position back to ~a, trying to read-char again~%" pos)
 306         (let ((new-char (read-char s)))
 307           (assert (char= char new-char)))))
 308     (values)))
 309 (delete-file *test-path*)
 310
 311 ;;; We used to call STREAM-EXTERNAL-FORMAT on the stream in the error
 312 ;;; when printing a coding error, but that didn't work if the stream
 313 ;;; was closed by the time the error was printed.  See sbcl-devel
 314 ;;; "Subject: Printing coding errors for closed streams" by Zach Beane
 315 ;;; on 2008-10-16 for more info.
 316 (with-test (:name (:character-coding-error-stream-external-format))
 317   (flet ((first-file-character ()
 318            (with-open-file (stream *test-path* :external-format :utf-8)
 319              (read-char stream))))
 320     (with-open-file (stream *test-path*
 321                             :direction :output
 322                             :if-exists :supersede
 323                             :element-type '(unsigned-byte 8))
 324       (write-byte 192 stream))
 325     (princ-to-string (nth-value 1 (ignore-errors (first-file-character))))))
 326 (delete-file *test-path*)
 327
 328 ;;; External format support in SB-ALIEN
 329
 330 (with-test (:name (:sb-alien :vanilla))
 331   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 332       c-string
 333     (str c-string))
 334   (assert (equal "foo" (strdup "foo"))))
 335
 336 (with-test (:name (:sb-alien :utf-8 :utf-8))
 337   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 338       (c-string :external-format :utf-8)
 339     (str (c-string :external-format :utf-8)))
 340   (assert (equal "foo" (strdup "foo"))))
 341
 342 (with-test (:name (:sb-alien :latin-1 :utf-8))
 343   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 344       (c-string :external-format :latin-1)
 345     (str (c-string :external-format :utf-8)))
 346   (assert (= (length (strdup (string (code-char 246))))
 347              2)))
 348
 349 (with-test (:name (:sb-alien :utf-8 :latin-1))
 350   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 351       (c-string :external-format :utf-8)
 352     (str (c-string :external-format :latin-1)))
 353   (assert (equal (string (code-char 228))
 354                  (strdup (concatenate 'string
 355                                       (list (code-char 195))
 356                                       (list (code-char 164)))))))
 357
 358 (with-test (:name (:sb-alien :ebcdic :ebcdic))
 359   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 360       (c-string :external-format :ebcdic-us)
 361     (str (c-string :external-format :ebcdic-us)))
 362   (assert (equal "foo" (strdup "foo"))))
 363
 364 (with-test (:name (:sb-alien :latin-1 :ebcdic))
 365   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 366       (c-string :external-format :latin-1)
 367     (str (c-string :external-format :ebcdic-us)))
 368   (assert (not (equal "foo" (strdup "foo")))))
 369
 370 (with-test (:name (:sb-alien :simple-base-string))
 371   (define-alien-routine (#-win32 "strdup" #+win32 "_strdup" strdup)
 372       (c-string :external-format :ebcdic-us
 373                 :element-type base-char)
 374     (str (c-string :external-format :ebcdic-us)))
 375   (assert (typep (strdup "foo") 'simple-base-string)))
 376
 377 (with-test (:name (:input-replacement :at-end-of-file))
 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     (handler-bind ((sb-int:character-decoding-error
 382                     (lambda (c)
 383                       (declare (ignore c))
 384                       (invoke-restart 'sb-impl::input-replacement #\?))))
 385       (with-open-file (s *test-path* :external-format :utf-8)
 386         (cond
 387           ((char= (read-char s) #\?)
 388            (assert (or (= i (char-code #\?)) (> i 127))))
 389           (t (assert (and (not (= i (char-code #\?))) (< i 128)))))))))
 390
 391 (with-test (:name (:unibyte-invalid-codepoints :cp857))
 392   (dotimes (i 256)
 393     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 394       (write-byte i s))
 395     (with-open-file (s *test-path* :external-format :cp857)
 396       (handler-case (read-char s)
 397         (error () (assert (member i '(#xd5 #xe7 #xf2))))
 398         (:no-error (char) char (assert (not (member i '(#xd5 #xe7 #xf2)))))))))
 399 (delete-file *test-path*)
 400
 401 (with-test (:name (:unibyte-input-replacement :cp857))
 402   (dotimes (i 256)
 403     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 404       (write-byte i s))
 405     (with-open-file (s *test-path* :external-format '(:cp857 :replacement #\?))
 406       (let ((char (read-char s)))
 407         (cond
 408           ((eq char #\?)
 409            (assert (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))
 410           (t (assert (not (member i `(,(char-code #\?) #xd5 #xe7 #xf2))))))))))
 411 (delete-file *test-path*)
 412
 413 (with-test (:name (:unibyte-output-replacement :cp857))
 414   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:cp857 :replacement #\?))
 415     (dotimes (i 256)
 416       (write-char (code-char i) s)))
 417   (with-open-file (s *test-path* :external-format '(:cp857))
 418     (let ((string (make-string 256)))
 419       (read-sequence string s)
 420       (dotimes (i 128)
 421         (assert (= (char-code (char string i)) i)))
 422       (assert (= 38 (count #\? string :start 128))))))
 423 (delete-file *test-path*)
 424
 425 (with-test (:name (:unibyte-input-replacement :ascii))
 426   (dotimes (i 256)
 427     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 428       (write-byte i s))
 429     (with-open-file (s *test-path* :external-format '(:ascii :replacement #\?))
 430       (let ((char (read-char s)))
 431         (cond
 432           ((eq char #\?)
 433            (assert (or (= i (char-code #\?)) (> i 127))))
 434           (t (assert (and (< i 128) (not (= i (char-code #\?)))))))))))
 435 (delete-file *test-path*)
 436
 437 (with-test (:name (:unibyte-output-replacement :ascii))
 438   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ascii :replacement #\?))
 439     (dotimes (i 256)
 440       (write-char (code-char i) s)))
 441   (with-open-file (s *test-path* :external-format '(:ascii))
 442     (let ((string (make-string 256)))
 443       (read-sequence string s)
 444       (dotimes (i 128)
 445         (assert (= (char-code (char string i)) i)))
 446       (assert (= 128 (count #\? string :start 128))))))
 447 (delete-file *test-path*)
 448
 449 (with-test (:name (:unibyte-input-replacement :latin-1))
 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-1 :replacement #\?))
 454       (let ((char (read-char s)))
 455         (assert (= (char-code char) i))))))
 456 (delete-file *test-path*)
 457
 458 (with-test (:name (:unibyte-output-replacement :latin-1))
 459   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-1 :replacement #\?))
 460     (dotimes (i 257)
 461       (write-char (code-char i) s)))
 462   (with-open-file (s *test-path* :external-format '(:latin-1))
 463     (let ((string (make-string 257)))
 464       (read-sequence string s)
 465       (dotimes (i 256)
 466         (assert (= (char-code (char string i)) i)))
 467       (assert (char= #\? (char string 256))))))
 468 (delete-file *test-path*)
 469 \f
 470 ;;; latin-2 tests
 471 (with-test (:name (:unibyte-input-replacement :latin-2))
 472   (dotimes (i 256)
 473     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 474       (write-byte i s))
 475     (with-open-file (s *test-path* :external-format '(:latin-2 :replacement #\?))
 476       (let ((char (read-char s)))
 477         (cond
 478           ((< i #xa1) (assert (= (char-code char) i)))
 479           ;; FIXME: more tests
 480           )))))
 481 (delete-file *test-path*)
 482
 483 (with-test (:name (:unibyte-output-replacement :latin-2))
 484   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-2 :replacement #\?))
 485     (dotimes (i 256)
 486       (write-char (code-char i) s)))
 487   (with-open-file (s *test-path* :external-format '(:latin-2))
 488     (let ((string (make-string 256)))
 489       (read-sequence string s)
 490       (dotimes (i #xa1)
 491         (assert (= (char-code (char string i)) i)))
 492       (assert (= 57 (count #\? string :start #xa1))))))
 493 (delete-file *test-path*)
 494 \f
 495 ;;; latin-3 tests
 496 (with-test (:name (:unibyte-input-replacement :latin-3))
 497   (dotimes (i 256)
 498     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 499       (write-byte i s))
 500     (with-open-file (s *test-path* :external-format '(:latin-3 :replacement #\?))
 501       (let ((char (read-char s)))
 502         (cond
 503           ((eq char #\?)
 504            (assert #1=(or (= i (char-code #\?))
 505                           (member i '(#xa5 #xae #xbe #xc3 #xd0 #xe3 #xf0)))))
 506           (t (assert (not #1#))))))))
 507 (delete-file *test-path*)
 508
 509 (with-test (:name (:unibyte-output-replacement :latin-3))
 510   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-3 :replacement #\?))
 511     (dotimes (i 256)
 512       (write-char (code-char i) s)))
 513   (with-open-file (s *test-path* :external-format '(:latin-3))
 514     (let ((string (make-string 256)))
 515       (read-sequence string s)
 516       (dotimes (i #xa1)
 517         (assert (= (char-code (char string i)) i)))
 518       (assert (= 35 (count #\? string :start #xa1))))))
 519 (delete-file *test-path*)
 520 \f
 521 ;;; latin-4 tests
 522 (with-test (:name (:unibyte-input-replacement :latin-4))
 523   (dotimes (i 256)
 524     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 525       (write-byte i s))
 526     (with-open-file (s *test-path* :external-format '(:latin-4 :replacement #\?))
 527       (let ((char (read-char s)))
 528         (cond
 529           ((< i #xa1) (assert (= (char-code char) i)))
 530           ;; FIXME: more tests
 531           )))))
 532 (delete-file *test-path*)
 533
 534 (with-test (:name (:unibyte-output-replacement :latin-4))
 535   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-4 :replacement #\?))
 536     (dotimes (i 256)
 537       (write-char (code-char i) s)))
 538   (with-open-file (s *test-path* :external-format '(:latin-4))
 539     (let ((string (make-string 256)))
 540       (read-sequence string s)
 541       (dotimes (i #xa1)
 542         (assert (= (char-code (char string i)) i)))
 543       (assert (= 50 (count #\? string :start #xa1))))))
 544 (delete-file *test-path*)
 545 \f
 546 ;;; iso-8859-5 tests
 547 (with-test (:name (:unibyte-input-replacement :iso-8859-5))
 548   (dotimes (i 256)
 549     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 550       (write-byte i s))
 551     (with-open-file (s *test-path* :external-format '(:iso-8859-5 :replacement #\?))
 552       (let ((char (read-char s)))
 553         (cond
 554           ((= (char-code char) i)
 555            (assert (or (< i #xa1) (= i #xad))))
 556           (t (assert (and (>= i #xa1) (/= i #xad)))))))))
 557 (delete-file *test-path*)
 558
 559 (with-test (:name (:unibyte-output-replacement :iso-8859-5))
 560   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-5 :replacement #\?))
 561     (dotimes (i 256)
 562       (write-char (code-char i) s)))
 563   (with-open-file (s *test-path* :external-format '(:iso-8859-5))
 564     (let ((string (make-string 256)))
 565       (read-sequence string s)
 566       (dotimes (i #xa1)
 567         (assert (= (char-code (char string i)) i)))
 568       (assert (= 93 (count #\? string :start #xa1))))))
 569 (delete-file *test-path*)
 570 \f
 571 ;;; iso-8859-6 tests
 572 (with-test (:name (:unibyte-input-replacement :iso-8859-6))
 573   (dotimes (i 256)
 574     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 575       (write-byte i s))
 576     (with-open-file (s *test-path* :external-format '(:iso-8859-6 :replacement #\?))
 577       (let ((char (read-char s)))
 578         (cond
 579           ((eq char #\?)
 580            (assert #1=(or (= i (char-code #\?))
 581                           (<= #xa1 i #xa3) (<= #xa5 i #xab) (<= #xae i #xba)
 582                           (<= #xbc i #xbe) (= i #xc0) (<= #xdb i #xdf)
 583                           (<= #xf3 i))))
 584           (t (assert (not #1#))))))))
 585 (delete-file *test-path*)
 586
 587 (with-test (:name (:unibyte-output-replacement :iso-8859-6))
 588   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-6 :replacement #\?))
 589     (dotimes (i 256)
 590       (write-char (code-char i) s)))
 591   (with-open-file (s *test-path* :external-format '(:iso-8859-6))
 592     (let ((string (make-string 256)))
 593       (read-sequence string s)
 594       (dotimes (i #xa1)
 595         (assert (= (char-code (char string i)) i)))
 596       (assert (= 93 (count #\? string :start #xa1))))))
 597 (delete-file *test-path*)
 598 \f
 599 ;;; iso-8859-7 tests
 600 (with-test (:name (:unibyte-input-replacement :iso-8859-7))
 601   (dotimes (i 256)
 602     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 603       (write-byte i s))
 604     (with-open-file (s *test-path* :external-format '(:iso-8859-7 :replacement #\?))
 605       (let ((char (read-char s)))
 606         (cond
 607           ((eq char #\?)
 608            (assert #1=(or (= i (char-code #\?))
 609                           (member i '(#xa4 #xa5 #xaa #xae #xd2 #xff)))))
 610           (t (assert (not #1#))))))))
 611 (delete-file *test-path*)
 612
 613 (with-test (:name (:unibyte-output-replacement :iso-8859-7))
 614   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-7 :replacement #\?))
 615     (dotimes (i 256)
 616       (write-char (code-char i) s)))
 617   (with-open-file (s *test-path* :external-format '(:iso-8859-7))
 618     (let ((string (make-string 256)))
 619       (read-sequence string s)
 620       (dotimes (i #xa1)
 621         (assert (= (char-code (char string i)) i)))
 622       (assert (= 80 (count #\? string :start #xa1))))))
 623 (delete-file *test-path*)
 624 \f
 625 ;;; iso-8859-8 tests
 626 (with-test (:name (:unibyte-input-replacement :iso-8859-8))
 627   (dotimes (i 256)
 628     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 629       (write-byte i s))
 630     (with-open-file (s *test-path* :external-format '(:iso-8859-8 :replacement #\?))
 631       (let ((char (read-char s)))
 632         (cond
 633           ((eq char #\?)
 634            (assert #1=(or (= i (char-code #\?))
 635                           (= i #xa1) (<= #xbf i #xde) (>= i #xfb))))
 636           (t (assert (not  #1#))))))))
 637 (delete-file *test-path*)
 638
 639 (with-test (:name (:unibyte-output-replacement :iso-8859-8))
 640   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-8 :replacement #\?))
 641     (dotimes (i 256)
 642       (write-char (code-char i) s)))
 643   (with-open-file (s *test-path* :external-format '(:iso-8859-8))
 644     (let ((string (make-string 256)))
 645       (read-sequence string s)
 646       (dotimes (i #xa1)
 647         (assert (= (char-code (char string i)) i)))
 648       (assert (= 67 (count #\? string :start #xa1))))))
 649 (delete-file *test-path*)
 650 \f
 651 ;;; latin-5 tests
 652 (with-test (:name (:unibyte-input-replacement :latin-5))
 653   (dotimes (i 256)
 654     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 655       (write-byte i s))
 656     (with-open-file (s *test-path* :external-format '(:latin-5 :replacement #\?))
 657       (let ((char (read-char s)))
 658         (assert (or (and (= (char-code char) i)
 659                          (not (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))))
 660                     (and (member i '(#xd0 #xdd #xde #xf0 #xfd #xfe))
 661                          (not (char= char #\?)))))))))
 662 (delete-file *test-path*)
 663
 664 (with-test (:name (:unibyte-output-replacement :latin-5))
 665   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-5 :replacement #\?))
 666     (dotimes (i 256)
 667       (write-char (code-char i) s)))
 668   (with-open-file (s *test-path* :external-format '(:latin-5))
 669     (let ((string (make-string 256)))
 670       (read-sequence string s)
 671       (dotimes (i #xd0)
 672         (assert (= (char-code (char string i)) i)))
 673       (assert (= 6 (count #\? string :start #xd0))))))
 674 (delete-file *test-path*)
 675 \f
 676 ;;; latin-6 tests
 677 (with-test (:name (:unibyte-input-replacement :latin-6))
 678   (dotimes (i 256)
 679     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 680       (write-byte i s))
 681     (with-open-file (s *test-path* :external-format '(:latin-6 :replacement #\?))
 682       (let ((char (read-char s)))
 683         (assert (or (= (char-code char) i)
 684                     (and (<= #xa1 i #xff)
 685                          (not (char= char #\?)))))))))
 686 (delete-file *test-path*)
 687
 688 (with-test (:name (:unibyte-output-replacement :latin-6))
 689   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-6 :replacement #\?))
 690     (dotimes (i 256)
 691       (write-char (code-char i) s)))
 692   (with-open-file (s *test-path* :external-format '(:latin-6))
 693     (let ((string (make-string 256)))
 694       (read-sequence string s)
 695       (dotimes (i #xa1)
 696         (assert (= (char-code (char string i)) i)))
 697       (assert (= 46 (count #\? string :start #xa1))))))
 698 (delete-file *test-path*)
 699 \f
 700 ;;; iso-8859-11 tests
 701 (with-test (:name (:unibyte-input-replacement :iso-8859-11))
 702   (dotimes (i 256)
 703     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 704       (write-byte i s))
 705     (with-open-file (s *test-path* :external-format '(:iso-8859-11 :replacement #\?))
 706       (let ((char (read-char s)))
 707         (cond
 708           ((eq char #\?)
 709            (assert (member i #1=`(,(char-code #\?) #xdb #xdc #xdd #xde #xfc #xfd #xfe #xff))))
 710           (t (assert (not (member i #1#)))))))))
 711 (delete-file *test-path*)
 712
 713 (with-test (:name (:unibyte-output-replacement :iso-8859-11))
 714   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:iso-8859-11 :replacement #\?))
 715     (dotimes (i 256)
 716       (write-char (code-char i) s)))
 717   (with-open-file (s *test-path* :external-format '(:iso-8859-11))
 718     (let ((string (make-string 256)))
 719       (read-sequence string s)
 720       (dotimes (i #xa1)
 721         (assert (= (char-code (char string i)) i)))
 722       (assert (= 95 (count #\? string :start #xa1))))))
 723 (delete-file *test-path*)
 724 \f
 725 ;;; latin-7 tests
 726 (with-test (:name (:unibyte-input-replacement :latin-7))
 727   (dotimes (i 256)
 728     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 729       (write-byte i s))
 730     (with-open-file (s *test-path* :external-format '(:latin-7 :replacement #\?))
 731       (let ((char (read-char s)))
 732         (assert (or (= (char-code char) i)
 733                     (and (<= #xa1 i #xff)
 734                          (not (char= char #\?)))))))))
 735 (delete-file *test-path*)
 736
 737 (with-test (:name (:unibyte-output-replacement :latin-7))
 738   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-7 :replacement #\?))
 739     (dotimes (i 256)
 740       (write-char (code-char i) s)))
 741   (with-open-file (s *test-path* :external-format '(:latin-7))
 742     (let ((string (make-string 256)))
 743       (read-sequence string s)
 744       (dotimes (i #xa1)
 745         (assert (= (char-code (char string i)) i)))
 746       (dolist (i '(#xd8 #xc6 #xf8 #xe6))
 747         (assert (char/= (char string i) #\?)))
 748       (assert (= 52 (count #\? string :start #xa1))))))
 749 (delete-file *test-path*)
 750 \f
 751 ;;; latin-8 tests
 752 (with-test (:name (:unibyte-input-replacement :latin-8))
 753   (dotimes (i 256)
 754     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 755       (write-byte i s))
 756     (with-open-file (s *test-path* :external-format '(:latin-8 :replacement #\?))
 757       (let ((char (read-char s)))
 758         (assert (or (= (char-code char) i)
 759                     (and (<= #xa1 i #xfe)
 760                          (not (char= char #\?)))))))))
 761 (delete-file *test-path*)
 762
 763 (with-test (:name (:unibyte-output-replacement :latin-8))
 764   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-8 :replacement #\?))
 765     (dotimes (i 256)
 766       (write-char (code-char i) s)))
 767   (with-open-file (s *test-path* :external-format '(:latin-8))
 768     (let ((string (make-string 256)))
 769       (read-sequence string s)
 770       (dotimes (i #xa1)
 771         (assert (= (char-code (char string i)) i)))
 772       (assert (= 31 (count #\? string :start #xa1))))))
 773 (delete-file *test-path*)
 774 \f
 775 ;;; latin-9 tests
 776 (with-test (:name (:unibyte-input-replacement :latin-9))
 777   (dotimes (i 256)
 778     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 779       (write-byte i s))
 780     (with-open-file (s *test-path* :external-format '(:latin-9 :replacement #\?))
 781       (let ((char (read-char s)))
 782         (assert (or (and (= (char-code char) i)
 783                          (not (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))))
 784                     (and (member i '(#xa4 #xa6 #xa8 #xb4 #xb8 #xbc #xbd #xbe))
 785                          (not (char= char #\?)))))))))
 786 (delete-file *test-path*)
 787
 788 (with-test (:name (:unibyte-output-replacement :latin-9))
 789   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:latin-9 :replacement #\?))
 790     (dotimes (i 256)
 791       (write-char (code-char i) s)))
 792   (with-open-file (s *test-path* :external-format '(:latin-9))
 793     (let ((string (make-string 256)))
 794       (read-sequence string s)
 795       (dotimes (i #xa4)
 796         (assert (= (char-code (char string i)) i)))
 797       (assert (= 8 (count #\? string :start #xa4))))))
 798 (delete-file *test-path*)
 799 \f
 800 ;;; koi8-r tests
 801 (with-test (:name (:unibyte-input-replacement :koi8-r))
 802   (dotimes (i 256)
 803     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 804       (write-byte i s))
 805     (with-open-file (s *test-path* :external-format '(:koi8-r :replacement #\?))
 806       (let ((char (read-char s)))
 807         (cond ((= (char-code char) i)
 808                (assert (< i 128)))
 809               (t (assert (> i 127))))))))
 810 (delete-file *test-path*)
 811
 812 (with-test (:name (:unibyte-output-replacement :koi8-r))
 813   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-r :replacement #\?))
 814     (dotimes (i 256)
 815       (write-char (code-char i) s)))
 816   (with-open-file (s *test-path* :external-format '(:koi8-r))
 817     (let ((string (make-string 256)))
 818       (read-sequence string s)
 819       (dotimes (i #x80)
 820         (assert (= (char-code (char string i)) i)))
 821       (assert (= 122 (count #\? string :start #x80))))))
 822 (delete-file *test-path*)
 823 \f
 824 ;;; koi8-u tests
 825 (with-test (:name (:unibyte-input-replacement :koi8-u))
 826   (dotimes (i 256)
 827     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 828       (write-byte i s))
 829     (with-open-file (s *test-path* :external-format '(:koi8-u :replacement #\?))
 830       (let ((char (read-char s)))
 831         (cond ((= (char-code char) i)
 832                (assert (< i 128)))
 833               (t (assert (> i 127))))))))
 834 (delete-file *test-path*)
 835
 836 (with-test (:name (:unibyte-output-replacement :koi8-u))
 837   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:koi8-u :replacement #\?))
 838     (dotimes (i 256)
 839       (write-char (code-char i) s)))
 840   (with-open-file (s *test-path* :external-format '(:koi8-u))
 841     (let ((string (make-string 256)))
 842       (read-sequence string s)
 843       (dotimes (i #x80)
 844         (assert (= (char-code (char string i)) i)))
 845       (assert (= 122 (count #\? string :start #x80))))))
 846 (delete-file *test-path*)
 847 \f
 848 ;;; x-mac-cyrillic tests
 849 (with-test (:name (:unibyte-input-replacement :x-mac-cyrillic))
 850   (dotimes (i 256)
 851     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 852       (write-byte i s))
 853     (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic :replacement #\?))
 854       (let ((char (read-char s)))
 855         (cond ((= (char-code char) i)
 856                (assert (or (< i 128) (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))
 857               (t (assert (and (> i 127)
 858                               (not (member i '(#xa2 #xa3 #xa9 #xb1 #xb5)))))))))))
 859 (delete-file *test-path*)
 860
 861 (with-test (:name (:unibyte-output-replacement :x-mac-cyrillic))
 862   (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:x-mac-cyrillic :replacement #\?))
 863     (dotimes (i 256)
 864       (write-char (code-char i) s)))
 865   (with-open-file (s *test-path* :external-format '(:x-mac-cyrillic))
 866     (let ((string (make-string 256)))
 867       (read-sequence string s)
 868       (dotimes (i #x80)
 869         (assert (= (char-code (char string i)) i)))
 870       (assert (= 113 (count #\? string :start #x80))))))
 871 (delete-file *test-path*)
 872 \f
 873 ;;; ucs-2 tests
 874 (with-test (:name (:multibyte :ucs2le))
 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 0) (aref array i)) s)
 881         (write-byte (ldb (byte 8 8) (aref array i)) s)))
 882     (with-open-file (s *test-path* :external-format :ucs2le)
 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 :ucs2be))
 889   (let* ((size 120)
 890          (array (map-into (make-array size :element-type '(unsigned-byte 16))
 891                           (lambda () (random #x10000)))))
 892     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 893       (dotimes (i size)
 894         (write-byte (ldb (byte 8 8) (aref array i)) s)
 895         (write-byte (ldb (byte 8 0) (aref array i)) s)))
 896     (with-open-file (s *test-path* :external-format :ucs2be)
 897       (let ((string (make-string size)))
 898         (read-sequence string s)
 899         (dotimes (i size)
 900           (assert (= (char-code (char string i)) (aref array i))))))))
 901
 902 (with-test (:name (:multibyte :output-replacement :ucs2le))
 903   (let* ((size 1200)
 904          (string (map-into (make-string size)
 905                            (lambda () (code-char (random #x10000))))))
 906     (setf (char string 0) (code-char #x10001)
 907           (char string (1- size)) (code-char #x10002))
 908     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
 909       (write-string string s))
 910     (with-open-file (s *test-path* :external-format :ucs2le)
 911       (let ((new (make-string size)))
 912         (read-sequence new s)
 913         (assert (char= (char new 0) #\replacement_character))
 914         (assert (char= (char new (1- size)) #\replacement_character))
 915         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
 916
 917 (with-test (:name (:multibyte :output-replacement :ucs2be))
 918   (let* ((size 1200)
 919          (string (map-into (make-string size)
 920                            (lambda () (code-char (random #x10000))))))
 921     (setf (char string 0) (code-char #x10001)
 922           (char string (1- size)) (code-char #x10002))
 923     (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
 924       (write-string string s))
 925     (with-open-file (s *test-path* :external-format :ucs2be)
 926       (let ((new (make-string size)))
 927         (read-sequence new s)
 928         (assert (char= (char new 0) #\replacement_character))
 929         (assert (char= (char new (1- size)) #\replacement_character))
 930         (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
 931
 932 (with-test (:name (:multibyte :input-replacement :ucs4le))
 933   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
 934     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 935       (write-sequence octets s))
 936     (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
 937       (let ((string (read-line s)))
 938         (assert (char= (char string 0) (code-char #x10100)))
 939         (assert (char= (char string 1) #\replacement_character))))))
 940
 941 (with-test (:name (:multibyte :input-replacement :ucs4le))
 942   (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
 943     (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
 944       (write-sequence octets s))
 945     (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
 946       (let ((string (read-line s)))
 947         (assert (char= (char string 0) (code-char #x10100)))
 948         (assert (char= (char string 1) #\replacement_character))))))
 949 \f
 950 ;;; utf tests
 951 (with-test (:name (:utf-16le :roundtrip))
 952   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 953     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 954                        :external-format :utf-16le)
 955       (write-string string s))
 956     (with-open-file (s *test-path* :external-format :utf-16le)
 957       (assert (string= string (read-line s))))))
 958 (with-test (:name (:utf-16be :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-16be)
 962       (write-string string s))
 963     (with-open-file (s *test-path* :external-format :utf-16be)
 964       (assert (string= string (read-line s))))))
 965 (with-test (:name (:utf-16le :encoding-error))
 966   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 967     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 968                        :external-format '(:utf-16le :replacement #\?))
 969       (write-string string s))
 970     (with-open-file (s *test-path* :external-format :utf-16le)
 971       (assert (string= " ???? " (read-line s))))))
 972 (with-test (:name (:utf-16be :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-16be :replacement #\?))
 976       (write-string string s))
 977     (with-open-file (s *test-path* :external-format :utf-16be)
 978       (assert (string= " ???? " (read-line s))))))
 979
 980 (with-test (:name (:utf-32le :roundtrip))
 981   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 982     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 983                        :external-format :utf-32le)
 984       (write-string string s))
 985     (with-open-file (s *test-path* :external-format :utf-32le)
 986       (assert (string= string (read-line s))))))
 987 (with-test (:name (:utf-32be :roundtrip))
 988   (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
 989     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 990                        :external-format :utf-32be)
 991       (write-string string s))
 992     (with-open-file (s *test-path* :external-format :utf-32be)
 993       (assert (string= string (read-line s))))))
 994 (with-test (:name (:utf-32le :encoding-error))
 995   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
 996     (with-open-file (s *test-path* :direction :output :if-exists :supersede
 997                        :external-format '(:utf-32le :replacement #\?))
 998       (write-string string s))
 999     (with-open-file (s *test-path* :external-format :utf-32le)
1000       (assert (string= " ???? " (read-line s))))))
1001 (with-test (:name (:utf-32be :encoding-error))
1002   (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
1003     (with-open-file (s *test-path* :direction :output :if-exists :supersede
1004                        :external-format '(:utf-32be :replacement #\?))
1005       (write-string string s))
1006     (with-open-file (s *test-path* :external-format :utf-32be)
1007       (assert (string= " ???? " (read-line s))))))
1008
1009 (with-test (:name :invalid-external-format :fails-on :win32)
1010   (labels ((test-error (e)
1011              (assert (typep e 'error))
1012              (unless (equal "Undefined external-format: :BAD-FORMAT"
1013                             (princ-to-string e))
1014                (error "Bad error:~%  ~A" e)))
1015            (test (direction)
1016              (test-error
1017               (handler-case
1018                   (open "/dev/null" :direction direction :external-format :bad-format
1019                         :if-exists :overwrite)
1020                 (error (e) e)))))
1021     (test :input)
1022     (test :output)
1023     (test :io)
1024     (test-error
1025      (handler-case
1026          (run-program "sh" '() :input :stream :external-format :bad-format)
1027        (error (e) e)))
1028     (test-error
1029      (handler-case
1030          (string-to-octets "foobar" :external-format :bad-format)
1031        (error (e) e)))
1032     (test-error
1033      (let ((octets (string-to-octets "foobar" :external-format :latin1)))
1034        (handler-case
1035            (octets-to-string octets :external-format :bad-format)
1036          (error (e) e))))))
1037
1038 (with-test (:name :lp713063)
1039   (with-open-file (f *test-path*
1040                      :direction :output
1041                      :external-format '(:euc-jp :replacement #\?)
1042                      :if-exists :supersede)
1043     (write-string (make-string 3 :initial-element #\horizontal_bar) f))
1044   (assert (equal "???"
1045                  (with-open-file (f *test-path*
1046                                     :direction :input
1047                                     :external-format :euc-jp)
1048                    (read-line f))))
1049   (delete-file *test-path*))
1050 \f
1051 ;;;; success