X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fexternal-format.impure.lisp;h=430078ba5961b88a716d57b62d5b67f6777d8b41;hb=35f870eecfcaaba496d54e0f290b09e63884f74c;hp=5a2b4cd04d75d94c5a6f690a1c9a97cbe753f42a;hpb=c1b609d072224eddf850a0e3f85e578c6919117f;p=sbcl.git diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index 5a2b4cd..430078b 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -22,7 +22,7 @@ ,@body)))) (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. @@ -117,8 +117,15 @@ (dotimes (i 80) (assert (equal (read-line s nil s) "1234567890123456789012345678901234567890123456789"))))))) + (with-test (:name (:character-decode-large :force-end-of-file) :fails-on :sbcl) + (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 "external-format-test.txt" :direction :input :external-format :utf-8) (handler-bind @@ -203,6 +210,115 @@ :external-format :koi8-r) (let ((char (read-char s))) (assert (= (char-code (eval char)) #xB0)))) +(delete-file "external-format-test.txt") + +(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))) -(delete-file "external-format-test.txt") +;;; tests of FILE-STRING-LENGTH +(let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~")) + (do-external-formats (xf) + (with-open-file (s "external-format-test.txt" :direction :output + :external-format xf) + (loop for x across standard-characters + for position = (file-position s) + for char-length = (file-string-length s x) + do (write-char x s) + do (assert (= (file-position s) (+ position char-length)))) + (let ((position (file-position s)) + (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"))) + +(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 + :external-format :utf-8) + (dolist (code char-codes) + (let* ((char (code-char code)) + (position (file-position s)) + (char-length (file-string-length s char))) + (write-char char s) + (assert (= (file-position s) (+ position char-length))))) + (let* ((string (map 'string #'code-char char-codes)) + (position (file-position s)) + (string-length (file-string-length s string))) + (write-string string s) + (assert (= (file-position s) (+ position string-length)))))) + + +;;; 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 "external-format-test.txt")) + (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))) + +;;; 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