;;;; 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.
  )

)
