Mercurial > hg > xemacs-beta
annotate tests/automated/mule-tests.el @ 4318:4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
APPROVE COMMIT
NOTE: this patch has been committed.
This is patch http://mid.gmane.org/18264.25814.828088.486899@parhasard.net
tests/ChangeLog addition:
2007-12-06 Aidan Kehoe <kehoea@parhasard.net>
* automated/mule-tests.el:
Add a Known-Bug-Expect-Error call testing and documenting that we
don't support all of the Unicode code space in a single session.
* automated/test-harness.el (Known-Bug-Expect-Error):
Provide Known-Bug-Expect-Error, analagous to
Known-Bug-Expect-Failure and Check-Error.
* automated/test-harness.el (Silence-Message):
Dynamically bind the function definition of #'clear-message, as
well as that of #'append-message, to nil.
src/ChangeLog addition:
2007-12-06 Aidan Kehoe <kehoea@parhasard.net>
* tests.c (Ftest_data_format_conversion):
Move those tests that expect that iso-8859-2 is ISO
2022-compatible to testing iso-latin-2-with-esc instead.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 09 Dec 2007 15:10:46 +0100 |
| parents | 2bb3630ea397 |
| children | e5b3c4dbc8a2 |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1999 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org> | |
| 440 | 4 ;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>, |
| 5 ;; Martin Buchholz <martin@xemacs.org> | |
| 428 | 6 ;; Created: 1999 |
| 7 ;; Keywords: tests | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; 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. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 24 ;; 02111-1307, USA. | |
| 25 | |
| 26 ;;; Synched up with: Not in FSF. | |
| 27 | |
| 28 ;;; Commentary: | |
| 29 | |
| 30 ;; Test some Mule functionality (most of these remain to be written) . | |
| 31 ;; See test-harness.el for instructions on how to run these tests. | |
| 32 | |
| 434 | 33 ;; This file will be (read)ed by a non-mule XEmacs, so don't use |
| 34 ;; literal non-Latin1 characters. Use (make-char) instead. | |
| 35 | |
| 3948 | 36 (require 'bytecomp) |
| 37 | |
| 428 | 38 ;;----------------------------------------------------------------- |
| 39 ;; Test whether all legal chars may be safely inserted to a buffer. | |
| 40 ;;----------------------------------------------------------------- | |
| 41 | |
| 42 (defun test-chars (&optional for-test-harness) | |
| 43 "Insert all characters in a buffer, to see if XEmacs will crash. | |
| 44 This is done by creating a string with all the legal characters | |
| 4133 | 45 in [0, 2^21) range, inserting it into the buffer, and checking |
| 428 | 46 that the buffer's contents are equivalent to the string. |
| 47 | |
| 48 If FOR-TEST-HARNESS is specified, a temporary buffer is used, and | |
| 49 the Assert macro checks for correctness." | |
| 4133 | 50 (let ((max (expt 2 (if (featurep 'mule) 21 8))) |
| 428 | 51 (list nil) |
| 52 (i 0)) | |
| 53 (while (< i max) | |
| 54 (and (not for-test-harness) | |
| 55 (zerop (% i 1000)) | |
| 56 (message "%d" i)) | |
| 57 (and (int-char i) | |
| 58 ;; Don't aset to a string directly because random string | |
| 59 ;; access is O(n) under Mule. | |
| 60 (setq list (cons (int-char i) list))) | |
| 61 (setq i (1+ i))) | |
| 62 (let ((string (apply #'string (nreverse list)))) | |
| 63 (if for-test-harness | |
| 64 ;; For use with test-harness, use Assert and a temporary | |
| 65 ;; buffer. | |
| 66 (with-temp-buffer | |
| 67 (insert string) | |
| 68 (Assert (equal (buffer-string) string))) | |
| 69 ;; For use without test harness: use a normal buffer, so that | |
| 70 ;; you can also test whether redisplay works. | |
| 71 (switch-to-buffer (get-buffer-create "test")) | |
| 72 (erase-buffer) | |
| 73 (buffer-disable-undo) | |
| 74 (insert string) | |
| 75 (assert (equal (buffer-string) string)))))) | |
| 76 | |
| 77 ;; It would be really *really* nice if test-harness allowed a way to | |
| 78 ;; run a test in byte-compiled mode only. It's tedious to have | |
| 79 ;; time-consuming tests like this one run twice, once interpreted and | |
| 80 ;; once compiled, for no good reason. | |
| 81 (test-chars t) | |
| 434 | 82 |
| 3439 | 83 (defun unicode-code-point-to-utf-8-string (code-point) |
| 84 "Convert a Unicode code point to the equivalent UTF-8 string. | |
| 85 This is a naive implementation in Lisp. " | |
| 86 (check-argument-type 'natnump code-point) | |
| 87 (check-argument-range code-point 0 #x1fffff) | |
| 88 (if (< code-point #x80) | |
| 89 (format "%c" code-point) | |
| 90 (if (< code-point #x800) | |
| 91 (format "%c%c" | |
| 92 ;; ochars[0] = 0xC0 | (input & ~(0xFFFFF83F)) >> 6; | |
| 93 (logior #xc0 (lsh (logand code-point #x7c0) -6)) | |
| 94 ;; ochars[1] = 0x80 | input & ~(0xFFFFFFC0); | |
| 95 (logior #x80 (logand code-point #x3f))) | |
| 96 (if (< code-point #x00010000) | |
| 97 (format "%c%c%c" | |
| 98 ;; ochars[0] = 0xE0 | (input >> 12) & ~(0xFFFFFFF0); | |
| 99 (logior #xe0 (logand (lsh code-point -12) #x0f)) | |
| 100 ;; ochars[1] = 0x80 | (input >> 6) & ~(0xFFFFFFC0); | |
| 101 (logior #x80 (logand (lsh code-point -6) #x3f)) | |
| 102 ;; ochars[2] = 0x80 | input & ~(0xFFFFFFC0); | |
| 103 (logior #x80 (logand code-point #x3f))) | |
| 104 (if (< code-point #x200000) | |
| 105 (format "%c%c%c%c" | |
| 106 ;; ochars[0] = 0xF0 | (input >> 18) & ~(0xFFFFFFF8) | |
| 107 (logior #xF0 (logand (lsh code-point -18) #x7)) | |
| 108 ;; ochars[1] = 0x80 | (input >> 12) & ~(0xFFFFFFC0); | |
| 109 (logior #x80 (logand (lsh code-point -12) #x3f)) | |
| 110 ;; ochars[2] = 0x80 | (input >> 6) & ~(0xFFFFFFC0); | |
| 111 (logior #x80 (logand (lsh code-point -6) #x3f)) | |
| 112 ;; ochars[3] = 0x80 | input & ~(0xFFFFFFC0); | |
| 113 (logior #x80 (logand code-point #x3f)))))))) | |
| 114 | |
| 4026 | 115 ;;---------------------------------------------------------------- |
| 116 ;; Test that revert-buffer resets the modiff | |
| 117 ;; Bug reported 2007-06-20 <200706201902.32191.scop@xemacs.org>. | |
| 118 ;; Fixed 2007-06-22 <18043.2793.611745.734215@parhasard.net>. | |
| 119 ;;---------------------------------------------------------------- | |
| 120 | |
| 4133 | 121 (let ((test-file-name |
| 122 ;; The Gnus people, when they call #'make-temp-name, then loop, | |
| 123 ;; checking if the corresponding file exists. Our #'make-temp-name | |
| 124 ;; already does this loop, and the Gnus approach doesn't bring | |
| 125 ;; anything; there remains a race condition if you can predict the | |
| 126 ;; path name. The path name in question depends on the process ID and | |
| 127 ;; a (weak) PRNG seeded with the seconds to the power of the | |
| 128 ;; milliseconds of some instant close to the startup time of this | |
| 129 ;; XEmacs; without being able to read the address space of this | |
| 130 ;; XEmacs, or monitor what stat() calls it does, it is not predictable. | |
| 131 ;; | |
| 132 ;; The really kosher way to do this is to merge GNU's make-temp-file | |
| 133 ;; and use that. It basically has the functionality of the Unix | |
| 134 ;; mkstemp. | |
| 135 (make-temp-name (expand-file-name "tXfXsKc" (temp-directory)))) | |
| 4026 | 136 revert-buffer-function |
| 137 kill-buffer-hook) ; paranoia | |
| 138 (find-file test-file-name) | |
| 139 (erase-buffer) | |
| 140 (insert "a string\n") | |
| 4133 | 141 (Silence-Message (save-buffer 0)) |
| 4026 | 142 (insert "more text\n") |
| 143 (revert-buffer t t) | |
| 144 ;; Just "find-file" with autodetect coding didn't fail for me, but it does | |
| 145 ;; fail under test harness. Still we'll redo the test with an explicit | |
| 146 ;; coding system just in case. | |
| 147 (Assert (not (buffer-modified-p))) | |
| 148 (kill-buffer nil) | |
| 149 (when (find-coding-system 'utf-8) | |
| 150 (find-file test-file-name 'utf-8) | |
| 151 (insert "more text\n") | |
| 152 (revert-buffer t t) | |
| 153 (Assert (not (buffer-modified-p))) | |
| 154 (kill-buffer nil)) | |
| 155 (delete-file test-file-name)) | |
| 156 | |
| 434 | 157 ;;----------------------------------------------------------------- |
| 158 ;; Test string modification functions that modify the length of a char. | |
| 159 ;;----------------------------------------------------------------- | |
| 160 | |
| 161 (when (featurep 'mule) | |
| 442 | 162 ;;--------------------------------------------------------------- |
| 434 | 163 ;; Test fillarray |
| 442 | 164 ;;--------------------------------------------------------------- |
| 434 | 165 (macrolet |
| 166 ((fillarray-test | |
| 167 (charset1 charset2) | |
| 168 (let ((char1 (make-char charset1 69)) | |
| 169 (char2 (make-char charset2 69))) | |
| 170 `(let ((string (make-string 1000 ,char1))) | |
| 171 (fillarray string ,char2) | |
| 172 (Assert (eq (aref string 0) ,char2)) | |
| 173 (Assert (eq (aref string (1- (length string))) ,char2)) | |
| 174 (Assert (eq (length string) 1000)))))) | |
| 175 (fillarray-test ascii latin-iso8859-1) | |
| 176 (fillarray-test ascii latin-iso8859-2) | |
| 177 (fillarray-test latin-iso8859-1 ascii) | |
| 178 (fillarray-test latin-iso8859-2 ascii)) | |
| 179 | |
| 180 ;; Test aset | |
| 181 (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69)))) | |
| 182 (aset string 0 (make-char 'latin-iso8859-2 42)) | |
| 183 (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69)))) | |
| 184 | |
| 442 | 185 ;;--------------------------------------------------------------- |
| 440 | 186 ;; Test coding system functions |
| 442 | 187 ;;--------------------------------------------------------------- |
| 440 | 188 |
| 189 ;; Create alias for coding system without subsidiaries | |
| 190 (Assert (coding-system-p (find-coding-system 'binary))) | |
| 191 (Assert (coding-system-canonical-name-p 'binary)) | |
| 192 (Assert (not (coding-system-alias-p 'binary))) | |
| 193 (Assert (not (coding-system-alias-p 'mule-tests-alias))) | |
| 194 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 195 (Check-Error-Message | |
| 196 error "Symbol is the canonical name of a coding system and cannot be redefined" | |
| 197 (define-coding-system-alias 'binary 'iso8859-2)) | |
| 198 (Check-Error-Message | |
| 199 error "Symbol is not a coding system alias" | |
| 200 (coding-system-aliasee 'binary)) | |
| 201 | |
| 202 (define-coding-system-alias 'mule-tests-alias 'binary) | |
| 203 (Assert (coding-system-alias-p 'mule-tests-alias)) | |
| 204 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 205 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias))) | |
| 206 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias))) | |
| 207 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) | |
| 208 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos))) | |
| 209 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac))) | |
| 210 | |
| 211 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'binary)) | |
| 212 (Assert (coding-system-alias-p 'mule-tests-alias)) | |
| 213 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 214 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias))) | |
| 215 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias))) | |
| 216 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) | |
| 217 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos))) | |
| 218 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac))) | |
| 219 | |
| 220 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias) | |
| 221 (Assert (coding-system-alias-p 'nested-mule-tests-alias)) | |
| 222 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias))) | |
| 223 (Assert (eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias))) | |
| 224 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias)) | |
| 225 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias))) | |
| 226 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-unix))) | |
| 227 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos))) | |
| 228 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-mac))) | |
| 229 | |
| 230 (Check-Error-Message | |
| 231 error "Attempt to create a coding system alias loop" | |
| 232 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias)) | |
| 233 (Check-Error-Message | |
| 234 error "No such coding system" | |
| 235 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system)) | |
| 236 (Check-Error-Message | |
| 237 error "Attempt to create a coding system alias loop" | |
| 238 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias)) | |
| 239 | |
| 240 (define-coding-system-alias 'nested-mule-tests-alias nil) | |
| 241 (define-coding-system-alias 'mule-tests-alias nil) | |
| 242 (Assert (coding-system-p (find-coding-system 'binary))) | |
| 243 (Assert (coding-system-canonical-name-p 'binary)) | |
| 244 (Assert (not (coding-system-alias-p 'binary))) | |
| 245 (Assert (not (coding-system-alias-p 'mule-tests-alias))) | |
| 246 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 247 (Check-Error-Message | |
| 248 error "Symbol is the canonical name of a coding system and cannot be redefined" | |
| 249 (define-coding-system-alias 'binary 'iso8859-2)) | |
| 250 (Check-Error-Message | |
| 251 error "Symbol is not a coding system alias" | |
| 252 (coding-system-aliasee 'binary)) | |
| 253 | |
| 254 (define-coding-system-alias 'nested-mule-tests-alias nil) | |
| 255 (define-coding-system-alias 'mule-tests-alias nil) | |
| 256 | |
| 257 ;; Create alias for coding system with subsidiaries | |
| 258 (define-coding-system-alias 'mule-tests-alias 'iso-8859-7) | |
| 259 (Assert (coding-system-alias-p 'mule-tests-alias)) | |
| 260 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 261 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias))) | |
| 262 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias))) | |
| 263 (Assert (coding-system-alias-p 'mule-tests-alias-unix)) | |
| 264 (Assert (coding-system-alias-p 'mule-tests-alias-dos)) | |
| 265 (Assert (coding-system-alias-p 'mule-tests-alias-mac)) | |
| 266 | |
| 267 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'iso-8859-7)) | |
| 268 (Assert (coding-system-alias-p 'mule-tests-alias)) | |
| 269 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) | |
| 270 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias))) | |
| 271 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias))) | |
| 272 (Assert (coding-system-alias-p 'mule-tests-alias-unix)) | |
| 273 (Assert (coding-system-alias-p 'mule-tests-alias-dos)) | |
| 274 (Assert (coding-system-alias-p 'mule-tests-alias-mac)) | |
| 275 (Assert (eq (find-coding-system 'mule-tests-alias-mac) | |
| 276 (find-coding-system 'iso-8859-7-mac))) | |
| 277 | |
| 278 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias) | |
| 279 (Assert (coding-system-alias-p 'nested-mule-tests-alias)) | |
| 280 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias))) | |
| 281 (Assert (eq (get-coding-system 'iso-8859-7) | |
| 282 (get-coding-system 'nested-mule-tests-alias))) | |
| 283 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias)) | |
| 284 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias))) | |
| 285 (Assert (coding-system-alias-p 'nested-mule-tests-alias-unix)) | |
| 286 (Assert (coding-system-alias-p 'nested-mule-tests-alias-dos)) | |
| 287 (Assert (coding-system-alias-p 'nested-mule-tests-alias-mac)) | |
| 288 (Assert (eq (find-coding-system 'nested-mule-tests-alias-unix) | |
| 289 (find-coding-system 'iso-8859-7-unix))) | |
| 290 | |
| 291 (Check-Error-Message | |
| 292 error "Attempt to create a coding system alias loop" | |
| 293 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias)) | |
| 294 (Check-Error-Message | |
| 295 error "No such coding system" | |
| 296 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system)) | |
| 297 (Check-Error-Message | |
| 298 error "Attempt to create a coding system alias loop" | |
| 299 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias)) | |
| 300 | |
| 301 ;; Test dangling alias deletion | |
| 302 (define-coding-system-alias 'mule-tests-alias nil) | |
| 303 (Assert (not (coding-system-alias-p 'mule-tests-alias))) | |
| 304 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) | |
| 305 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias))) | |
| 306 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos))) | |
| 307 | |
| 442 | 308 ;;--------------------------------------------------------------- |
| 438 | 309 ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c) |
| 442 | 310 ;;--------------------------------------------------------------- |
| 438 | 311 (defun charset-char-string (charset) |
| 2026 | 312 (let (lo hi string n (gc-cons-threshold most-positive-fixnum)) |
| 438 | 313 (if (= (charset-chars charset) 94) |
| 314 (setq lo 33 hi 126) | |
| 315 (setq lo 32 hi 127)) | |
| 316 (if (= (charset-dimension charset) 1) | |
| 317 (progn | |
| 318 (setq string (make-string (1+ (- hi lo)) ??)) | |
| 319 (setq n 0) | |
| 320 (loop for j from lo to hi do | |
| 321 (progn | |
| 322 (aset string n (make-char charset j)) | |
| 323 (incf n))) | |
| 2026 | 324 (garbage-collect) |
| 438 | 325 string) |
| 326 (progn | |
| 327 (setq string (make-string (* (1+ (- hi lo)) (1+ (- hi lo))) ??)) | |
| 328 (setq n 0) | |
| 329 (loop for j from lo to hi do | |
| 330 (loop for k from lo to hi do | |
| 331 (progn | |
| 332 (aset string n (make-char charset j k)) | |
| 333 (incf n)))) | |
| 2026 | 334 (garbage-collect) |
| 438 | 335 string)))) |
| 336 | |
| 337 ;; The following two used to crash xemacs! | |
| 338 (Assert (charset-char-string 'japanese-jisx0208)) | |
| 339 (aset (make-string 9003 ??) 1 (make-char 'latin-iso8859-1 77)) | |
| 340 | |
| 341 (let ((greek-string (charset-char-string 'greek-iso8859-7)) | |
| 342 (string (make-string (* 96 60) ??))) | |
| 343 (loop for j from 0 below (length string) do | |
| 344 (aset string j (aref greek-string (mod j 96)))) | |
| 345 (loop for k in '(0 1 58 59) do | |
| 346 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string)))) | |
| 347 | |
| 348 (let ((greek-string (charset-char-string 'greek-iso8859-7)) | |
| 349 (string (make-string (* 96 60) ??))) | |
| 350 (loop for j from (1- (length string)) downto 0 do | |
| 351 (aset string j (aref greek-string (mod j 96)))) | |
| 352 (loop for k in '(0 1 58 59) do | |
| 353 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string)))) | |
| 354 | |
| 355 (let ((ascii-string (charset-char-string 'ascii)) | |
| 356 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57)))) | |
| 357 (loop for j from 0 below (length string) do | |
| 358 (aset string j (aref ascii-string (mod j 94)))) | |
| 359 (loop for k in '(0 1 58 59) do | |
| 360 (Assert (equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string)))) | |
| 361 | |
| 362 (let ((ascii-string (charset-char-string 'ascii)) | |
| 363 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57)))) | |
| 364 (loop for j from (1- (length string)) downto 0 do | |
| 365 (aset string j (aref ascii-string (mod j 94)))) | |
| 366 (loop for k in '(0 1 58 59) do | |
| 367 (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string)))) | |
| 368 | |
| 442 | 369 ;;--------------------------------------------------------------- |
| 370 ;; Test file-system character conversion (and, en passant, file ops) | |
| 371 ;;--------------------------------------------------------------- | |
| 3970 | 372 (let* ((dstroke (make-char 'latin-iso8859-2 80)) |
| 373 (latin2-string (make-string 4 dstroke)) | |
| 597 | 374 (prefix (concat (file-name-as-directory |
| 375 (file-truename (temp-directory))) | |
| 376 latin2-string)) | |
| 2026 | 377 (file-name-coding-system |
| 378 ;; 'iso-8859-X doesn't work on darwin (as of "Panther" 10.3), it | |
| 379 ;; seems to know that file-name-coding-system is definitely utf-8 | |
| 380 (if (string-match "darwin" system-configuration) | |
| 381 'utf-8 | |
| 382 'iso-8859-2)) | |
| 3970 | 383 ;; make-temp-name does stat(), which on OS X requires that you |
| 384 ;; normalise, where open() will normalise for you. Previously we | |
| 385 ;; used scaron as the Latin-2 character, and make-temp-name errored | |
| 3976 | 386 ;; on OS X. LATIN CAPITAL LETTER D WITH STROKE does not decompose. |
| 3970 | 387 (name1 (make-temp-name prefix)) |
| 388 (name2 (make-temp-name prefix))) | |
| 389 ;; This is how you suppress output from `message', called by `write-region' | |
| 3472 | 390 (Assert (not (equal name1 name2))) |
| 391 (Assert (not (file-exists-p name1))) | |
| 392 (Silence-Message | |
| 393 (write-region (point-min) (point-max) name1)) | |
| 394 (Assert (file-exists-p name1)) | |
| 395 (when (fboundp 'make-symbolic-link) | |
| 396 (make-symbolic-link name1 name2) | |
| 397 (Assert (file-exists-p name2)) | |
| 398 (Assert (equal (file-truename name2) name1)) | |
| 399 (Assert (equal (file-truename name1) name1))) | |
| 3970 | 400 (ignore-file-errors (delete-file name1) (delete-file name2))) |
| 442 | 401 |
| 402 ;; Add many more file operation tests here... | |
| 403 | |
| 404 ;;--------------------------------------------------------------- | |
| 405 ;; Test Unicode-related functions | |
| 406 ;;--------------------------------------------------------------- | |
| 407 (let* ((scaron (make-char 'latin-iso8859-2 57))) | |
| 875 | 408 ;; Used to try #x0000, but you can't change ASCII or Latin-1 |
| 409 (loop for code in '(#x0100 #x2222 #x4444 #xffff) do | |
| 442 | 410 (progn |
| 800 | 411 (set-unicode-conversion scaron code) |
| 412 (Assert (eq code (char-to-unicode scaron))) | |
| 413 (Assert (eq scaron (unicode-to-char code '(latin-iso8859-2)))))) | |
| 442 | 414 |
| 800 | 415 (Check-Error wrong-type-argument (set-unicode-conversion scaron -10000))) |
| 1195 | 416 |
| 3439 | 417 (dolist (utf-8-char |
| 418 '("\xc6\x92" ;; U+0192 LATIN SMALL LETTER F WITH HOOK | |
| 419 "\xe2\x81\x8a" ;; U+204A TIRONIAN SIGN ET | |
| 420 "\xe2\x82\xae" ;; U+20AE TUGRIK SIGN | |
| 421 "\xf0\x9d\x92\xbd" ;; U+1D4BD MATHEMATICAL SCRIPT SMALL H | |
| 422 "\xf0\x9d\x96\x93" ;; U+1D593 MATHEMATICAL BOLD FRAKTUR SMALL N | |
| 423 "\xf0\xaf\xa8\x88" ;; U+2FA08 CJK COMPATIBILITY FOR U+4BCE | |
| 424 "\xf4\x8f\xbf\xbd")) ;; U+10FFFD <Plane 16 Private Use, Last> | |
| 425 (let* ((xemacs-character (car (append | |
| 426 (decode-coding-string utf-8-char 'utf-8) | |
| 427 nil))) | |
| 428 (xemacs-charset (car (split-char xemacs-character)))) | |
| 429 | |
| 430 ;; Trivial test of the UTF-8 support of the escape-quoted character set. | |
| 431 (Assert (equal (decode-coding-string utf-8-char 'utf-8) | |
| 432 (decode-coding-string (concat "\033%G" utf-8-char) | |
| 433 'escape-quoted))) | |
| 434 | |
| 435 ;; Check that the reverse mapping holds. | |
| 436 (Assert (equal (unicode-code-point-to-utf-8-string | |
| 437 (encode-char xemacs-character 'ucs)) | |
| 438 utf-8-char)) | |
| 439 | |
| 440 ;; Check that, if this character has been JIT-allocated, it is encoded | |
| 441 ;; in escape-quoted using the corresponding UTF-8 escape. | |
| 442 (when (charset-property xemacs-charset 'encode-as-utf-8) | |
| 443 (Assert (equal (concat "\033%G" utf-8-char) | |
| 444 (encode-coding-string xemacs-character 'escape-quoted))) | |
| 445 (Assert (equal (concat "\033%G" utf-8-char) | |
| 446 (encode-coding-string xemacs-character 'ctext)))))) | |
| 447 | |
| 3952 | 448 (loop |
| 449 for (code-point encoded) | |
| 450 in '((#x10000 "\xd8\x00\xdc\x00") | |
| 451 (#x10FFFD "\xdb\xff\xdf\xfd")) | |
| 452 do (Assert (equal (encode-coding-string | |
| 453 (decode-char 'ucs code-point) 'utf-16) | |
| 454 encoded))) | |
| 455 | |
| 1195 | 456 ;;--------------------------------------------------------------- |
| 3690 | 457 ;; Regression test for a couple of CCL-related bugs. |
| 458 ;;--------------------------------------------------------------- | |
| 459 | |
| 460 (let ((ccl-vector [0 0 0 0 0 0 0 0 0])) | |
| 461 (define-ccl-program ccl-write-two-control-1-chars | |
| 462 `(1 | |
| 463 ((r0 = ,(charset-id 'control-1)) | |
| 464 (r1 = 0) | |
| 465 (write-multibyte-character r0 r1) | |
| 466 (r1 = 31) | |
| 467 (write-multibyte-character r0 r1))) | |
| 468 "CCL program that writes two control-1 multibyte characters.") | |
| 469 | |
| 470 (Assert (equal | |
| 471 (ccl-execute-on-string 'ccl-write-two-control-1-chars | |
| 472 ccl-vector "") | |
| 473 (format "%c%c" (make-char 'control-1 0) | |
| 474 (make-char 'control-1 31)))) | |
| 475 | |
| 476 (define-ccl-program ccl-unicode-two-control-1-chars | |
| 477 `(1 | |
| 478 ((r0 = ,(charset-id 'control-1)) | |
| 479 (r1 = 31) | |
| 480 (mule-to-unicode r0 r1) | |
| 481 (r4 = r0) | |
| 482 (r3 = ,(charset-id 'control-1)) | |
| 483 (r2 = 0) | |
| 484 (mule-to-unicode r3 r2))) | |
| 485 "CCL program that writes two control-1 UCS code points in r3 and r4") | |
| 486 | |
| 487 ;; Re-initialise the vector, mainly to clear the instruction counter, | |
| 488 ;; which is its last element. | |
| 489 (setq ccl-vector [0 0 0 0 0 0 0 0 0]) | |
| 490 | |
| 491 (ccl-execute-on-string 'ccl-unicode-two-control-1-chars ccl-vector "") | |
| 492 | |
| 493 (Assert (and (eq (aref ccl-vector 3) | |
| 494 (encode-char (make-char 'control-1 0) 'ucs)) | |
| 495 (eq (aref ccl-vector 4) | |
| 496 (encode-char (make-char 'control-1 31) 'ucs))))) | |
| 497 | |
| 4295 | 498 |
| 499 ;; Test the 8 bit fixed-width coding systems for round-trip | |
| 500 ;; compatibility with themselves. | |
| 501 (loop | |
| 502 for coding-system in (coding-system-list) | |
| 503 with all-possible-octets = (apply #'string | |
| 504 (loop for i from ?\x00 to ?\xFF | |
| 505 collect i)) | |
| 506 do | |
| 507 (when (and (coding-system-get coding-system '8-bit-fixed) | |
| 508 ;; Don't check the coding systems with autodetect, they are | |
| 509 ;; not round-trip compatible for the possible line-ending | |
| 510 ;; characters. | |
| 511 (string-match #r"-\(unix\|dos\|mac\)$" | |
| 512 (symbol-name coding-system))) | |
| 513 ;; These coding systems are round-trip compatible with themselves. | |
| 514 (Assert (equal (encode-coding-string | |
| 515 (decode-coding-string all-possible-octets | |
| 516 coding-system) | |
| 517 coding-system) | |
| 518 all-possible-octets)))) | |
| 519 | |
| 3690 | 520 ;;--------------------------------------------------------------- |
| 1195 | 521 ;; Test charset-in-* functions |
| 522 ;;--------------------------------------------------------------- | |
| 523 (with-temp-buffer | |
| 524 (insert-file-contents (locate-data-file "HELLO")) | |
| 3927 | 525 (Assert (equal |
| 526 ;; The sort is to make the algorithm of charsets-in-region | |
| 527 ;; irrelevant. | |
| 528 (sort (charsets-in-region (point-min) (point-max)) | |
| 4133 | 529 #'string<) |
| 3927 | 530 '(arabic-1-column arabic-2-column ascii chinese-big5-1 |
| 531 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7 | |
| 532 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212 | |
| 533 katakana-jisx0201 korean-ksc5601 latin-iso8859-1 | |
| 534 latin-iso8859-2 thai-xtis vietnamese-viscii-lower))) | |
| 535 (Assert (equal | |
| 536 (sort (charsets-in-string (buffer-substring (point-min) | |
| 1316 | 537 (point-max))) |
| 4133 | 538 #'string<) |
| 3927 | 539 '(arabic-1-column arabic-2-column ascii chinese-big5-1 |
| 540 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7 | |
| 541 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212 | |
| 542 katakana-jisx0201 korean-ksc5601 latin-iso8859-1 | |
| 543 latin-iso8859-2 thai-xtis vietnamese-viscii-lower)))) | |
| 3948 | 544 |
| 4133 | 545 ;;--------------------------------------------------------------- |
| 546 ;; Language environments, and whether the specified values are sane. | |
| 547 ;;--------------------------------------------------------------- | |
| 548 (loop | |
| 549 for language in (mapcar #'car language-info-alist) | |
| 550 with language-input-method = nil | |
| 4305 | 551 with native-coding-system = nil |
| 4133 | 552 do |
| 553 ;; s-l-e can call #'require, which says "Loading ..." | |
| 554 (Silence-Message (set-language-environment language)) | |
| 3970 | 555 (Assert (equal language current-language-environment)) |
| 4133 | 556 |
| 557 (setq language-input-method | |
| 558 (get-language-info language 'input-method)) | |
| 559 (when (and language-input-method | |
| 560 ;; #### Not robust, if more input methods besides canna are | |
| 561 ;; in core. The intention of this is that if *any* of the | |
| 562 ;; packages' input methods are available, we check that *all* | |
| 563 ;; of the language environments' input methods actually | |
| 564 ;; exist, which goes against the spirit of non-monolithic | |
| 565 ;; packages. But I don't have a better approach to this. | |
| 566 (> (length input-method-alist) 1)) | |
| 567 (Assert (assoc language-input-method input-method-alist)) | |
| 568 (Skip-Test-Unless | |
| 569 (assoc language-input-method input-method-alist) | |
| 570 "input method unavailable" | |
| 571 (format "check that IM %s can be activated" language-input-method) | |
| 572 ;; s-i-m can load files. | |
| 573 (Silence-Message | |
| 574 (set-input-method language-input-method)) | |
| 575 (Assert (equal language-input-method current-input-method)))) | |
| 576 | |
| 3970 | 577 (dolist (charset (get-language-info language 'charset)) |
| 578 (Assert (charsetp (find-charset charset)))) | |
| 579 (dolist (coding-system (get-language-info language 'coding-system)) | |
| 580 (Assert (coding-system-p (find-coding-system coding-system)))) | |
| 4305 | 581 (dolist (coding-system |
| 582 (if (listp (setq native-coding-system | |
| 583 (get-language-info language | |
| 584 'native-coding-system))) | |
| 585 native-coding-system | |
| 586 (list native-coding-system))) | |
| 4133 | 587 ;; We don't have the appropriate POSIX locales to test with a |
| 588 ;; native-coding-system that is a function. | |
| 589 (unless (functionp coding-system) | |
| 590 (Assert (coding-system-p (find-coding-system coding-system)))))) | |
| 3970 | 591 |
| 3948 | 592 (with-temp-buffer |
| 593 (flet | |
| 594 ((Assert-elc-is-escape-quoted () | |
| 595 "Assert the current buffer has an escape-quoted cookie if compiled." | |
| 596 (save-excursion | |
| 597 (let ((byte-compile-result (byte-compile-from-buffer | |
| 598 (current-buffer) nil nil)) | |
| 599 (temporary-file-name (make-temp-name | |
| 600 (expand-file-name "zjPQ2Pk" | |
| 601 (temp-directory))))) | |
| 602 (byte-compile-insert-header | |
| 603 temporary-file-name | |
| 604 (current-buffer) | |
| 605 byte-compile-result) | |
| 4133 | 606 (Assert (string-match |
| 607 "^;;;###coding system: escape-quoted" | |
| 608 (buffer-substring nil nil byte-compile-result)))))) | |
| 3948 | 609 (Assert-elc-has-no-specified-encoding () |
| 610 "Assert the current buffer has no coding cookie if compiled." | |
| 611 (save-excursion | |
| 612 (let ((byte-compile-result (byte-compile-from-buffer | |
| 613 (current-buffer) nil nil)) | |
| 614 (temporary-file-name (make-temp-name | |
| 615 (expand-file-name "zjPQ2Pk" | |
| 616 (temp-directory))))) | |
| 617 (byte-compile-insert-header | |
| 618 temporary-file-name | |
| 619 (current-buffer) | |
| 620 byte-compile-result) | |
| 621 (Assert (not (string-match | |
| 622 ";;;###coding system:" | |
| 4133 | 623 (buffer-substring nil nil |
| 624 byte-compile-result)))))))) | |
| 3948 | 625 (insert |
| 4133 | 626 ;; Create a buffer with Unicode escapes. The #'read call is at |
| 627 ;; runtime, because this file may be compiled and read in a non-Mule | |
| 628 ;; XEmacs. (But it won't be run.) | |
| 629 (read | |
| 630 "#r\" (defvar testing-mule-compilation-handling | |
| 631 (string ?\\u371E ;; kDefinition beautiful; pretty, used | |
| 3948 | 632 ;; in girl's name |
| 4133 | 633 ?\\U0002A6A9 ;; kDefinition (Cant.) sound of shouting |
| 634 ?\\U0002A65B ;; kDefinition (Cant.) decayed teeth; | |
| 3948 | 635 ;; tongue-tied |
| 4133 | 636 ?\\U00010400 ;; DESERET CAPITAL LETTER LONG I |
| 637 ?\\u3263)) ;; CIRCLED HANGUL RIEUL \"")) | |
| 3948 | 638 |
| 639 (Assert-elc-is-escape-quoted) | |
| 640 (delete-region (point-min) (point-max)) | |
| 641 | |
| 642 (insert | |
| 643 ;; This time, the buffer will contain the actual characters, because of | |
| 644 ;; u flag to the #r. | |
| 4133 | 645 (read |
| 646 "#ru\" (defvar testing-mule-compilation-handling | |
| 647 (string ?\\u371E ;; kDefinition beautiful; pretty, used | |
| 3948 | 648 ;; in girl's name |
| 4133 | 649 ?\\U0002A6A9 ;; kDefinition (Cant.) sound of shouting |
| 650 ?\\U0002A65B ;; kDefinition (Cant.) decayed teeth; | |
| 3948 | 651 ;; tongue-tied |
| 4133 | 652 ?\\U00010400 ;; DESERET CAPITAL LETTER LONG I |
| 653 ?\\u3263)) ;; CIRCLED HANGUL RIEUL \"")) | |
| 3948 | 654 |
| 655 (Assert-elc-is-escape-quoted) | |
| 656 (delete-region (point-min) (point-max)) | |
| 657 | |
| 658 (insert | |
| 659 ;; Just a single four character escape. | |
| 4133 | 660 (read |
| 661 "#r\" (defvar testing-mule-compilation-handling | |
| 662 (string ?\\u371E)) ;; kDefinition beautiful; pretty, used\"")) | |
| 3948 | 663 |
| 664 (Assert-elc-is-escape-quoted) | |
| 665 (delete-region (point-min) (point-max)) | |
| 666 | |
| 667 (insert | |
| 668 ;; Just a single eight character escape. | |
| 4133 | 669 (read |
| 670 "#r\" (defvar testing-mule-compilation-handling | |
| 671 (string ?\\U0002A65B)) ;; kDefinition (Cant.) decayed teeth;\"")) | |
| 3948 | 672 |
| 673 (Assert-elc-is-escape-quoted) | |
| 674 (delete-region (point-min) (point-max)) | |
| 675 | |
| 676 (insert | |
| 4133 | 677 ;; A single latin-1 hex digit escape No run-time #'read call, |
| 678 ;; non-Mule can handle this too. | |
| 3948 | 679 #r" (defvar testing-mule-compilation-handling |
| 4133 | 680 (string ?\xab)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK") |
| 681 | |
| 682 (Assert-elc-has-no-specified-encoding) | |
| 683 (delete-region (point-min) (point-max)) | |
| 684 | |
| 685 (insert | |
| 686 ;; A single latin-1 character. No run-time #'read call. | |
| 687 #ru" (defvar testing-mule-compilation-handling | |
| 688 (string ?\u00AB)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK\")") | |
| 3948 | 689 |
| 690 (Assert-elc-has-no-specified-encoding) | |
| 691 (delete-region (point-min) (point-max)) | |
| 692 | |
| 693 (insert | |
| 4133 | 694 ;; Just ASCII. No run-time #'read call |
| 695 #r" (defvar testing-mule-compilation-handling | |
| 696 (string ?A)) ;; LATIN CAPITAL LETTER A") | |
| 3948 | 697 |
| 698 (Assert-elc-has-no-specified-encoding) | |
| 699 (delete-region (point-min) (point-max)) | |
| 700 | |
| 4133 | 701 ;; This bug exists because the coding-cookie insertion code looks at |
| 702 ;; the input buffer, not the output buffer. | |
| 703 ;; | |
| 704 ;; It looks at the input buffer because byte-compile-dynamic and | |
| 705 ;; byte-compile-dynamic-docstrings currently need to be | |
| 706 ;; unconditionally turned off for Mule files, since dynamic | |
| 707 ;; compilation of function bodies and docstrings fails if you can't | |
| 708 ;; call (point) and trivially get the byte offset in the file. | |
| 709 ;; | |
| 710 ;; And to unconditionally turn those two features off, you need to | |
| 711 ;; know before byte-compilation whether the byte-compilation output | |
| 712 ;; file contains non-Latin-1 characters, or perhaps to check after | |
| 713 ;; compilation and redo; but we don't do the latter. | |
| 714 ;; | |
| 715 ;; To fix this bug, we need to add Mule support to | |
| 716 ;; byte-compile-dynamic and byte-compile-dynamic-docstrings. Or drop | |
| 717 ;; support for those features entirely. | |
| 3948 | 718 (insert |
| 4133 | 719 "(defvar testing-mule-compilation-handling (eval-when-compile |
| 720 (decode-char 'ucs #x371e))) ;; kDefinition beautiful; pretty, used\"") | |
| 721 (Known-Bug-Expect-Failure | |
| 722 (Assert-elc-is-escape-quoted)) | |
| 3948 | 723 (delete-region (point-min) (point-max)))) |
|
4318
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
724 |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
725 (Known-Bug-Expect-Error |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
726 invalid-constant |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
727 (loop |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
728 for i from #x0 to #x10FFFF |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
729 with exceptions = #s(range-table type start-closed-end-closed |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
730 data ((#xFFFE #xFFFF) t |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
731 (#xFDD0 #xFDEF) t |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
732 (#xD800 #xDBFF) t |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
733 (#xDC00 #xDFFF) t)) |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
734 do (unless (get-range-table i exceptions) |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
735 (read (format (if (> i #xFFFF) #r"?\U%08X" #r"?\u%04X") i))) |
|
4d0f773d5e21
Fix the test failures introduced by the non-ISO-2022 coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4305
diff
changeset
|
736 finally return t)) |
| 434 | 737 ) |