0.9.2.13:
[sbcl.git] / tests / external-format.impure.lisp
1 ;;;; This file is for testing external-format functionality, using
2 ;;;; test machinery which might have side effects (e.g.  executing
3 ;;;; DEFUN, writing files).  Note that the tests here reach into
4 ;;;; unexported functionality, and should not be used as a guide for
5 ;;;; users.
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
12 ;;;; from CMU CL.
13 ;;;; 
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
17
18 #-sb-unicode
19 (sb-ext:quit :unix-status 104)
20
21 (defmacro do-external-formats ((xf &optional result) &body body)
22   (let ((nxf (gensym)))
23     `(dolist (,nxf sb-impl::*external-formats* ,result)
24        (let ((,xf (first (first ,nxf))))
25          ,@body))))
26
27 (do-external-formats (xf)
28   (with-open-file (s "/dev/null" :direction :input :external-format xf)
29     (assert (eq (read-char s nil s) s))))
30
31 ;;; Test standard character read-write equivalency over all external formats.
32 (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~"))
33   (do-external-formats (xf)
34     (with-open-file (s "external-format-test.txt" :direction :output
35                      :if-exists :supersede :external-format xf)
36       (loop for character across standard-characters
37             do (write-char character s)))
38     (with-open-file (s "external-format-test.txt" :direction :input
39                      :external-format xf)
40       (loop for character across standard-characters
41             do (assert (eql (read-char s) character))))))
42
43 ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with
44 ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are
45 ;;; 4096 wide.
46 (dotimes (width-1 4)
47   (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1))))
48     (dotimes (offset (+ width-1 1))
49       (with-open-file (s "external-format-test.txt" :direction :output
50                        :if-exists :supersede :external-format :utf-8)
51         (dotimes (n offset)
52           (write-char #\a s))
53         (dotimes (n 4097)
54           (write-char character s)))
55       (with-open-file (s "external-format-test.txt" :direction :input
56                        :external-format :utf-8)
57         (dotimes (n offset)
58           (assert (eql (read-char s) #\a)))
59         (dotimes (n 4097)
60           (assert (eql (read-char s) character)))
61         (assert (eql (read-char s nil s) s))))))
62
63 ;;; Test character decode restarts.
64 (with-open-file (s "external-format-test.txt" :direction :output
65                  :if-exists :supersede :element-type '(unsigned-byte 8))
66   (write-byte 65 s)
67   (write-byte 66 s)
68   (write-byte #xe0 s)
69   (write-byte 67 s))
70 (with-open-file (s "external-format-test.txt" :direction :input
71                  :external-format :utf-8)
72   (handler-bind
73       ((sb-int:character-decoding-error #'(lambda (decoding-error)
74                                             (declare (ignore decoding-error))
75                                             (invoke-restart
76                                              'sb-int:attempt-resync))))
77     (assert (equal (read-line s nil s) "ABC"))
78     (assert (equal (read-line s nil s) s))))
79 (with-open-file (s "external-format-test.txt" :direction :input
80                  :external-format :utf-8)
81   (handler-bind
82       ((sb-int:character-decoding-error #'(lambda (decoding-error)
83                                             (declare (ignore decoding-error))
84                                             (invoke-restart
85                                              'sb-int:force-end-of-file))))
86     (assert (equal (read-line s nil s) "AB"))
87     (assert (equal (read-line s nil s) s))))
88
89 ;;; Test character encode restarts.
90 (with-open-file (s "external-format-test.txt" :direction :output
91                  :if-exists :supersede :external-format :latin-1)
92   (handler-bind
93       ((sb-int:character-encoding-error #'(lambda (encoding-error)
94                                             (declare (ignore encoding-error))
95                                             (invoke-restart
96                                              'sb-impl::output-nothing))))
97     (write-char #\A s)
98     (write-char #\B s)
99     (write-char (code-char 322) s)
100     (write-char #\C s)))
101 (with-open-file (s "external-format-test.txt" :direction :input
102                  :external-format :latin-1)
103   (assert (equal (read-line s nil s) "ABC"))
104   (assert (equal (read-line s nil s) s)))
105
106 (with-open-file (s "external-format-test.txt" :direction :output
107                  :if-exists :supersede :external-format :latin-1)
108   (handler-bind
109       ((sb-int:character-encoding-error #'(lambda (encoding-error)
110                                             (declare (ignore encoding-error))
111                                             (invoke-restart
112                                              'sb-impl::output-nothing))))
113     (let ((string (make-array 4 :element-type 'character
114                               :initial-contents `(#\A #\B ,(code-char 322)
115                                                       #\C))))
116       (write-string string s))))
117 (with-open-file (s "external-format-test.txt" :direction :input
118                  :external-format :latin-1)
119   (assert (equal (read-line s nil s) "ABC"))
120   (assert (equal (read-line s nil s) s)))
121
122 ;;; Test skipping character-decode-errors in comments.
123 (let ((s (open "external-format-test.lisp" :direction :output
124                :if-exists :supersede :external-format :latin-1)))
125   (unwind-protect
126        (progn
127          (write-string ";;; ABCD" s)
128          (write-char (code-char 233) s)
129          (terpri s)
130          (close s)
131          (compile-file "external-format-test.lisp" :external-format :utf-8))
132     (delete-file s)
133     (let ((p (probe-file (compile-file-pathname "external-format-test.lisp"))))
134       (when p
135         (delete-file p)))))
136
137 (delete-file "external-format-test.txt")
138
139 (sb-ext:quit :unix-status 104)