cgit.sxemacs.org Git - sxemacs/blob - tests/automated/mule-tests.el

   1 ;; Copyright (C) 1999 Free Software Foundation, Inc.
   2
   3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org>
   4 ;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>,
   5 ;;              Martin Buchholz <martin@xemacs.org>
   6 ;; Created: 1999
   7 ;; Keywords: tests
   8
   9 ;; This file is part of SXEmacs.
  10
  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.
  15
  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.
  20
  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/>.
  23
  24 ;;; Synched up with: Not in FSF.
  25
  26 ;;; Commentary:
  27
  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.
  30
  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.
  33
  34 ;;-----------------------------------------------------------------
  35 ;; Test whether all legal chars may be safely inserted to a buffer.
  36 ;;-----------------------------------------------------------------
  37
  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.
  43
  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)))
  47         (list nil)
  48         (i 0))
  49     (while (< i max)
  50       (and (not for-test-harness)
  51            (zerop (% i 1000))
  52            (message "%d" i))
  53       (and (int-char i)
  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)))
  57       (setq i (1+ i)))
  58     (let ((string (apply #'string (nreverse list))))
  59       (if for-test-harness
  60           ;; For use with test-harness, use Assert and a temporary
  61           ;; buffer.
  62           (with-temp-buffer
  63             (insert string)
  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"))
  68         (erase-buffer)
  69         (buffer-disable-undo)
  70         (insert string)
  71         (assert (equal (buffer-string) string))))))
  72
  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.
  77 (test-chars t)
  78
  79 ;;-----------------------------------------------------------------
  80 ;; Test string modification functions that modify the length of a char.
  81 ;;-----------------------------------------------------------------
  82
  83 (when (featurep 'mule)
  84   ;;---------------------------------------------------------------
  85   ;; Test fillarray
  86   ;;---------------------------------------------------------------
  87   (macrolet
  88       ((fillarray-test
  89         (charset1 charset2)
  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))
 101
 102   ;; Test aset
 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))))
 106
 107   ;;---------------------------------------------------------------
 108   ;; Test coding system functions
 109   ;;---------------------------------------------------------------
 110
 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)))
 117   (Check-Error-Message
 118    error "Symbol is the canonical name of a coding system and cannot be redefined"
 119    (define-coding-system-alias 'binary 'iso8859-2))
 120   (Check-Error-Message
 121    error "Symbol is not a coding system alias"
 122    (coding-system-aliasee 'binary))
 123
 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)))
 132
 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)))
 141
 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)))
 151
 152   (Check-Error-Message
 153    error "Attempt to create a coding system alias loop"
 154    (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
 155   (Check-Error-Message
 156    error "No such coding system"
 157    (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
 158   (Check-Error-Message
 159    error "Attempt to create a coding system alias loop"
 160    (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
 161
 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)))
 169   (Check-Error-Message
 170    error "Symbol is the canonical name of a coding system and cannot be redefined"
 171    (define-coding-system-alias 'binary 'iso8859-2))
 172   (Check-Error-Message
 173    error "Symbol is not a coding system alias"
 174    (coding-system-aliasee 'binary))
 175
 176   (define-coding-system-alias 'nested-mule-tests-alias nil)
 177   (define-coding-system-alias 'mule-tests-alias nil)
 178
 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))
 188
 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)))
 199
 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)))
 212
 213   (Check-Error-Message
 214    error "Attempt to create a coding system alias loop"
 215    (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
 216   (Check-Error-Message
 217    error "No such coding system"
 218    (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
 219   (Check-Error-Message
 220    error "Attempt to create a coding system alias loop"
 221    (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
 222
 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)))
 229
 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)
 236           (setq lo 33 hi 126)
 237         (setq lo 32 hi 127))
 238       (if (= (charset-dimension charset) 1)
 239           (progn
 240             (setq string (make-string (1+ (- hi lo)) ??))
 241             (setq n 0)
 242             (loop for j from lo to hi do
 243               (progn
 244                 (aset string n (make-char charset j))
 245                 (incf n)))
 246             (garbage-collect)
 247             string)
 248         (progn
 249           (setq string (make-string (* (1+ (- hi lo)) (1+ (- hi lo))) ??))
 250           (setq n 0)
 251           (loop for j from lo to hi do
 252             (loop for k from lo to hi do
 253               (progn
 254                 (aset string n (make-char charset j k))
 255                 (incf n))))
 256           (garbage-collect)
 257           string))))
 258
 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))
 262
 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)))
 269
 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)))
 276
 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)))
 283
 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)))
 290
 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)))
 298                          latin2-string))
 299          (name1 (make-temp-name prefix))
 300          (name2 (make-temp-name prefix))
 301          (file-name-coding-system 'iso-8859-2))
 302     (Silence-Message
 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))
 308              (require 'un-define)
 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) (file-truename name1))
 317         (Assert-Equal (file-truename name2) name1)
 318         (Assert-Equal (file-truename name1) name1))
 319
 320       (ignore-file-errors (delete-file name1) (delete-file name2))))
 321
 322   ;; Add many more file operation tests here...
 323
 324   ;;---------------------------------------------------------------
 325   ;; Test Unicode-related functions
 326   ;;---------------------------------------------------------------
 327   (let* ((scaron (make-char 'latin-iso8859-2 57)))
 328     (loop for code in '(#x0000 #x2222 #x4444 #xffff) do
 329       (progn
 330         (set-ucs-char code scaron)
 331         (Assert (eq scaron (ucs-char code)))))
 332
 333     (Assert (eq nil (set-ucs-char #x1ffff scaron)))
 334     (Check-Error wrong-type-argument (set-ucs-char -10000 scaron)))
 335
 336   )