X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fexternal-format.impure.lisp;h=78285f71b05019c10a03fe2d62534323dc3ccdfe;hb=4363cb61eb8e2dc833070da398864a039210e1c8;hp=aabdf03a6ff0bb0ffa4e7c7a819ce1ba25b9c47b;hpb=31481ad7a664585715d60fbdeee153c5c5343400;p=sbcl.git diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index aabdf03..78285f7 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -17,27 +17,31 @@ (defmacro do-external-formats ((xf &optional result) &body body) (let ((nxf (gensym))) - `(dolist (,nxf sb-impl::*external-formats* ,result) - (let ((,xf (first (first ,nxf)))) - ,@body)))) + `(loop for ,nxf being the hash-values of sb-impl::*external-formats* + do (let ((,xf (first (sb-impl::ef-names ,nxf)))) + ,@body)))) + +(defvar *test-path* "external-format-test.tmp") (do-external-formats (xf) - (with-open-file (s "/dev/null" :direction :input :external-format xf) + (with-open-file (s #-win32 "/dev/null" #+win32 "nul" :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 + (with-open-file (s *test-path* :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 + (with-open-file (s *test-path* :direction :input :external-format xf) (loop for character across standard-characters - do (assert (eql (read-char s) character)))))) + do (let ((got (read-char s))) + (unless (eql character got) + (error "wanted ~S, got ~S" character got))))))) -(delete-file "external-format-test.txt") +(delete-file *test-path*) #-sb-unicode (progn (test-util:report-test-status) @@ -49,28 +53,30 @@ (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 + (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format :utf-8) (dotimes (n offset) (write-char #\a s)) - (dotimes (n 4097) + (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+)) (write-char character s))) - (with-open-file (s "external-format-test.txt" :direction :input + (with-open-file (s *test-path* :direction :input :external-format :utf-8) (dotimes (n offset) (assert (eql (read-char s) #\a))) - (dotimes (n 4097) - (assert (eql (read-char s) character))) + (dotimes (n (+ 4 sb-impl::+bytes-per-buffer+)) + (let ((got (read-char s))) + (unless (eql got character) + (error "wanted ~S, got ~S (~S)" character got n)))) (assert (eql (read-char s nil s) s)))))) ;;; Test character decode restarts. -(with-open-file (s "external-format-test.txt" :direction :output +(with-open-file (s *test-path* :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 +(with-open-file (s *test-path* :direction :input :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) @@ -79,7 +85,7 @@ '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 +(with-open-file (s *test-path* :direction :input :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) @@ -91,7 +97,7 @@ ;;; And again with more data to account for buffering (this was briefly) ;;; broken in early 0.9.6. -(with-open-file (s "external-format-test.txt" :direction :output +(with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (let ((a (make-array 50 :element-type '(unsigned-byte 64) @@ -104,7 +110,7 @@ (dotimes (i 40) (write-sequence a s)))) (with-test (:name (:character-decode-large :attempt-resync)) - (with-open-file (s "external-format-test.txt" :direction :input + (with-open-file (s *test-path* :direction :input :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) @@ -117,9 +123,16 @@ (dotimes (i 80) (assert (equal (read-line s nil s) "1234567890123456789012345678901234567890123456789"))))))) + (with-test (:name (:character-decode-large :force-end-of-file) :fails-on :sbcl) - (with-open-file (s "external-format-test.txt" :direction :input + (error "We can't reliably test this due to WITH-TIMEOUT race condition") + ;; This test will currently fail. But sometimes it will fail in + ;; ungracefully due to the WITH-TIMEOUT race mentioned above. This + ;; rightfully confuses some people, so we'll skip running the code + ;; for now. -- JES, 2006-01-27 + #+nil + (with-open-file (s *test-path* :direction :input :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) @@ -135,7 +148,7 @@ (assert (equal (read-line s nil s) s)))))) ;;; Test character encode restarts. -(with-open-file (s "external-format-test.txt" :direction :output +(with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format :latin-1) (handler-bind ((sb-int:character-encoding-error #'(lambda (encoding-error) @@ -146,12 +159,12 @@ (write-char #\B s) (write-char (code-char 322) s) (write-char #\C s))) -(with-open-file (s "external-format-test.txt" :direction :input +(with-open-file (s *test-path* :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 +(with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format :latin-1) (handler-bind ((sb-int:character-encoding-error #'(lambda (encoding-error) @@ -162,7 +175,7 @@ :initial-contents `(#\A #\B ,(code-char 322) #\C)))) (write-string string s)))) -(with-open-file (s "external-format-test.txt" :direction :input +(with-open-file (s *test-path* :direction :input :external-format :latin-1) (assert (equal (read-line s nil s) "ABC")) (assert (equal (read-line s nil s) s))) @@ -184,7 +197,7 @@ ;;;; KOI8-R external format -(with-open-file (s "external-format-test.txt" :direction :output +(with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format :koi8-r) (write-char (code-char #xB0) s) (assert (eq @@ -195,20 +208,30 @@ (sb-int:character-encoding-error () :good)) :good))) -(with-open-file (s "external-format-test.txt" :direction :input +(with-open-file (s *test-path* :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 +(with-open-file (s *test-path* :direction :input :external-format :koi8-r) (let ((char (read-char s))) (assert (= (char-code (eval char)) #xB0)))) -(delete-file "external-format-test.txt") +(delete-file *test-path*) + +(let* ((koi8-r-codes (coerce '(240 210 201 215 197 212 33) '(vector (unsigned-byte 8)))) + (uni-codes #(1055 1088 1080 1074 1077 1090 33)) + + (string (octets-to-string koi8-r-codes :external-format :koi8-r)) + (uni-decoded (map 'vector #'char-code string))) + (assert (equalp (map 'vector #'char-code (octets-to-string koi8-r-codes :external-format :koi8-r)) + uni-codes)) + (assert (equalp (string-to-octets (map 'string #'code-char uni-codes) :external-format :koi8-r) + koi8-r-codes))) ;;; tests of FILE-STRING-LENGTH (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~")) (do-external-formats (xf) - (with-open-file (s "external-format-test.txt" :direction :output + (with-open-file (s *test-path* :direction :output :external-format xf) (loop for x across standard-characters for position = (file-position s) @@ -219,12 +242,12 @@ (string-length (file-string-length s standard-characters))) (write-string standard-characters s) (assert (= (file-position s) (+ position string-length))))) - (delete-file "external-format-test.txt"))) + (delete-file *test-path*))) (let ((char-codes '(0 1 255 256 511 512 1023 1024 2047 2048 4095 4096 8191 8192 16383 16384 32767 32768 65535 65536 131071 131072 262143 262144))) - (with-open-file (s "external-format-test.txt" :direction :output + (with-open-file (s *test-path* :direction :output :external-format :utf-8) (dolist (code char-codes) (let* ((char (code-char code)) @@ -238,4 +261,88 @@ (write-string string s) (assert (= (file-position s) (+ position string-length)))))) -;;;; success \ No newline at end of file + +;;; See sbcl-devel "Subject: Bug in FILE-POSITION on UTF-8-encoded files" +;;; by Lutz Euler on 2006-03-05 for more details. +(with-test (:name (:file-position :utf-8)) + (let ((path *test-path*)) + (with-open-file (s path + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + ;; Write #\*, encoded in UTF-8, to the file. + (write-byte 42 s) + ;; Append #\adiaeresis, encoded in UTF-8, to the file. + (write-sequence '(195 164) s)) + (with-open-file (s path :external-format :utf-8) + (read-char s) + (let ((pos (file-position s)) + (char (read-char s))) + (format t "read character with code ~a successfully from file position ~a~%" + (char-code char) pos) + (file-position s pos) + (format t "set file position back to ~a, trying to read-char again~%" pos) + (let ((new-char (read-char s))) + (assert (char= char new-char))))) + (values))) +(delete-file *test-path*) + +;;; We used to call STREAM-EXTERNAL-FORMAT on the stream in the error +;;; when printing a coding error, but that didn't work if the stream +;;; was closed by the time the error was printed. See sbcl-devel +;;; "Subject: Printing coding errors for closed streams" by Zach Beane +;;; on 2008-10-16 for more info. +(with-test (:name (:character-coding-error-stream-external-format)) + (flet ((first-file-character () + (with-open-file (stream *test-path* :external-format :utf-8) + (read-char stream)))) + (with-open-file (stream *test-path* + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) + (write-byte 192 stream)) + (princ-to-string (nth-value 1 (ignore-errors (first-file-character)))))) +(delete-file *test-path*) + +;;; External format support in SB-ALIEN + +(with-test (:name (:sb-alien :vanilla)) + (define-alien-routine strdup c-string (str c-string)) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :utf-8 :utf-8)) + (define-alien-routine strdup (c-string :external-format :utf-8) + (str (c-string :external-format :utf-8))) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :latin-1 :utf-8)) + (define-alien-routine strdup (c-string :external-format :latin-1) + (str (c-string :external-format :utf-8))) + (assert (= (length (strdup (string (code-char 246)))) + 2))) + +(with-test (:name (:sb-alien :utf-8 :latin-1)) + (define-alien-routine strdup (c-string :external-format :utf-8) + (str (c-string :external-format :latin-1))) + (assert (equal (string (code-char 228)) + (strdup (concatenate 'string + (list (code-char 195)) + (list (code-char 164))))))) + +(with-test (:name (:sb-alien :ebcdic :ebcdic)) + (define-alien-routine strdup (c-string :external-format :ebcdic-us) + (str (c-string :external-format :ebcdic-us))) + (assert (equal "foo" (strdup "foo")))) + +(with-test (:name (:sb-alien :latin-1 :ebcdic)) + (define-alien-routine strdup (c-string :external-format :latin-1) + (str (c-string :external-format :ebcdic-us))) + (assert (not (equal "foo" (strdup "foo"))))) + +(with-test (:name (:sb-alien :simple-base-string)) + (define-alien-routine strdup (c-string :external-format :ebcdic-us + :element-type base-char) + (str (c-string :external-format :ebcdic-us))) + (assert (typep (strdup "foo") 'simple-base-string))) + +;;;; success