;; Copyright (C) 1999 Free Software Foundation, Inc.
;; Author: Hrvoje Niksic <hniksic@xemacs.org>
-;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
+;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>,
+;; Martin Buchholz <martin@xemacs.org>
;; Created: 1999
;; Keywords: tests
;; Test some Mule functionality (most of these remain to be written) .
;; See test-harness.el for instructions on how to run these tests.
+;; This file will be (read)ed by a non-mule XEmacs, so don't use
+;; literal non-Latin1 characters. Use (make-char) instead.
+
;;-----------------------------------------------------------------
;; Test whether all legal chars may be safely inserted to a buffer.
;;-----------------------------------------------------------------
;; time-consuming tests like this one run twice, once interpreted and
;; once compiled, for no good reason.
(test-chars t)
+
+;;-----------------------------------------------------------------
+;; Test string modification functions that modify the length of a char.
+;;-----------------------------------------------------------------
+
+(when (featurep 'mule)
+ ;;---------------------------------------------------------------
+ ;; Test fillarray
+ ;;---------------------------------------------------------------
+ (macrolet
+ ((fillarray-test
+ (charset1 charset2)
+ (let ((char1 (make-char charset1 69))
+ (char2 (make-char charset2 69)))
+ `(let ((string (make-string 1000 ,char1)))
+ (fillarray string ,char2)
+ (Assert (eq (aref string 0) ,char2))
+ (Assert (eq (aref string (1- (length string))) ,char2))
+ (Assert (eq (length string) 1000))))))
+ (fillarray-test ascii latin-iso8859-1)
+ (fillarray-test ascii latin-iso8859-2)
+ (fillarray-test latin-iso8859-1 ascii)
+ (fillarray-test latin-iso8859-2 ascii))
+
+ ;; Test aset
+ (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69))))
+ (aset string 0 (make-char 'latin-iso8859-2 42))
+ (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69))))
+
+ ;;---------------------------------------------------------------
+ ;; Test coding system functions
+ ;;---------------------------------------------------------------
+
+ ;; Create alias for coding system without subsidiaries
+ (Assert (coding-system-p (find-coding-system 'binary)))
+ (Assert (coding-system-canonical-name-p 'binary))
+ (Assert (not (coding-system-alias-p 'binary)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Check-Error-Message
+ error "Symbol is the canonical name of a coding system and cannot be redefined"
+ (define-coding-system-alias 'binary 'iso8859-2))
+ (Check-Error-Message
+ error "Symbol is not a coding system alias"
+ (coding-system-aliasee 'binary))
+
+ (define-coding-system-alias 'mule-tests-alias 'binary)
+ (Assert (coding-system-alias-p 'mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
+ (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
+
+ (define-coding-system-alias 'mule-tests-alias (get-coding-system 'binary))
+ (Assert (coding-system-alias-p 'mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
+ (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
+
+ (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
+ (Assert (coding-system-alias-p 'nested-mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
+ (Assert (eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias)))
+ (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
+ (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
+ (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-unix)))
+ (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
+ (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-mac)))
+
+ (Check-Error-Message
+ error "Attempt to create a coding system alias loop"
+ (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
+ (Check-Error-Message
+ error "No such coding system"
+ (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
+ (Check-Error-Message
+ error "Attempt to create a coding system alias loop"
+ (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
+
+ (define-coding-system-alias 'nested-mule-tests-alias nil)
+ (define-coding-system-alias 'mule-tests-alias nil)
+ (Assert (coding-system-p (find-coding-system 'binary)))
+ (Assert (coding-system-canonical-name-p 'binary))
+ (Assert (not (coding-system-alias-p 'binary)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Check-Error-Message
+ error "Symbol is the canonical name of a coding system and cannot be redefined"
+ (define-coding-system-alias 'binary 'iso8859-2))
+ (Check-Error-Message
+ error "Symbol is not a coding system alias"
+ (coding-system-aliasee 'binary))
+
+ (define-coding-system-alias 'nested-mule-tests-alias nil)
+ (define-coding-system-alias 'mule-tests-alias nil)
+
+ ;; Create alias for coding system with subsidiaries
+ (define-coding-system-alias 'mule-tests-alias 'iso-8859-7)
+ (Assert (coding-system-alias-p 'mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
+ (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
+ (Assert (coding-system-alias-p 'mule-tests-alias-unix))
+ (Assert (coding-system-alias-p 'mule-tests-alias-dos))
+ (Assert (coding-system-alias-p 'mule-tests-alias-mac))
+
+ (define-coding-system-alias 'mule-tests-alias (get-coding-system 'iso-8859-7))
+ (Assert (coding-system-alias-p 'mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
+ (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
+ (Assert (coding-system-alias-p 'mule-tests-alias-unix))
+ (Assert (coding-system-alias-p 'mule-tests-alias-dos))
+ (Assert (coding-system-alias-p 'mule-tests-alias-mac))
+ (Assert (eq (find-coding-system 'mule-tests-alias-mac)
+ (find-coding-system 'iso-8859-7-mac)))
+
+ (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
+ (Assert (coding-system-alias-p 'nested-mule-tests-alias))
+ (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
+ (Assert (eq (get-coding-system 'iso-8859-7)
+ (get-coding-system 'nested-mule-tests-alias)))
+ (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
+ (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
+ (Assert (coding-system-alias-p 'nested-mule-tests-alias-unix))
+ (Assert (coding-system-alias-p 'nested-mule-tests-alias-dos))
+ (Assert (coding-system-alias-p 'nested-mule-tests-alias-mac))
+ (Assert (eq (find-coding-system 'nested-mule-tests-alias-unix)
+ (find-coding-system 'iso-8859-7-unix)))
+
+ (Check-Error-Message
+ error "Attempt to create a coding system alias loop"
+ (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
+ (Check-Error-Message
+ error "No such coding system"
+ (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
+ (Check-Error-Message
+ error "Attempt to create a coding system alias loop"
+ (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
+
+ ;; Test dangling alias deletion
+ (define-coding-system-alias 'mule-tests-alias nil)
+ (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ (Assert (not (coding-system-alias-p 'nested-mule-tests-alias)))
+ (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
+
+ ;;---------------------------------------------------------------
+ ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c)
+ ;;---------------------------------------------------------------
+ (defun charset-char-string (charset)
+ (let (lo hi string n)
+ (if (= (charset-chars charset) 94)
+ (setq lo 33 hi 126)
+ (setq lo 32 hi 127))
+ (if (= (charset-dimension charset) 1)
+ (progn
+ (setq string (make-string (1+ (- hi lo)) ??))
+ (setq n 0)
+ (loop for j from lo to hi do
+ (progn
+ (aset string n (make-char charset j))
+ (incf n)))
+ string)
+ (progn
+ (setq string (make-string (* (1+ (- hi lo)) (1+ (- hi lo))) ??))
+ (setq n 0)
+ (loop for j from lo to hi do
+ (loop for k from lo to hi do
+ (progn
+ (aset string n (make-char charset j k))
+ (incf n))))
+ string))))
+
+ ;; The following two used to crash xemacs!
+ (Assert (charset-char-string 'japanese-jisx0208))
+ (aset (make-string 9003 ??) 1 (make-char 'latin-iso8859-1 77))
+
+ (let ((greek-string (charset-char-string 'greek-iso8859-7))
+ (string (make-string (* 96 60) ??)))
+ (loop for j from 0 below (length string) do
+ (aset string j (aref greek-string (mod j 96))))
+ (loop for k in '(0 1 58 59) do
+ (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
+
+ (let ((greek-string (charset-char-string 'greek-iso8859-7))
+ (string (make-string (* 96 60) ??)))
+ (loop for j from (1- (length string)) downto 0 do
+ (aset string j (aref greek-string (mod j 96))))
+ (loop for k in '(0 1 58 59) do
+ (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
+
+ (let ((ascii-string (charset-char-string 'ascii))
+ (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
+ (loop for j from 0 below (length string) do
+ (aset string j (aref ascii-string (mod j 94))))
+ (loop for k in '(0 1 58 59) do
+ (Assert (equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string))))
+
+ (let ((ascii-string (charset-char-string 'ascii))
+ (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
+ (loop for j from (1- (length string)) downto 0 do
+ (aset string j (aref ascii-string (mod j 94))))
+ (loop for k in '(0 1 58 59) do
+ (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string))))
+
+ ;;---------------------------------------------------------------
+ ;; Test file-system character conversion (and, en passant, file ops)
+ ;;---------------------------------------------------------------
+ (let* ((scaron (make-char 'latin-iso8859-2 57))
+ (latin2-string (make-string 4 scaron))
+ (prefix (concat (file-name-as-directory
+ (file-truename (temp-directory)))
+ latin2-string))
+ (name1 (make-temp-name prefix))
+ (name2 (make-temp-name prefix))
+ (file-name-coding-system 'iso-8859-2))
+ ;; This is how you suppress output from `message', called by `write-region'
+ (flet ((append-message (&rest args) ()))
+ (Assert (not (equal name1 name2)))
+ (Assert (not (file-exists-p name1)))
+ (write-region (point-min) (point-max) name1)
+ (Assert (file-exists-p name1))
+ (when (fboundp 'make-symbolic-link)
+ (make-symbolic-link name1 name2)
+ (Assert (file-exists-p name2))
+ (Assert (equal (file-truename name2) name1))
+ (Assert (equal (file-truename name1) name1)))
+
+ (ignore-file-errors (delete-file name1) (delete-file name2))))
+
+ ;; Add many more file operation tests here...
+
+ ;;---------------------------------------------------------------
+ ;; Test Unicode-related functions
+ ;;---------------------------------------------------------------
+ (let* ((scaron (make-char 'latin-iso8859-2 57)))
+ (loop for code in '(#x0000 #x2222 #x4444 #xffff) do
+ (progn
+ (set-ucs-char code scaron)
+ (Assert (eq scaron (ucs-char code)))))
+
+ (Assert (eq nil (set-ucs-char #x1ffff scaron)))
+ (Check-Error wrong-type-argument (set-ucs-char -10000 scaron)))
+
+ )
projects / chise / xemacs-chise.git.1 / blobdiff