X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fexternal-format.impure.lisp;h=d1a9644efbc1d0d49e47f2302af50a4fb958761e;hb=40e3ba03d0e1b824e4d1ae75d74246b975b70964;hp=9673578e806c0f2a08e167ae8b82db835e87a32d;hpb=5cd0fc84df83d1b3321b7fc969843207721de429;p=sbcl.git diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index 9673578..d1a9644 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -10,7 +10,7 @@ ;;;; 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. @@ -19,25 +19,144 @@ (let ((nxf (gensym))) `(dolist (,nxf sb-impl::*external-formats* ,result) (let ((,xf (first (first ,nxf)))) - ,@body)))) + ,@body)))) (do-external-formats (xf) (with-open-file (s "/dev/null" :direction :input :external-format xf) (assert (eq (read-char s nil s) s)))) +;;; Test standard character read-write equivalency over all external formats. +(let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~")) + (do-external-formats (xf) + (with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :external-format xf) + (loop for character across standard-characters + do (write-char character s))) + (with-open-file (s "external-format-test.txt" :direction :input + :external-format xf) + (loop for character across standard-characters + do (assert (eql (read-char s) character)))))) + +(delete-file "external-format-test.txt") +#-sb-unicode +(sb-ext:quit :unix-status 104) + +;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with +;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are +;;; 4096 wide. +(dotimes (width-1 4) + (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1)))) + (dotimes (offset (+ width-1 1)) + (with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :external-format :utf-8) + (dotimes (n offset) + (write-char #\a s)) + (dotimes (n 4097) + (write-char character s))) + (with-open-file (s "external-format-test.txt" :direction :input + :external-format :utf-8) + (dotimes (n offset) + (assert (eql (read-char s) #\a))) + (dotimes (n 4097) + (assert (eql (read-char s) character))) + (assert (eql (read-char s nil s) s)))))) + +;;; Test character decode restarts. +(with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :element-type '(unsigned-byte 8)) + (write-byte 65 s) + (write-byte 66 s) + (write-byte #xe0 s) + (write-byte 67 s)) +(with-open-file (s "external-format-test.txt" :direction :input + :external-format :utf-8) + (handler-bind + ((sb-int:character-decoding-error #'(lambda (decoding-error) + (declare (ignore decoding-error)) + (invoke-restart + 'sb-int:attempt-resync)))) + (assert (equal (read-line s nil s) "ABC")) + (assert (equal (read-line s nil s) s)))) +(with-open-file (s "external-format-test.txt" :direction :input + :external-format :utf-8) + (handler-bind + ((sb-int:character-decoding-error #'(lambda (decoding-error) + (declare (ignore decoding-error)) + (invoke-restart + 'sb-int:force-end-of-file)))) + (assert (equal (read-line s nil s) "AB")) + (assert (equal (read-line s nil s) s)))) + +;;; Test character encode restarts. +(with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :external-format :latin-1) + (handler-bind + ((sb-int:character-encoding-error #'(lambda (encoding-error) + (declare (ignore encoding-error)) + (invoke-restart + 'sb-impl::output-nothing)))) + (write-char #\A s) + (write-char #\B s) + (write-char (code-char 322) s) + (write-char #\C s))) +(with-open-file (s "external-format-test.txt" :direction :input + :external-format :latin-1) + (assert (equal (read-line s nil s) "ABC")) + (assert (equal (read-line s nil s) s))) + +(with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :external-format :latin-1) + (handler-bind + ((sb-int:character-encoding-error #'(lambda (encoding-error) + (declare (ignore encoding-error)) + (invoke-restart + 'sb-impl::output-nothing)))) + (let ((string (make-array 4 :element-type 'character + :initial-contents `(#\A #\B ,(code-char 322) + #\C)))) + (write-string string s)))) +(with-open-file (s "external-format-test.txt" :direction :input + :external-format :latin-1) + (assert (equal (read-line s nil s) "ABC")) + (assert (equal (read-line s nil s) s))) + +;;; Test skipping character-decode-errors in comments. (let ((s (open "external-format-test.lisp" :direction :output - :if-exists :supersede :external-format :latin-1))) + :if-exists :supersede :external-format :latin-1))) (unwind-protect (progn - (write-string ";;; ABCD" s) - (write-char (code-char 233) s) - (terpri s) - (close s) - (compile-file "external-format-test.lisp" :external-format :utf-8)) + (write-string ";;; ABCD" s) + (write-char (code-char 233) s) + (terpri s) + (close s) + (compile-file "external-format-test.lisp" :external-format :utf-8)) (delete-file s) (let ((p (probe-file (compile-file-pathname "external-format-test.lisp")))) (when p - (delete-file p))))) + (delete-file p))))) + + +;;;; KOI8-R external format +(with-open-file (s "external-format-test.txt" :direction :output + :if-exists :supersede :external-format :koi8-r) + (write-char (code-char #xB0) s) + (assert (eq + (handler-case + (progn + (write-char (code-char #xBAAD) s) + :bad) + (sb-int:character-encoding-error () + :good)) + :good))) +(with-open-file (s "external-format-test.txt" :direction :input + :element-type '(unsigned-byte 8)) + (let ((byte (read-byte s))) + (assert (= (eval byte) #x9C)))) +(with-open-file (s "external-format-test.txt" :direction :input + :external-format :koi8-r) + (let ((char (read-char s))) + (assert (= (char-code (eval char)) #xB0)))) + +(delete-file "external-format-test.txt") (sb-ext:quit :unix-status 104) - \ No newline at end of file