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: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          (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
 995 (with-test (:name :invalid-external-format :fails-on :win32)
 996   (labels ((test-error (e)
 997              (assert (typep e 'error))
 998              (unless (equal "Undefined external-format: :BAD-FORMAT"
 999                             (princ-to-string e))
1000                (error "Bad error:~%  ~A" e)))
1001            (test (direction)
1002              (test-error
1003               (handler-case
1004                   (open "/dev/null" :direction direction :external-format :bad-format
1005                         :if-exists :overwrite)
1006                 (error (e) e)))))
1007     (test :input)
1008     (test :output)
1009     (test :io)
1010     (test-error
1011      (handler-case
1012          (run-program "sh" '() :input :stream :external-format :bad-format)
1013        (error (e) e)))
1014     (test-error
1015      (handler-case
1016          (string-to-octets "foobar" :external-format :bad-format)
1017        (error (e) e)))
1018     (test-error
1019      (let ((octets (string-to-octets "foobar" :external-format :latin1)))
1020        (handler-case
1021            (octets-to-string octets :external-format :bad-format)
1022          (error (e) e))))))
1023
1024 (with-test (:name :lp713063)
1025   (with-open-file (f *test-path*
1026                      :direction :output
1027                      :external-format '(:euc-jp :replacement #\?)
1028                      :if-exists :supersede)
1029     (write-string (make-string 3 :initial-element #\horizontal_bar) f))
1030   (assert (equal "???"
1031                  (with-open-file (f *test-path*
1032                                     :direction :input
1033                                     :external-format :euc-jp)
1034                    (read-line f))))
1035   (delete-file *test-path*))
1036 \f
1037 ;;;; success