--- /dev/null
+;;;; tests of octet/character machinery with no side effects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(cl:in-package :cl-user)
+
+(locally
+ (declare (optimize debug (speed 0)))
+
+(labels ((ub8 (len-or-seq)
+ (if (numberp len-or-seq)
+ (make-array len-or-seq :element-type '(unsigned-byte 8) :initial-element 0)
+ (coerce len-or-seq '(simple-array (unsigned-byte 8) (*)))))
+
+ (ensure-roundtrip-ascii ()
+ (let ((octets (ub8 128)))
+ (dotimes (i 128)
+ (setf (aref octets i) i))
+ (let* ((str (octets-to-string octets :external-format :ascii))
+ (oct2 (string-to-octets str :external-format :ascii)))
+ (assert (= (length octets) (length oct2)))
+ (assert (every #'= octets oct2))))
+ t)
+
+ (ensure-roundtrip-latin (format)
+ (let ((octets (ub8 256)))
+ (dotimes (i 256)
+ (setf (aref octets i) i))
+ (let* ((str (octets-to-string octets :external-format format))
+ (oct2 (string-to-octets str :external-format format)))
+ (assert (= (length octets) (length oct2)))
+ (assert (every #'= octets oct2))))
+ t)
+
+ (ensure-roundtrip-latin1 ()
+ (ensure-roundtrip-latin :latin1))
+
+ #+sb-unicode
+ (ensure-roundtrip-latin9 ()
+ (ensure-roundtrip-latin :latin9))
+
+ (ensure-roundtrip-utf8 ()
+ (let ((string (make-string char-code-limit)))
+ (dotimes (i char-code-limit)
+ (setf (char string i) (code-char i)))
+ (let ((string2
+ (octets-to-string (string-to-octets string :external-format :utf8)
+ :external-format :utf8)))
+ (assert (= (length string2) (length string)))
+ (assert (string= string string2))))
+ t)
+
+ (utf8-decode-test (octets expected-results expected-errors)
+ (let ((error-count 0))
+ (handler-bind ((sb-int:character-decoding-error
+ (lambda (c)
+ (incf error-count)
+ (use-value "?" c))))
+ (assert (string= expected-results
+ (octets-to-string (ub8 octets)
+ :external-format :utf-8)))
+ (assert (= error-count expected-errors)))))
+
+ (utf8-decode-tests (octets expected-results)
+ (let ((expected-errors (count #\? expected-results)))
+ (utf8-decode-test octets expected-results expected-errors)
+ (utf8-decode-test (concatenate 'vector
+ '(34)
+ octets
+ '(34))
+ (format nil "\"~A\"" expected-results)
+ expected-errors))))
+
+ (ensure-roundtrip-ascii)
+ (ensure-roundtrip-latin1)
+ #+sb-unicode
+ (progn
+ (ensure-roundtrip-latin9)
+ ;; Latin-9 chars; the previous test checked roundtrip from
+ ;; octets->char and back, now test that the latin-9 characters did
+ ;; in fact appear during that trip.
+ (let ((l9c (map 'string #'code-char '(8364 352 353 381 382 338 339 376))))
+ (assert
+ (string= (octets-to-string (string-to-octets l9c :external-format :latin9)
+ :external-format :latin9)
+ l9c))))
+ (ensure-roundtrip-utf8)
+
+ (let ((non-ascii-bytes (make-array 128
+ :element-type '(unsigned-byte 8)
+ :initial-contents (loop for i from 128 below 256
+ collect i))))
+ (handler-bind ((sb-int:character-decoding-error
+ (lambda (c)
+ (use-value "??" c))))
+ (assert (string= (octets-to-string non-ascii-bytes :external-format :ascii)
+ (make-string 256 :initial-element #\?)))))
+ (let ((non-ascii-chars (make-array 128
+ :element-type 'character
+ :initial-contents (loop for i from 128 below 256
+ collect (code-char i)))))
+ (handler-bind ((sb-int:character-encoding-error
+ (lambda (c)
+ (use-value "??" c))))
+ (assert (equalp (string-to-octets non-ascii-chars :external-format :ascii)
+ (make-array 256 :initial-element (char-code #\?))))))
+
+ ;; From Markus Kuhn's UTF-8 test file:
+ ;; http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt
+
+ ;; Too-big characters
+ #-sb-unicode
+ (progn
+ (utf8-decode-tests #(#xc4 #x80) "?") ; #x100
+ (utf8-decode-tests #(#xdf #xbf) "?") ; #x7ff
+ (utf8-decode-tests #(#xe0 #xa0 #x80) "?") ; #x800
+ (utf8-decode-tests #(#xef #xbf #xbf) "?") ; #xffff
+ (utf8-decode-tests #(#xf0 #x90 #x80 #x80) "?")) ; #x10000
+ (utf8-decode-tests #(#xf4 #x90 #x80 #x80) "?") ; #x110000
+ (utf8-decode-tests #(#xf7 #xbf #xbf #xbf) "?") ; #x1fffff
+ (utf8-decode-tests #(#xf8 #x88 #x80 #x80 #x80) "?") ; #x200000
+ (utf8-decode-tests #(#xfb #xbf #xbf #xbf #xbf) "?") ; #x3ffffff
+ (utf8-decode-tests #(#xfc #x84 #x80 #x80 #x80 #x80) "?") ; #x4000000
+ (utf8-decode-tests #(#xfd #xbf #xbf #xbf #xbf #xbf) "?") ; #x7fffffff
+
+ ;; Unexpected continuation bytes
+ (utf8-decode-tests #(#x80) "?")
+ (utf8-decode-tests #(#xbf) "?")
+ (utf8-decode-tests #(#x80 #xbf) "??")
+ (utf8-decode-tests #(#x80 #xbf #x80) "???")
+ (utf8-decode-tests #(#x80 #xbf #x80 #xbf) "????")
+ (utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80) "?????")
+ (utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80 #xbf) "??????")
+ (utf8-decode-tests #(#x80 #xbf #x80 #xbf #x80 #xbf #x80) "???????")
+
+ ;; All 64 continuation bytes in a row
+ (apply #'utf8-decode-tests
+ (loop for i from #x80 to #xbf
+ collect i into bytes
+ collect #\? into chars
+ finally (return (list bytes
+ (coerce chars 'string)))))
+
+ ;; Lonely start characters
+ (flet ((lsc (first last)
+ (apply #'utf8-decode-tests
+ (loop for i from first to last
+ nconc (list i 32) into bytes
+ nconc (list #\? #\Space) into chars
+ finally (return (list bytes
+ (coerce chars 'string)))))
+ (apply #'utf8-decode-tests
+ (loop for i from first to last
+ collect i into bytes
+ collect #\? into chars
+ finally (return (list bytes
+ (coerce chars 'string)))))))
+ (lsc #xc0 #xdf) ; 2-byte sequence start chars
+ (lsc #xe0 #xef) ; 3-byte
+ (lsc #xf0 #xf7) ; 4-byte
+ (lsc #xf8 #xfb) ; 5-byte
+ (lsc #xfc #xfd)) ; 6-byte
+
+ ;; Otherwise incomplete sequences (last continuation byte missing)
+ (utf8-decode-tests #0=#(#xc0) "?")
+ (utf8-decode-tests #1=#(#xe0 #x80) "?")
+ (utf8-decode-tests #2=#(#xf0 #x80 #x80) "?")
+ (utf8-decode-tests #3=#(#xf8 #x80 #x80 #x80) "?")
+ (utf8-decode-tests #4=#(#xfc #x80 #x80 #x80 #x80) "?")
+ (utf8-decode-tests #5=#(#xdf) "?")
+ (utf8-decode-tests #6=#(#xef #xbf) "?")
+ (utf8-decode-tests #7=#(#xf7 #xbf #xbf) "?")
+ (utf8-decode-tests #8=#(#xfb #xbf #xbf #xbf) "?")
+ (utf8-decode-tests #9=#(#xfd #xbf #xbf #xbf #xbf) "?")
+
+ ;; All ten previous tests concatenated
+ (utf8-decode-tests (concatenate 'vector #0# #1# #2# #3# #4# #5# #6# #7# #8# #9#)
+ "??????????")
+
+ ;; Random impossible bytes
+ (utf8-decode-tests #(#xfe) "?")
+ (utf8-decode-tests #(#xff) "?")
+ (utf8-decode-tests #(#xfe #xfe #xff #xff) "????")
+
+ ;; Overlong sequences - /
+ (utf8-decode-tests #(#xc0 #xaf) "?")
+ (utf8-decode-tests #(#xe0 #x80 #xaf) "?")
+ (utf8-decode-tests #(#xf0 #x80 #x80 #xaf) "?")
+ (utf8-decode-tests #(#xf8 #x80 #x80 #x80 #xaf) "?")
+ (utf8-decode-tests #(#xfc #x80 #x80 #x80 #x80 #xaf) "?")
+
+ ;; Overlong sequences - #\Rubout
+ (utf8-decode-tests #(#xc1 #xbf) "?")
+ (utf8-decode-tests #(#xe0 #x9f #xbf) "?")
+ (utf8-decode-tests #(#xf0 #x8f #xbf #xbf) "?")
+ (utf8-decode-tests #(#xf8 #x87 #xbf #xbf #xbf) "?")
+ (utf8-decode-tests #(#xfc #x83 #xbf #xbf #xbf #xbf) "?")
+
+ ;; Overlong sequences - #\Null
+ (utf8-decode-tests #(#xc0 #x80) "?")
+ (utf8-decode-tests #(#xe0 #x80 #x80) "?")
+ (utf8-decode-tests #(#xf0 #x80 #x80 #x80) "?")
+ (utf8-decode-tests #(#xf8 #x80 #x80 #x80 #x80) "?")
+ (utf8-decode-tests #(#xfc #x80 #x80 #x80 #x80 #x80) "?")
+
+ ;; Not testing surrogates & characters #xFFFE, #xFFFF; they're
+ ;; perfectly good sbcl chars even if they're not actually ISO 10646
+ ;; characters, and it's probably a good idea for s-to-o and o-to-s
+ ;; to be inverses of each other as far as possible.
+ )
+
+)
projects / sbcl.git / blobdiff