1 ;; Copyright (C) 1999 Free Software Foundation, Inc.
3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org>
4 ;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>,
5 ;; Martin Buchholz <martin@xemacs.org>
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by the
13 ;; Free Software Foundation, either version 3 of the License, or (at your
14 ;; option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be
17 ;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not in FSF.
28 ;; Test some Mule functionality (most of these remain to be written) .
29 ;; See test-harness.el for instructions on how to run these tests.
31 ;; This file will be (read)ed by a non-mule XEmacs, so don't use
32 ;; literal non-Latin1 characters. Use (make-char) instead.
34 ;;-----------------------------------------------------------------
35 ;; Test whether all legal chars may be safely inserted to a buffer.
36 ;;-----------------------------------------------------------------
38 (defun test-chars (&optional for-test-harness)
39 "Insert all characters in a buffer, to see if XEmacs will crash.
40 This is done by creating a string with all the legal characters
41 in [0, 2^19) range, inserting it into the buffer, and checking
42 that the buffer's contents are equivalent to the string.
44 If FOR-TEST-HARNESS is specified, a temporary buffer is used, and
45 the Assert macro checks for correctness."
46 (let ((max (expt 2 (if (featurep 'mule) 19 8)))
50 (and (not for-test-harness)
54 ;; Don't aset to a string directly because random string
55 ;; access is O(n) under Mule.
56 (setq list (cons (int-char i) list)))
58 (let ((string (apply #'string (nreverse list))))
60 ;; For use with test-harness, use Assert and a temporary
64 (Assert (equal (buffer-string) string)))
65 ;; For use without test harness: use a normal buffer, so that
66 ;; you can also test whether redisplay works.
67 (switch-to-buffer (get-buffer-create "test"))
71 (assert (equal (buffer-string) string))))))
73 ;; It would be really *really* nice if test-harness allowed a way to
74 ;; run a test in byte-compiled mode only. It's tedious to have
75 ;; time-consuming tests like this one run twice, once interpreted and
76 ;; once compiled, for no good reason.
79 ;;-----------------------------------------------------------------
80 ;; Test string modification functions that modify the length of a char.
81 ;;-----------------------------------------------------------------
83 (when (featurep 'mule)
84 ;;---------------------------------------------------------------
86 ;;---------------------------------------------------------------
90 (let ((char1 (make-char charset1 69))
91 (char2 (make-char charset2 69)))
92 `(let ((string (make-string 1000 ,char1)))
93 (fillarray string ,char2)
94 (Assert (eq (aref string 0) ,char2))
95 (Assert (eq (aref string (1- (length string))) ,char2))
96 (Assert (eq (length string) 1000))))))
97 (fillarray-test ascii latin-iso8859-1)
98 (fillarray-test ascii latin-iso8859-2)
99 (fillarray-test latin-iso8859-1 ascii)
100 (fillarray-test latin-iso8859-2 ascii))
103 (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69))))
104 (aset string 0 (make-char 'latin-iso8859-2 42))
105 (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69))))
107 ;;---------------------------------------------------------------
108 ;; Test coding system functions
109 ;;---------------------------------------------------------------
111 ;; Create alias for coding system without subsidiaries
112 (Assert (coding-system-p (find-coding-system 'binary)))
113 (Assert (coding-system-canonical-name-p 'binary))
114 (Assert (not (coding-system-alias-p 'binary)))
115 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
116 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
118 error "Symbol is the canonical name of a coding system and cannot be redefined"
119 (define-coding-system-alias 'binary 'iso8859-2))
121 error "Symbol is not a coding system alias"
122 (coding-system-aliasee 'binary))
124 (define-coding-system-alias 'mule-tests-alias 'binary)
125 (Assert (coding-system-alias-p 'mule-tests-alias))
126 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
127 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
128 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
129 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
130 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
131 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
133 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'binary))
134 (Assert (coding-system-alias-p 'mule-tests-alias))
135 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
136 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
137 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
138 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
139 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
140 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
142 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
143 (Assert (coding-system-alias-p 'nested-mule-tests-alias))
144 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
145 (Assert (eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias)))
146 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
147 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
148 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-unix)))
149 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
150 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-mac)))
153 error "Attempt to create a coding system alias loop"
154 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
156 error "No such coding system"
157 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
159 error "Attempt to create a coding system alias loop"
160 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
162 (define-coding-system-alias 'nested-mule-tests-alias nil)
163 (define-coding-system-alias 'mule-tests-alias nil)
164 (Assert (coding-system-p (find-coding-system 'binary)))
165 (Assert (coding-system-canonical-name-p 'binary))
166 (Assert (not (coding-system-alias-p 'binary)))
167 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
168 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
170 error "Symbol is the canonical name of a coding system and cannot be redefined"
171 (define-coding-system-alias 'binary 'iso8859-2))
173 error "Symbol is not a coding system alias"
174 (coding-system-aliasee 'binary))
176 (define-coding-system-alias 'nested-mule-tests-alias nil)
177 (define-coding-system-alias 'mule-tests-alias nil)
179 ;; Create alias for coding system with subsidiaries
180 (define-coding-system-alias 'mule-tests-alias 'iso-8859-7)
181 (Assert (coding-system-alias-p 'mule-tests-alias))
182 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
183 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
184 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
185 (Assert (coding-system-alias-p 'mule-tests-alias-unix))
186 (Assert (coding-system-alias-p 'mule-tests-alias-dos))
187 (Assert (coding-system-alias-p 'mule-tests-alias-mac))
189 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'iso-8859-7))
190 (Assert (coding-system-alias-p 'mule-tests-alias))
191 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
192 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
193 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
194 (Assert (coding-system-alias-p 'mule-tests-alias-unix))
195 (Assert (coding-system-alias-p 'mule-tests-alias-dos))
196 (Assert (coding-system-alias-p 'mule-tests-alias-mac))
197 (Assert (eq (find-coding-system 'mule-tests-alias-mac)
198 (find-coding-system 'iso-8859-7-mac)))
200 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
201 (Assert (coding-system-alias-p 'nested-mule-tests-alias))
202 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
203 (Assert (eq (get-coding-system 'iso-8859-7)
204 (get-coding-system 'nested-mule-tests-alias)))
205 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
206 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
207 (Assert (coding-system-alias-p 'nested-mule-tests-alias-unix))
208 (Assert (coding-system-alias-p 'nested-mule-tests-alias-dos))
209 (Assert (coding-system-alias-p 'nested-mule-tests-alias-mac))
210 (Assert (eq (find-coding-system 'nested-mule-tests-alias-unix)
211 (find-coding-system 'iso-8859-7-unix)))
214 error "Attempt to create a coding system alias loop"
215 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
217 error "No such coding system"
218 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
220 error "Attempt to create a coding system alias loop"
221 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
223 ;; Test dangling alias deletion
224 (define-coding-system-alias 'mule-tests-alias nil)
225 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
226 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
227 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias)))
228 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
230 ;;---------------------------------------------------------------
231 ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c)
232 ;;---------------------------------------------------------------
233 (defun charset-char-string (charset)
234 (let (lo hi string n (gc-cons-threshold most-positive-fixnum))
235 (if (= (charset-chars charset) 94)
238 (if (= (charset-dimension charset) 1)
240 (setq string (make-string (1+ (- hi lo)) ??))
242 (loop for j from lo to hi do
244 (aset string n (make-char charset j))
249 (setq string (make-string (* (1+ (- hi lo)) (1+ (- hi lo))) ??))
251 (loop for j from lo to hi do
252 (loop for k from lo to hi do
254 (aset string n (make-char charset j k))
259 ;; The following two used to crash xemacs!
260 (Assert (charset-char-string 'japanese-jisx0208))
261 (aset (make-string 9003 ??) 1 (make-char 'latin-iso8859-1 77))
263 (let ((greek-string (charset-char-string 'greek-iso8859-7))
264 (string (make-string (* 96 60) ??)))
265 (loop for j from 0 below (length string) do
266 (aset string j (aref greek-string (mod j 96))))
267 (loop for k in '(0 1 58 59) do
268 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
270 (let ((greek-string (charset-char-string 'greek-iso8859-7))
271 (string (make-string (* 96 60) ??)))
272 (loop for j from (1- (length string)) downto 0 do
273 (aset string j (aref greek-string (mod j 96))))
274 (loop for k in '(0 1 58 59) do
275 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
277 (let ((ascii-string (charset-char-string 'ascii))
278 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
279 (loop for j from 0 below (length string) do
280 (aset string j (aref ascii-string (mod j 94))))
281 (loop for k in '(0 1 58 59) do
282 (Assert (equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string))))
284 (let ((ascii-string (charset-char-string 'ascii))
285 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
286 (loop for j from (1- (length string)) downto 0 do
287 (aset string j (aref ascii-string (mod j 94))))
288 (loop for k in '(0 1 58 59) do
289 (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string))))
291 ;;---------------------------------------------------------------
292 ;; Test file-system character conversion (and, en passant, file ops)
293 ;;---------------------------------------------------------------
294 (let* ((scaron (make-char 'latin-iso8859-2 57))
295 (latin2-string (make-string 4 scaron))
296 (prefix (concat (file-name-as-directory
297 (file-truename (temp-directory)))
299 (name1 (make-temp-name prefix))
300 (name2 (make-temp-name prefix))
301 (file-name-coding-system 'iso-8859-2))
303 (Assert (not (equal name1 name2)))
304 ;; Kludge to handle Mac OS X which groks only UTF-8.
305 (cond ((eq system-type 'darwin)
306 (Check-Error-Message 'file-error "Opening output file"
307 (write-region (point-min) (point-max) name1))
309 (setq file-name-coding-system 'utf-8)))
310 (Assert (not (file-exists-p name1)))
311 (write-region (point-min) (point-max) name1)
312 (Assert (file-exists-p name1))
313 (when (fboundp 'make-symbolic-link)
314 (make-symbolic-link name1 name2)
315 (Assert (file-exists-p name2))
316 (Assert (equal (file-truename name2) name1))
317 (Assert (equal (file-truename name1) name1)))
319 (ignore-file-errors (delete-file name1) (delete-file name2))))
321 ;; Add many more file operation tests here...
323 ;;---------------------------------------------------------------
324 ;; Test Unicode-related functions
325 ;;---------------------------------------------------------------
326 (let* ((scaron (make-char 'latin-iso8859-2 57)))
327 (loop for code in '(#x0000 #x2222 #x4444 #xffff) do
329 (set-ucs-char code scaron)
330 (Assert (eq scaron (ucs-char code)))))
332 (Assert (eq nil (set-ucs-char #x1ffff scaron)))
333 (Check-Error wrong-type-argument (set-ucs-char -10000 scaron)))