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     `(dolist (,nxf sb-impl::*external-formats* ,result)
  21        (let ((,xf (first (first ,nxf))))
  22          ,@body))))
  23
  24 (do-external-formats (xf)
  25   (with-open-file (s #-win32 "/dev/null" #+win32 "nul" :direction :input :external-format xf)
  26     (assert (eq (read-char s nil s) s))))
  27
  28 ;;; Test standard character read-write equivalency over all external formats.
  29 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
  30   (do-external-formats (xf)
  31     (with-open-file (s "external-format-test.txt" :direction :output
  32                      :if-exists :supersede :external-format xf)
  33       (loop for character across standard-characters
  34             do (write-char character s)))
  35     (with-open-file (s "external-format-test.txt" :direction :input
  36                      :external-format xf)
  37       (loop for character across standard-characters
  38             do (let ((got (read-char s)))
  39                  (unless (eql character got)
  40                    (error "wanted ~S, got ~S" character got)))))))
  41
  42 (delete-file "external-format-test.txt")
  43 #-sb-unicode
  44 (progn
  45   (test-util:report-test-status)
  46   (sb-ext:quit :unix-status 104))
  47
  48 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
  49 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
  50 ;;; 4096 wide.
  51 (dotimes (width-1 4)
  52   (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
  53     (dotimes (offset (+ width-1 1))
  54       (with-open-file (s "external-format-test.txt" :direction :output
  55                        :if-exists :supersede :external-format :utf-8)
  56         (dotimes (n offset)
  57           (write-char #\a s))
  58         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
  59           (write-char character s)))
  60       (with-open-file (s "external-format-test.txt" :direction :input
  61                        :external-format :utf-8)
  62         (dotimes (n offset)
  63           (assert (eql (read-char s) #\a)))
  64         (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+))
  65           (let ((got (read-char s)))
  66             (unless (eql got character)
  67               (error "wanted ~S, got ~S (~S)" character got n))))
  68         (assert (eql (read-char s nil s) s))))))
  69
  70 ;;; Test character decode restarts.
  71 (with-open-file (s "external-format-test.txt" :direction :output
  72                  :if-exists :supersede :element-type '(unsigned-byte 8))
  73   (write-byte 65 s)
  74   (write-byte 66 s)
  75   (write-byte #xe0 s)
  76   (write-byte 67 s))
  77 (with-open-file (s "external-format-test.txt" :direction :input
  78                  :external-format :utf-8)
  79   (handler-bind
  80       ((sb-int:character-decoding-error #'(lambda (decoding-error)
  81                                             (declare (ignore decoding-error))
  82                                             (invoke-restart
  83                                              'sb-int:attempt-resync))))
  84     (assert (equal (read-line s nil s) "ABC"))
  85     (assert (equal (read-line s nil s) s))))
  86 (with-open-file (s "external-format-test.txt" :direction :input
  87                  :external-format :utf-8)
  88   (handler-bind
  89       ((sb-int:character-decoding-error #'(lambda (decoding-error)
  90                                             (declare (ignore decoding-error))
  91                                             (invoke-restart
  92                                              'sb-int:force-end-of-file))))
  93     (assert (equal (read-line s nil s) "AB"))
  94     (assert (equal (read-line s nil s) s))))
  95
  96 ;;; And again with more data to account for buffering (this was briefly)
  97 ;;; broken in early 0.9.6.
  98 (with-open-file (s "external-format-test.txt" :direction :output
  99                  :if-exists :supersede :element-type '(unsigned-byte 8))
 100   (let ((a (make-array 50
 101                        :element-type '(unsigned-byte 64)
 102                        :initial-contents (map 'list #'char-code
 103                                               "1234567890123456789012345678901234567890123456789."))))
 104     (setf (aref a 49) (char-code #\Newline))
 105     (dotimes (i 40)
 106       (write-sequence a s))
 107     (write-byte #xe0 s)
 108     (dotimes (i 40)
 109       (write-sequence a s))))
 110 (with-test (:name (:character-decode-large :attempt-resync))
 111   (with-open-file (s "external-format-test.txt" :direction :input
 112                      :external-format :utf-8)
 113     (handler-bind
 114         ((sb-int:character-decoding-error #'(lambda (decoding-error)
 115                                               (declare (ignore decoding-error))
 116                                               (invoke-restart
 117                                                'sb-int:attempt-resync)))
 118          ;; The failure mode is an infinite loop, add a timeout to detetct it.
 119          (sb-ext:timeout (lambda () (error "Timeout"))))
 120       (sb-ext:with-timeout 5
 121         (dotimes (i 80)
 122           (assert (equal (read-line s nil s)
 123                          "1234567890123456789012345678901234567890123456789")))))))
 124
 125 (with-test (:name (:character-decode-large :force-end-of-file)
 126             :fails-on :sbcl)
 127   (error "We can't reliably test this due to WITH-TIMEOUT race condition")
 128   ;; This test will currently fail. But sometimes it will fail in
 129   ;; ungracefully due to the WITH-TIMEOUT race mentioned above. This
 130   ;; rightfully confuses some people, so we'll skip running the code
 131   ;; for now. -- JES, 2006-01-27
 132   #+nil
 133   (with-open-file (s "external-format-test.txt" :direction :input
 134                      :external-format :utf-8)
 135     (handler-bind
 136         ((sb-int:character-decoding-error #'(lambda (decoding-error)
 137                                               (declare (ignore decoding-error))
 138                                               (invoke-restart
 139                                                'sb-int:force-end-of-file)))
 140          ;; The failure mode is an infinite loop, add a timeout to detetct it.
 141          (sb-ext:timeout (lambda () (error "Timeout"))))
 142       (sb-ext:with-timeout 5
 143         (dotimes (i 80)
 144           (assert (equal (read-line s nil s)
 145                          "1234567890123456789012345678901234567890123456789")))
 146         (assert (equal (read-line s nil s) s))))))
 147
 148 ;;; Test character encode restarts.
 149 (with-open-file (s "external-format-test.txt" :direction :output
 150                  :if-exists :supersede :external-format :latin-1)
 151   (handler-bind
 152       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 153                                             (declare (ignore encoding-error))
 154                                             (invoke-restart
 155                                              'sb-impl::output-nothing))))
 156     (write-char #\A s)
 157     (write-char #\B s)
 158     (write-char (code-char 322) s)
 159     (write-char #\C s)))
 160 (with-open-file (s "external-format-test.txt" :direction :input
 161                  :external-format :latin-1)
 162   (assert (equal (read-line s nil s) "ABC"))
 163   (assert (equal (read-line s nil s) s)))
 164
 165 (with-open-file (s "external-format-test.txt" :direction :output
 166                  :if-exists :supersede :external-format :latin-1)
 167   (handler-bind
 168       ((sb-int:character-encoding-error #'(lambda (encoding-error)
 169                                             (declare (ignore encoding-error))
 170                                             (invoke-restart
 171                                              'sb-impl::output-nothing))))
 172     (let ((string (make-array 4 :element-type 'character
 173                               :initial-contents `(#\A #\B ,(code-char 322)
 174                                                       #\C))))
 175       (write-string string s))))
 176 (with-open-file (s "external-format-test.txt" :direction :input
 177                  :external-format :latin-1)
 178   (assert (equal (read-line s nil s) "ABC"))
 179   (assert (equal (read-line s nil s) s)))
 180
 181 ;;; Test skipping character-decode-errors in comments.
 182 (let ((s (open "external-format-test.lisp" :direction :output
 183                :if-exists :supersede :external-format :latin-1)))
 184   (unwind-protect
 185        (progn
 186          (write-string ";;; ABCD" s)
 187          (write-char (code-char 233) s)
 188          (terpri s)
 189          (close s)
 190          (compile-file "external-format-test.lisp" :external-format :utf-8))
 191     (delete-file s)
 192     (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
 193       (when p
 194         (delete-file p)))))
 195
 196 \f
 197 ;;;; KOI8-R external format
 198 (with-open-file (s "external-format-test.txt" :direction :output
 199                  :if-exists :supersede :external-format :koi8-r)
 200   (write-char (code-char #xB0) s)
 201   (assert (eq
 202            (handler-case
 203                (progn
 204                  (write-char (code-char #xBAAD) s)
 205                  :bad)
 206              (sb-int:character-encoding-error ()
 207                :good))
 208            :good)))
 209 (with-open-file (s "external-format-test.txt" :direction :input
 210                  :element-type '(unsigned-byte 8))
 211   (let ((byte (read-byte s)))
 212     (assert (= (eval byte) #x9C))))
 213 (with-open-file (s "external-format-test.txt" :direction :input
 214                  :external-format :koi8-r)
 215   (let ((char (read-char s)))
 216     (assert (= (char-code (eval char)) #xB0))))
 217 (delete-file "external-format-test.txt")
 218
 219 (let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8))))
 220        (uni-codes #(1055 1088 1080 1074 1077 1090 33))
 221
 222        (string (octets-to-string koi8-r-codes :external-format :koi8-r))
 223        (uni-decoded (map 'vector #'char-code string)))
 224   (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r))
 225                   uni-codes))
 226   (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r)
 227                   koi8-r-codes)))
 228 \f
 229 ;;; tests of FILE-STRING-LENGTH
 230 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
 231   (do-external-formats (xf)
 232     (with-open-file (s "external-format-test.txt" :direction :output
 233                        :external-format xf)
 234       (loop for x across standard-characters
 235             for position = (file-position s)
 236             for char-length = (file-string-length s x)
 237             do (write-char x s)
 238             do (assert (= (file-position s) (+ position char-length))))
 239       (let ((position (file-position s))
 240             (string-length (file-string-length s standard-characters)))
 241         (write-string standard-characters s)
 242         (assert (= (file-position s) (+ position string-length)))))
 243     (delete-file "external-format-test.txt")))
 244
 245 (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096
 246                     8191 8192 16383 16384 32767 32768 65535 65536 131071
 247                     131072 262143 262144)))
 248   (with-open-file (s "external-format-test.txt" :direction :output
 249                      :external-format :utf-8)
 250     (dolist (code char-codes)
 251       (let* ((char (code-char code))
 252              (position (file-position s))
 253              (char-length (file-string-length s char)))
 254         (write-char char s)
 255         (assert (= (file-position s) (+ position char-length)))))
 256     (let* ((string (map 'string #'code-char char-codes))
 257            (position (file-position s))
 258            (string-length (file-string-length s string)))
 259       (write-string string s)
 260       (assert (= (file-position s) (+ position string-length))))))
 261 \f
 262
 263 ;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files"
 264 ;;; by Lutz Euler on 2006-03-05 for more details.
 265 (with-test (:name (:file-position :utf-8))
 266   (let ((path "external-format-test.txt"))
 267     (with-open-file (s path
 268                        :direction :output
 269                        :if-exists :supersede
 270                        :element-type '(unsigned-byte 8))
 271       ;; Write #\*, encoded in UTF-8, to the file.
 272       (write-byte 42 s)
 273       ;; Append #\adiaeresis, encoded in UTF-8, to the file.
 274       (write-sequence '(195 164) s))
 275     (with-open-file (s path :external-format :utf-8)
 276       (read-char s)
 277       (let ((pos (file-position s))
 278             (char (read-char s)))
 279         (format t "read character with code ~a successfully from file position ~a~%"
 280                 (char-code char) pos)
 281         (file-position s pos)
 282         (format t "set file position back to ~a, trying to read-char again~%" pos)
 283         (let ((new-char (read-char s)))
 284           (assert (char= char new-char)))))
 285     (values)))
 286
 287 ;;; External format support in SB-ALIEN
 288
 289 (with-test (:name (:sb-alien :vanilla))
 290   (define-alien-routine strdup c-string (str c-string))
 291   (assert (equal "foo" (strdup "foo"))))
 292
 293 (with-test (:name (:sb-alien :utf-8 :utf-8))
 294   (define-alien-routine strdup (c-string :external-format :utf-8)
 295     (str (c-string :external-format :utf-8)))
 296   (assert (equal "foo" (strdup "foo"))))
 297
 298 (with-test (:name (:sb-alien :latin-1 :utf-8))
 299   (define-alien-routine strdup (c-string :external-format :latin-1)
 300     (str (c-string :external-format :utf-8)))
 301   (assert (= (length (strdup (string (code-char 246))))
 302              2)))
 303
 304 (with-test (:name (:sb-alien :utf-8 :latin-1))
 305   (define-alien-routine strdup (c-string :external-format :utf-8)
 306     (str (c-string :external-format :latin-1)))
 307   (assert (equal (string (code-char 228))
 308                  (strdup (concatenate 'string
 309                                       (list (code-char 195))
 310                                       (list (code-char 164)))))))
 311
 312 (with-test (:name (:sb-alien :ebcdic :ebcdic))
 313   (define-alien-routine strdup (c-string :external-format :ebcdic-us)
 314     (str (c-string :external-format :ebcdic-us)))
 315   (assert (equal "foo" (strdup "foo"))))
 316
 317 (with-test (:name (:sb-alien :latin-1 :ebcdic))
 318   (define-alien-routine strdup (c-string :external-format :latin-1)
 319     (str (c-string :external-format :ebcdic-us)))
 320   (assert (not (equal "foo" (strdup "foo")))))
 321
 322 (with-test (:name (:sb-alien :simple-base-string))
 323   (define-alien-routine strdup (c-string :external-format :ebcdic-us
 324                                          :element-type base-char)
 325     (str (c-string :external-format :ebcdic-us)))
 326   (assert (typep (strdup "foo") 'simple-base-string)))
 327
 328 ;;;; success