mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
517 lines
31 KiB
Common Lisp
517 lines
31 KiB
Common Lisp
;;;; This file is for testing external-format functionality for UTF-8,
|
|
;;;; using test machinery which does not have side effects. Note that
|
|
;;;; the tests here reach into unexported functionality, and should
|
|
;;;; not be used as a guide for users.
|
|
|
|
;;;; 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.
|
|
|
|
(defvar *test-path* (scratch-file-name))
|
|
|
|
(macrolet ((input-test (inxf expected &environment env)
|
|
`(progn
|
|
(with-test (:name (,(macroexpand 'name env) :file ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(let* ((string (make-string 20))
|
|
(count (read-sequence string s)))
|
|
(assert (equal (map 'list 'identity (subseq string 0 count)) ,expected)))))
|
|
(with-test (:name (,(macroexpand 'name env) :octets ,inxf))
|
|
(let ((octets (coerce bytes '(simple-array (unsigned-byte 8) 1))))
|
|
(assert (equal (sb-ext:octets-to-string octets :external-format ',inxf)
|
|
(coerce ,expected 'string)))))))
|
|
(with-input-bytes ((id bytes) &body body)
|
|
`(let ((bytes ,bytes))
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8)
|
|
:direction :output :if-exists :supersede)
|
|
(dolist (byte bytes)
|
|
(write-byte byte s)))
|
|
(symbol-macrolet ((name ,id))
|
|
(macrolet ((test (inxf expected)
|
|
`(input-test ,inxf ,expected)))
|
|
,@body))))
|
|
(output-test (chars outxf expected &environment env)
|
|
`(progn
|
|
(with-open-file (s *test-path* :element-type 'character
|
|
:external-format ',outxf
|
|
:direction :output :if-exists :supersede)
|
|
(write-sequence ,chars s))
|
|
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
|
(let* ((vector (make-array 20 :element-type '(unsigned-byte 8)))
|
|
(count (read-sequence vector s)))
|
|
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
|
(with-test (:name (,(macroexpand 'name env) :octets string ,outxf))
|
|
(let* ((string (coerce chars 'string))
|
|
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
|
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
|
(assert (equal (coerce octets 'list) ,expected))))
|
|
(when (every (lambda (x) (typep x 'base-char)) chars)
|
|
(with-test (:name (,(macroexpand 'name env) :octets base-string ,outxf))
|
|
(let* ((string (coerce chars 'base-string))
|
|
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
|
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
|
(assert (equal (coerce octets 'list) ,expected)))))))
|
|
(with-output-characters ((id chars) &body body)
|
|
`(let ((chars ,chars))
|
|
(symbol-macrolet ((name ,id))
|
|
(macrolet ((test (outxf expected)
|
|
`(output-test chars ,outxf ,expected)))
|
|
,@body)))))
|
|
(with-input-bytes ((:input :lf :ascii) '(#x35 #x0a #x37))
|
|
(test :utf-8 '(#\5 #\Newline #\7))
|
|
(test (:utf-8 :newline :lf) '(#\5 #\Newline #\7))
|
|
(test (:utf-8 :newline :cr) '(#\5 #\Newline #\7))
|
|
(test (:utf-8 :newline :crlf) '(#\5 #\Newline #\7)))
|
|
(with-output-characters ((:output :lf :ascii) '(#\5 #\Linefeed #\7))
|
|
(test :utf-8 '(#x35 #x0a #x37))
|
|
(test (:utf-8 :newline :lf) '(#x35 #x0a #x37))
|
|
(test (:utf-8 :newline :cr) '(#x35 #x0d #x37))
|
|
(test (:utf-8 :newline :crlf) '(#x35 #x0d #x0a #x37)))
|
|
(with-input-bytes ((:input :cr :ascii) '(#x35 #x0d #x37))
|
|
(test :utf-8 '(#\5 #\Return #\7))
|
|
(test (:utf-8 :newline :lf) '(#\5 #\Return #\7))
|
|
(test (:utf-8 :newline :cr) '(#\5 #\Newline #\7))
|
|
(test (:utf-8 :newline :crlf) '(#\5 #\Return #\7)))
|
|
(with-output-characters ((:output :cr :ascii) '(#\5 #\Return #\7))
|
|
(test :utf-8 '(#x35 #x0d #x37))
|
|
(test (:utf-8 :newline :lf) '(#x35 #x0d #x37))
|
|
(test (:utf-8 :newline :cr) '(#x35 #x0d #x37))
|
|
(test (:utf-8 :newline :crlf) '(#x35 #x0d #x37)))
|
|
(with-input-bytes ((:input :crlf :ascii) '(#x35 #x0d #x0a #x37))
|
|
(test :utf-8 '(#\5 #\Return #\Newline #\7))
|
|
(test (:utf-8 :newline :lf) '(#\5 #\Return #\Newline #\7))
|
|
(test (:utf-8 :newline :cr) '(#\5 #\Newline #\Newline #\7))
|
|
(test (:utf-8 :newline :crlf) '(#\5 #\Newline #\7)))
|
|
(with-output-characters ((:output :crlf :ascii) '(#\5 #\Return #\Linefeed #\7))
|
|
(test :utf-8 '(#x35 #x0d #x0a #x37))
|
|
(test (:utf-8 :newline :lf) '(#x35 #x0d #x0a #x37))
|
|
(test (:utf-8 :newline :cr) '(#x35 #x0d #x0d #x37))
|
|
(test (:utf-8 :newline :crlf) '(#x35 #x0d #x0d #x0a #x37)))
|
|
(with-input-bytes ((:input :lf) '(#xc3 #xa9 #x0a #xc3 #xa8))
|
|
(test :utf-8 '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE)))
|
|
(with-output-characters ((:output :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test :utf-8 '(#xc3 #xa9 #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :lf) '(#xc3 #xa9 #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :cr) '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :crlf) '(#xc3 #xa9 #x0d #x0a #xc3 #xa8)))
|
|
(with-input-bytes ((:input :cr) '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test :utf-8 '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\LATIN_SMALL_LETTER_E_WITH_GRAVE)))
|
|
(with-output-characters ((:output :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test :utf-8 '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :lf) '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :cr) '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :crlf) '(#xc3 #xa9 #x0d #xc3 #xa8)))
|
|
(with-input-bytes ((:input :crlf) '(#xc3 #xa9 #x0d #x0a #xc3 #xa8))
|
|
(test :utf-8 '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Newline #\LATIN_SMALL_LETTER_E_WITH_GRAVE)))
|
|
(with-output-characters ((:output :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test :utf-8 '(#xc3 #xa9 #x0d #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :lf) '(#xc3 #xa9 #x0d #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :cr) '(#xc3 #xa9 #x0d #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :crlf) '(#xc3 #xa9 #x0d #x0d #x0a #xc3 #xa8))))
|
|
|
|
(macrolet ((input-test (inxf expected &environment env)
|
|
`(progn
|
|
(with-test (:name (,(macroexpand 'name env) :file ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(handler-bind ((sb-int:character-decoding-error
|
|
(lambda (c) (use-value "" c))))
|
|
(let* ((string (make-string 20))
|
|
(count (read-sequence string s)))
|
|
(assert (equal (map 'list 'identity (subseq string 0 count)) ,expected))))))
|
|
(with-test (:name (,(macroexpand 'name env) :octets ,inxf))
|
|
(handler-bind ((sb-int:character-decoding-error
|
|
(lambda (c) (use-value "" c))))
|
|
(let ((octets (coerce bytes '(simple-array (unsigned-byte 8) 1))))
|
|
(assert (equal (sb-ext:octets-to-string octets :external-format ',inxf)
|
|
(coerce ,expected 'string))))))))
|
|
(with-input-bytes ((id bytes) &body body)
|
|
`(let ((bytes ,bytes))
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8)
|
|
:direction :output :if-exists :supersede)
|
|
(dolist (byte bytes)
|
|
(write-byte byte s)))
|
|
(symbol-macrolet ((name ,id))
|
|
(macrolet ((test (inxf expected)
|
|
`(input-test ,inxf ,expected)))
|
|
,@body))))
|
|
(output-test (chars outxf expected &environment env)
|
|
`(progn
|
|
(with-open-file (s *test-path* :element-type 'character
|
|
:external-format ',outxf
|
|
:direction :output :if-exists :supersede)
|
|
(handler-bind ((sb-int:character-encoding-error
|
|
(lambda (c) (use-value "" c))))
|
|
(write-sequence ,chars s)))
|
|
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
|
(let* ((vector (make-array 20 :element-type '(unsigned-byte 8)))
|
|
(count (read-sequence vector s)))
|
|
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
|
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
|
(handler-bind ((sb-int:character-encoding-error
|
|
(lambda (c) (use-value "" c))))
|
|
(let* ((string (coerce chars 'string))
|
|
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
|
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
|
(assert (equal (coerce octets 'list) ,expected)))))))
|
|
(with-output-characters ((id chars) &body body)
|
|
`(let ((chars ,chars))
|
|
(symbol-macrolet ((name ,id))
|
|
(macrolet ((test (outxf expected)
|
|
`(output-test chars ,outxf ,expected)))
|
|
,@body)))))
|
|
(with-input-bytes ((:input :invalid :crlf) (list #xc3 #xa9 #xff #x0d #x0a #xc3 #xa8))
|
|
(test :utf-8 '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Linefeed #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE)))
|
|
(with-input-bytes ((:input :multiple-invalid :crlf) (list #xc3 #xa9 #xff #x0d #x0a #xff #xff #xc3 #xa8))
|
|
(test :utf-8 '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Return #\Linefeed #\? #\? #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Return #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :lf :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Return #\Linefeed #\? #\? #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :cr :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Linefeed #\Linefeed #\? #\? #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test (:utf-8 :newline :crlf :replacement #\?) '(#\LATIN_SMALL_LETTER_E_WITH_ACUTE #\? #\Linefeed #\? #\? #\LATIN_SMALL_LETTER_E_WITH_GRAVE)))
|
|
#+sb-unicode
|
|
(with-output-characters ((:output :invalid :lf) (list #\LATIN_SMALL_LETTER_E_WITH_ACUTE (code-char #xd800) #\Linefeed #\LATIN_SMALL_LETTER_E_WITH_GRAVE))
|
|
(test :utf-8 '(#xc3 #xa9 #x0a #xc3 #xa8))
|
|
(test (:utf-8 :replacement #\?) '(#xc3 #xa9 #x3f #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :lf) '(#xc3 #xa9 #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :lf :replacement #\?) '(#xc3 #xa9 #x3f #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :cr) '(#xc3 #xa9 #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :cr :replacement #\?) '(#xc3 #xa9 #x3f #x0d #xc3 #xa8))
|
|
(test (:utf-8 :newline :crlf) '(#xc3 #xa9 #x0d #x0a #xc3 #xa8))
|
|
(test (:utf-8 :newline :crlf :replacement #\?) '(#xc3 #xa9 #x3f #x0d #x0a #xc3 #xa8))))
|
|
|
|
(macrolet ((test (inxf expected &environment env)
|
|
`(with-test (:name (,(macroexpand 'name env) ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(let* ((string (make-string 100000))
|
|
(count (read-sequence string s)))
|
|
(assert (equal (map 'list 'char-code (subseq string 0 count)) ,expected)))))
|
|
`(with-test (:name (,(macroexpand 'name env) ,inxf :base-string))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(let* ((string (make-string 100000 :element-type 'base-char))
|
|
(count (read-sequence string s)))
|
|
(assert (equal (map 'list 'char-code (subseq string 0 count)) ,expected))))))
|
|
(with-test-file ((id bytes) &body body)
|
|
`(progn
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8)
|
|
:direction :output :if-exists :supersede)
|
|
(dolist (byte ,bytes)
|
|
(write-byte byte s)))
|
|
(symbol-macrolet ((name ,id))
|
|
,@body)))
|
|
(tests (size)
|
|
`(progn
|
|
(with-test-file ((:input :lf ,size) (contents ,size '(10)))
|
|
(test :utf-8 (contents ,size '(10)))
|
|
(test (:utf-8 :newline :lf) (contents ,size '(10)))
|
|
(test (:utf-8 :newline :cr) (contents ,size '(10)))
|
|
(test (:utf-8 :newline :crlf) (contents ,size '(10))))
|
|
(with-test-file ((:input :cr ,size) (contents ,size '(13)))
|
|
(test :utf-8 (contents ,size '(13)))
|
|
(test (:utf-8 :newline :lf) (contents ,size '(13)))
|
|
(test (:utf-8 :newline :cr) (contents ,size '(10)))
|
|
(test (:utf-8 :newline :crlf) (contents ,size '(13))))
|
|
(with-test-file ((:input :crlf ,size) (contents ,size '(13 10)))
|
|
(test :utf-8 (contents ,size '(13 10)))
|
|
(test (:utf-8 :newline :lf) (contents ,size '(13 10)))
|
|
(test (:utf-8 :newline :cr) (contents ,size '(10 10)))
|
|
(test (:utf-8 :newline :crlf) (contents ,(1- size) '(10)))))))
|
|
(flet ((contents (size nl)
|
|
(let ((bytes (make-array size :initial-element #x61)))
|
|
(loop for x in nl
|
|
for j from (- (length bytes) (length nl))
|
|
do (setf (aref bytes j) x))
|
|
(coerce bytes 'list))))
|
|
(tests 2)
|
|
|
|
(with-test (:name :ansi-stream-cin-buffer-length)
|
|
(assert (= sb-impl::+ansi-stream-in-buffer-length+ 512)))
|
|
|
|
(tests 511)
|
|
(tests 512)
|
|
(tests 513)
|
|
|
|
;; +ANSI-STREAM-IN-BUFFER-EXTRA+ is possibly also relevant. Can't
|
|
;; test for it as the constant gets shaken out, but it's currently
|
|
;; 4.
|
|
(tests 515)
|
|
(tests 516)
|
|
(tests 517)
|
|
|
|
(tests #.(- sb-impl::+bytes-per-buffer+ 2))
|
|
(tests #.(- sb-impl::+bytes-per-buffer+ 1))
|
|
(tests #.sb-impl::+bytes-per-buffer+)
|
|
(tests #.(+ sb-impl::+bytes-per-buffer+ 1))
|
|
(tests #.(+ sb-impl::+bytes-per-buffer+ 3))))
|
|
|
|
(macrolet ((test (inxf expected &optional (unread-expected expected) &environment env)
|
|
`(progn
|
|
(with-test (:name (,(macroexpand 'name env) ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(let ((actual
|
|
(cons (file-position s)
|
|
(loop for char = (read-char s nil nil)
|
|
while char
|
|
collect (file-position s)))))
|
|
(assert (equal actual ,expected)))))
|
|
(with-test (:name (,(macroexpand 'name env) unread-char ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf)
|
|
(assert (sb-impl::ansi-stream-cin-buffer s))
|
|
(let ((actual (loop for char = (read-char s nil nil)
|
|
if (null char) collect (file-position s) and do (loop-finish)
|
|
do (unread-char char s)
|
|
collect (file-position s)
|
|
do (read-char s))))
|
|
(assert (equal actual ,unread-expected)))))
|
|
(with-test (:name (,(macroexpand 'name env) unread-char :io ,inxf))
|
|
(with-open-file (s *test-path* :external-format ',inxf
|
|
:direction :io :if-exists :overwrite)
|
|
;; if we reinstate in character buffers for :io character streams,
|
|
;; make a stream that is unbuffered some other way
|
|
(assert (not (sb-impl::ansi-stream-cin-buffer s)))
|
|
(let ((actual (loop for char = (read-char s nil nil)
|
|
if (null char) collect (file-position s) and do (loop-finish)
|
|
do (unread-char char s)
|
|
collect (file-position s)
|
|
do (read-char s))))
|
|
(assert (equal actual ,unread-expected)))))))
|
|
(with-test-file ((id bytes) &body body)
|
|
`(progn
|
|
(with-open-file (s *test-path* :element-type '(unsigned-byte 8)
|
|
:direction :output :if-exists :supersede)
|
|
(dolist (byte ,bytes)
|
|
(write-byte byte s)))
|
|
(symbol-macrolet ((name ,id))
|
|
,@body))))
|
|
(with-test-file ((file-position :lf) '(#xc3 #xa9 #x0a #xc3 #xa8 #x38 #x0a #x39 #x3a #x0a #x3b))
|
|
(test :utf-8 '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :lf) '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :cr) '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :crlf) '(0 2 3 5 6 7 8 9 10 11)))
|
|
(with-test-file ((file-position :cr) '(#xc3 #xa9 #x0d #xc3 #xa8 #x38 #x0d #x39 #x3a #x0d #x3b))
|
|
(test :utf-8 '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :lf) '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :cr) '(0 2 3 5 6 7 8 9 10 11))
|
|
(test (:utf-8 :newline :crlf) '(0 2 3 5 6 7 8 9 10 11)))
|
|
(with-test-file ((file-position :crlf) '(#xc3 #xa9 #x0d #x0a #xc3 #xa8 #x38 #x0d #x0a #x39 #x3a #x0d #x0a #x3b))
|
|
(test :utf-8 '(0 2 3 4 6 7 8 9 10 11 12 13 14))
|
|
(test (:utf-8 :newline :lf) '(0 2 3 4 6 7 8 9 10 11 12 13 14))
|
|
(test (:utf-8 :newline :cr) '(0 2 3 4 6 7 8 9 10 11 12 13 14))
|
|
(test (:utf-8 :newline :crlf) '(0 2 4 6 7 9 10 11 13 14)))
|
|
(with-test-file ((file-position :replacement character) '(#xc3 #xa9 #x0d #x0a #xff #xc3 #xa8 #xff #x0d #x0a))
|
|
(test (:utf-8 :replacement #\?) '(0 2 3 4 5 7 8 9 10) '(0 2 3 5 5 8 8 9 10))
|
|
(test (:utf-8 :newline :lf :replacement #\?) '(0 2 3 4 5 7 8 9 10) '(0 2 3 5 5 8 8 9 10))
|
|
(test (:utf-8 :newline :cr :replacement #\?) '(0 2 3 4 5 7 8 9 10) '(0 2 3 5 5 8 8 9 10))
|
|
(test (:utf-8 :newline :crlf :replacement #\?) '(0 2 4 5 7 8 10) '(0 2 5 5 8 8 10)))
|
|
(with-test-file ((file-position :replacement string) '(#xc3 #xa9 #x0d #x0a #xff #xc3 #xa8 #xff #x0d #x0a))
|
|
(test (:utf-8 :replacement "??") '(0 2 3 4 5 5 7 8 8 9 10) '(0 2 3 5 5 5 8 8 8 9 10))
|
|
(test (:utf-8 :newline :lf :replacement "??") '(0 2 3 4 5 5 7 8 8 9 10) '(0 2 3 5 5 5 8 8 8 9 10))
|
|
(test (:utf-8 :newline :cr :replacement "??") '(0 2 3 4 5 5 7 8 8 9 10) '(0 2 3 5 5 5 8 8 8 9 10))
|
|
(test (:utf-8 :newline :crlf :replacement "??") '(0 2 4 5 5 7 8 8 10) '(0 2 5 5 5 8 8 8 10))))
|
|
|
|
(macrolet ((output-test (chars outxf expected &environment env)
|
|
`(progn
|
|
(with-test (:name (,(macroexpand 'name env) file-string-length ,outxf))
|
|
(let ((string (coerce ,chars 'string)))
|
|
(with-open-file (s *test-path* :element-type 'character
|
|
:external-format ',outxf
|
|
:direction :output :if-exists :supersede)
|
|
(handler-bind ((sb-int:character-encoding-error
|
|
(lambda (c) (use-value "" c))))
|
|
(let ((pos (file-position s))
|
|
(len (file-string-length s string)))
|
|
(let ((actual
|
|
(loop for index from 0 below (length string)
|
|
for char = (char string index)
|
|
for thislen = (file-string-length s char)
|
|
for thisstringlen = (file-string-length s (subseq string index))
|
|
if (null thisstringlen) do (assert (some 'null (subseq ,expected index))) else do (assert (notany 'null (subseq ,expected index)))
|
|
collect thislen
|
|
if (and (null len) thisstringlen) do (setf len (+ pos thisstringlen))
|
|
if thisstringlen do (assert (= (+ pos thisstringlen) len))
|
|
do (write-char char s)
|
|
if thislen do (assert (= (+ pos thislen) (file-position s)))
|
|
do (setf pos (file-position s)))))
|
|
(assert (equal actual ,expected))))))))))
|
|
(with-output-characters ((id chars) &body body)
|
|
`(let ((chars ,chars))
|
|
(symbol-macrolet ((name ,id))
|
|
(macrolet ((test (outxf expected)
|
|
`(output-test chars ,outxf ,expected)))
|
|
,@body)))))
|
|
(with-output-characters ((:output :lf) (list #\5 #\LATIN_SMALL_LETTER_E_WITH_ACUTE #\Linefeed #\7))
|
|
(test :utf-8 '(1 2 1 1))
|
|
(test (:utf-8 :newline :lf) '(1 2 1 1))
|
|
(test (:utf-8 :newline :cr) '(1 2 1 1))
|
|
(test (:utf-8 :newline :crlf) '(1 2 2 1)))
|
|
#+sb-unicode
|
|
(with-output-characters ((:output :invalid :lf) (list #\5 #\LATIN_SMALL_LETTER_E_WITH_ACUTE (code-char #xdb00) #\Linefeed #\7))
|
|
;; A sufficiently-smart streams implementation could statically determine the lengths
|
|
;; of replacement characters given as part of the external format
|
|
(test :utf-8 '(1 2 nil 1 1))
|
|
(test (:utf-8 :replacement #\?) '(1 2 nil 1 1))
|
|
(test (:utf-8 :newline :lf) '(1 2 nil 1 1))
|
|
(test (:utf-8 :newline :lf :replacement #\?) '(1 2 nil 1 1))
|
|
(test (:utf-8 :newline :cr) '(1 2 nil 1 1))
|
|
(test (:utf-8 :newline :cr :replacement #\?) '(1 2 nil 1 1))
|
|
(test (:utf-8 :newline :crlf) '(1 2 nil 2 1))
|
|
(test (:utf-8 :newline :crlf :replacement #\?) '(1 2 nil 2 1))))
|
|
|
|
(with-test (:name (:lp-2054169 :lf))
|
|
(let ((string (make-string 2048 :initial-element #\x)))
|
|
(loop for x from 78 by 78 below 2048
|
|
do (setf (aref string x) #\Newline))
|
|
(setf (aref string 24) #\LATIN_SMALL_LETTER_E_WITH_ACUTE) ; 2-bytes in UTF-8
|
|
(setf (aref string 23) #\Nul)
|
|
(with-open-file (s *test-path* :direction :output :external-format :utf-8 :if-exists :supersede)
|
|
(write-sequence string s))
|
|
(with-open-file (s *test-path* :external-format :utf-8)
|
|
(let ((positions
|
|
(loop for n from 0
|
|
for pos = (file-position s)
|
|
for char = (read-char s nil nil)
|
|
collect pos
|
|
if (null char) do (loop-finish))))
|
|
(assert (equal positions
|
|
(loop with pos = 0
|
|
for i from 0 to 2048
|
|
collect pos
|
|
if (and (> i 0) (= (mod i 78) 0)) do (incf pos 1)
|
|
else if (= i 24) do (incf pos 2)
|
|
else do (incf pos 1))))))))
|
|
|
|
(with-test (:name (:lp-2054169 :crlf))
|
|
(let ((string (make-string 2048 :initial-element #\x)))
|
|
(loop for x from 78 by 78 below 2048
|
|
do (setf (aref string x) #\Newline))
|
|
(setf (aref string 23) #\Nul)
|
|
(setf (aref string 24) #\LATIN_SMALL_LETTER_E_WITH_ACUTE) ; 2-bytes in UTF-8
|
|
(with-open-file (s *test-path* :direction :output
|
|
:external-format '(:utf-8 :newline :crlf) :if-exists :supersede)
|
|
(write-sequence string s))
|
|
(with-open-file (s *test-path* :external-format '(:utf-8 :newline :crlf))
|
|
(let ((positions
|
|
(loop for n from 0
|
|
for pos = (file-position s)
|
|
for char = (read-char s nil nil)
|
|
collect pos
|
|
if (null char) do (loop-finish))))
|
|
(assert (equal positions
|
|
(loop with pos = 0
|
|
for i from 0 to 2048
|
|
collect pos
|
|
if (and (> i 0) (= (mod i 78) 0)) do (incf pos 2)
|
|
else if (= i 24) do (incf pos 2)
|
|
else do (incf pos 1))))))))
|
|
(delete-file *test-path*)
|
|
|
|
#+sb-unicode
|
|
(defun random-string (stringlen percent-ascii &aux (unicode (- 100 percent-ascii)))
|
|
(let ((s (make-string stringlen)))
|
|
(dotimes (i stringlen s)
|
|
(setf (char s i)
|
|
(code-char (if (< (random 100.0) unicode)
|
|
(loop (let ((c (max 1 (random char-code-limit))))
|
|
(when (sb-unicode:scalar-p c) (return c))))
|
|
(max 1 (random 128))))))))
|
|
|
|
(with-test (:name :optimized-utf8-decoder
|
|
:skipped-on (:not :sb-unicode))
|
|
;; some tests need 100% ascii so that it hits the special case for base-string
|
|
(dolist (percent-ascii '(100 50 10))
|
|
(dotimes (i 1000)
|
|
(let* ((string (random-string (random 1000) percent-ascii))
|
|
(octets (string-to-octets string :null-terminate t))
|
|
(readback1
|
|
(sb-ext:octets-to-string octets :end (1- (length octets))))
|
|
(readback2
|
|
(sb-sys:with-pinned-objects (octets)
|
|
(sb-unicode:utf8-decode-from-sap (sb-sys:vector-sap octets))))
|
|
(readback3
|
|
;; doesn't take END or a displaced string. It could, but if you need
|
|
;; such capability, the SAP interface will do.
|
|
(sb-unicode:utf8-decode-from-octets
|
|
(subseq octets 0 (1- (length octets))))))
|
|
(when (= percent-ascii 100)
|
|
(assert (not (sb-kernel:simple-base-string-p readback1)))
|
|
(assert (sb-kernel:simple-base-string-p readback2))
|
|
(assert (sb-kernel:simple-base-string-p readback3)))
|
|
(assert (string= string readback1))
|
|
(assert (string= string readback2))
|
|
(assert (string= string readback3))))))
|
|
|
|
#+sb-unicode
|
|
(with-test (:name :character-string-utf8-length)
|
|
(flet ((test (chars expected-length &optional expected-ascii-p)
|
|
(let ((string (map 'string #'code-char chars)))
|
|
(multiple-value-bind (length ascii-p)
|
|
(sb-impl::character-string-utf8-length string)
|
|
(unless (and (eql expected-length length)
|
|
(eql expected-ascii-p (and ascii-p t)))
|
|
(error "(sb-impl::character-string-utf8-length ~a) => ~a, ~a; but ~a, ~a expected"
|
|
string length ascii-p
|
|
expected-length expected-ascii-p))))))
|
|
(test '(97 98 99 0) 4 t)
|
|
(test '(97 224 225 226 227 228 229 65) 14)
|
|
(test '(54620 0 24291 0 26085) 11)
|
|
(test '(97 128077 98 9989 65039 65039 65039 65039 65039 65039 65039) 30)
|
|
(test '(0 #xd800 1) nil)))
|
|
|
|
#+sb-unicode
|
|
(with-test (:name :output-to-c-string/utf-8/lf)
|
|
(flet ((test (chars expected &optional error-p)
|
|
(let ((string (map 'string #'code-char chars)))
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors (sb-impl::output-to-c-string/utf-8/lf string))
|
|
(if error-p
|
|
(unless error
|
|
(error "(sb-impl::output-to-c-string/utf-8/lf ~a) => ~a; but an error is expected"
|
|
string result))
|
|
(unless (and (typep result '(simple-array (unsigned-byte 8) (*)))
|
|
(equalp result expected))
|
|
(error "(sb-impl::output-to-c-string/utf-8/lf ~a) => ~a; but ~a is expected"
|
|
chars result expected)))))))
|
|
(test '(97 98 99)
|
|
#(97 98 99 0))
|
|
(test '(97 224 225 226 227 228 229 65)
|
|
#(97 195 160 195 161 195 162 195 163 195 164 195 165 65 0))
|
|
(test '(54620 0 24291 0 26085)
|
|
#(237 149 156 0 229 187 163 0 230 151 165 0))
|
|
(test '(97 128077 98 9989 65039 65039 65039 65039 65039 65039 65039)
|
|
#(97 240 159 145 141 98 226 156 133 239 184 143 239 184 143 239 184 143 239 184 143 239 184 143 239 184 143 239 184 143 0))
|
|
(test '(0 #xd800 1) nil t)))
|
|
|
|
#+sb-unicode
|
|
(with-test (:name :string-to-octets-encoding-error)
|
|
(assert
|
|
(equalp
|
|
(handler-bind ((sb-int:character-encoding-error (lambda (c) (use-value #\a c))))
|
|
(string-to-octets (map 'string #'code-char '(233 233 55955 99))))
|
|
#(195 169 195 169 97 99))))
|