comparison lisp/international/mule-util.el @ 18299:c6f35cac24b4

(coding-system-parent): New function. (coding-system-lessp): New function. (coding-system-list): Sort coding systems by coding-system-lessp. An element of returned list is always coing system, never be a cons. (modify-coding-system-alist): Renamed from set-coding-system-alist. (prefer-coding-system): New function. (compose-chars-component): But fix for handling a composite character of no compositon rule.

18298:3d036a21fc93

	      (throw 'lookup-nested-alist-tag t))))
	;; KEYSEQ is too long.
	(if nil-for-too-long nil i)
      alist)))

;; Coding system related functions.

;;;###autoload
(defun coding-system-list (&optional base-only)
  "Return a list of all existing coding systems.
If optional arg BASE-ONLY is non-nil, each element of the list
is a base coding system or a list of coding systems.
In the latter case, the first element is a base coding system,
and the remainings are aliases of it."
  (let (l)
    (mapatoms (lambda (x) (if (get x 'coding-system) (setq l (cons x l)))))
    (if (not base-only)
	l
      (let* ((codings (sort l (function
			       (lambda (x y)
				 (<= (coding-system-mnemonic x)
				     (coding-system-mnemonic y))))))
	     (tail (cons nil codings))
	     (aliases nil)		; ((BASE ALIAS ...) ...)
	     base coding)
	;; At first, remove subsidiary coding systems (eol variants) and
	;; move alias coding systems to ALIASES.
	(while (cdr tail)
	  (setq coding (car (cdr tail)))
	  (if (get coding 'eol-variant)
	      (setcdr tail (cdr (cdr tail)))
	    (setq base (coding-system-base coding))
	    (if (and (not (eq coding base))
		     (coding-system-equal coding base))
		(let ((slot (memq base aliases)))
		  (setcdr tail (cdr (cdr tail)))
		  (if slot
		      (setcdr slot (cons coding (cdr slot)))
		    (setq aliases (cons (list base coding) aliases))))
	      (setq tail (cdr tail)))))
	;; Then, replace a coding system who has aliases with a list.
	(setq tail codings)
	(while tail
	  (let ((alias (assq (car tail) aliases)))
	    (if alias
		(setcar tail alias)))
	  (setq tail (cdr tail)))
	codings))))

;;;###autoload
(defun coding-system-base (coding-system)
  "Return a base of CODING-SYSTEM.
The base is a coding system of which coding-system property is a
coding-spec (see the function `make-coding-system')."
  (let ((coding-spec (get coding-system 'coding-system)))
    (if (vectorp coding-spec)
	coding-system
      (coding-system-base coding-spec))))

;;;###autoload
(defun coding-system-plist (coding-system)
  "Return property list of CODING-SYSTEM."
  (let ((found nil)

	  'pre-write-conversion pre-write-conversion
	  'unification-table unification-table)))

;;;###autoload
(defun coding-system-equal (coding-system-1 coding-system-2)
  "Return t if and only of CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
Two coding systems are identical if two symbols are equal
or one is an alias of the other."
  (equal (coding-system-plist coding-system-1)
	 (coding-system-plist coding-system-2)))

;;;###autoload
(defun coding-system-eol-type-mnemonic (coding-system)
  "Return mnemonic letter of eol-type of CODING-SYSTEM."
  (let ((eol-type (coding-system-eol-type coding-system)))
    (cond ((vectorp eol-type) eol-mnemonic-undecided)
	  ((eq eol-type 0) eol-mnemonic-unix)
	  ((eq eol-type 1) eol-mnemonic-unix)
	  ((eq eol-type 2) eol-mnemonic-unix)
	  (t ?-))))

;;;###autoload
(defun coding-system-post-read-conversion (coding-system)
  "Return post-read-conversion property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'post-read-conversion)
	   (coding-system-post-read-conversion
	    (get coding-system 'coding-system)))))

;;;###autoload
(defun coding-system-pre-write-conversion (coding-system)
  "Return pre-write-conversion property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'pre-write-conversion)
	   (coding-system-pre-write-conversion
	    (get coding-system 'coding-system)))))

;;;###autoload
(defun coding-system-unification-table (coding-system)
  "Return unification-table property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'unification-table)
	   (coding-system-unification-table
	    (get coding-system 'coding-system)))))


;;; Composite charcater manipulations.

;;;###autoload

(defun compose-chars-component (ch)
  (if (< ch 128)
      (format "\240%c" (+ ch 128))
    (let ((str (char-to-string ch)))
      (if (cmpcharp ch)
	  (if (/= (aref str 1) ?\xFF)
	      (error "Char %c can't be composed" ch)
	    (substring str 2))
	(aset str 0 (+ (aref str 0) ?\x20))
	str))))

;; Return a string for composition rule RULE to be embedded in
;; multibyte form of composite character.

18299:c6f35cac24b4

	      (throw 'lookup-nested-alist-tag t))))
	;; KEYSEQ is too long.
	(if nil-for-too-long nil i)
      alist)))


;; Coding system related functions.

;;;###autoload
(defun coding-system-base (coding-system)
  "Return a base of CODING-SYSTEM.
The base is a coding system of which coding-system property is a
coding-spec (see the function `make-coding-system')."
  (let ((coding-spec (get coding-system 'coding-system)))
    (if (vectorp coding-spec)
	coding-system
      (coding-system-base coding-spec))))

;;;###autoload
(defun coding-system-eol-type-mnemonic (coding-system)
  "Return mnemonic letter of eol-type of CODING-SYSTEM."
  (let ((eol-type (coding-system-eol-type coding-system)))
    (cond ((vectorp eol-type) eol-mnemonic-undecided)
	  ((eq eol-type 0) eol-mnemonic-unix)
	  ((eq eol-type 1) eol-mnemonic-unix)
	  ((eq eol-type 2) eol-mnemonic-unix)
	  (t ?-))))

;;;###autoload
(defun coding-system-post-read-conversion (coding-system)
  "Return post-read-conversion property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'post-read-conversion)
	   (coding-system-post-read-conversion
	    (get coding-system 'coding-system)))))

;;;###autoload
(defun coding-system-pre-write-conversion (coding-system)
  "Return pre-write-conversion property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'pre-write-conversion)
	   (coding-system-pre-write-conversion
	    (get coding-system 'coding-system)))))

;;;###autoload
(defun coding-system-unification-table (coding-system)
  "Return unification-table property of CODING-SYSTEM."
  (and coding-system
       (symbolp coding-system)
       (or (get coding-system 'unification-table)
	   (coding-system-unification-table
	    (get coding-system 'coding-system)))))

;;;###autoload
(defun coding-system-parent (coding-system)
  "Return parent of CODING-SYSTEM."
  (let ((parent (get coding-system 'parent-coding-system)))
    (and parent
	 (or (coding-system-parent parent)
	     parent))))

(defun coding-system-lessp (x y)
  (cond ((eq x 'no-conversion) t)
	((eq y 'no-conversion) nil)
	((eq x 'emacs-mule) t)
	((eq y 'emacs-mule) nil)
	((eq x 'undecided) t)
	((eq y 'undecided) nil)
	(t (let ((c1 (coding-system-mnemonic x))
		 (c2 (coding-system-mnemonic y)))
	     (or (< (downcase c1) (downcase c2))
		 (and (not (> (downcase c1) (downcase c2)))
		      (< c1 c2)))))))

;;;###autoload
(defun coding-system-list (&optional base-only)
  "Return a list of all existing coding systems.
If optional arg BASE-ONLY is non-nil, only base coding systems are listed."
  (let (l)
    (mapatoms (lambda (x) (if (get x 'coding-system) (setq l (cons x l)))))
    (let* ((codings (sort l 'coding-system-lessp))
	   (tail (cons nil codings))
	   coding)
      ;; At first, remove subsidiary coding systems (eol variants) and
      ;; alias coding systems (if necessary).
      (while (cdr tail)
	(setq coding (car (cdr tail)))
	(if (or (get coding 'eol-variant)
		(and base-only (coding-system-parent coding)))
	    (setcdr tail (cdr (cdr tail)))
	  (setq tail (cdr tail))))
      codings)))

;;;###autoload
(defun modify-coding-system-alist (target-type regexp coding-system)
  "Modify one of look up tables for finding a coding system on I/O operation.
There are three of such tables, file-coding-system-alist,
process-coding-system-alist, and network-coding-system-alist.

TARGET-TYPE specifies which of them to modify.
If it is `file', it affects file-coding-system-alist (which see).
If it is `process', it affects process-coding-system-alist (which see).
If it is `network', it affects network-codign-system-alist (which see).

REGEXP is a regular expression matching a target of I/O operation.
The target is a file name if TARGET-TYPE is `file', a program name if
TARGET-TYPE is `process', or a network service name or a port number
to connect to if TARGET-TYPE is `network'.

CODING-SYSTEM is a coding system to perform code conversion on the I/O
operation, or a cons of coding systems for decoding and encoding
respectively, or a function symbol which returns the cons."
  (or (memq target-type '(file process network))
      (error "Invalid target type: %s" target-type))
  (or (stringp regexp)
      (and (eq target-type 'network) (integerp regexp))
      (error "Invalid regular expression: %s" regexp))
  (if (symbolp coding-system)
      (if (not (fboundp coding-system))
	  (progn
	    (check-coding-system coding-system)
	    (setq coding-system (cons coding-system coding-system))))
    (check-coding-system (car coding-system))
    (check-coding-system (cdr coding-system)))
  (cond ((eq target-type 'file)
	 (let ((slot (assoc regexp file-coding-system-alist)))
	   (if slot
	       (setcdr slot coding-system)
	     (setq file-coding-system-alist
		   (cons (cons regexp coding-system)
			 file-coding-system-alist)))))
	((eq target-type 'process)
	 (let ((slot (assoc regexp process-coding-system-alist)))
	   (if slot
	       (setcdr slot coding-system)
	     (setq process-coding-system-alist
		   (cons (cons regexp coding-system)
			 process-coding-system-alist)))))
	(t
	 (let ((slot (assoc regexp network-coding-system-alist)))
	   (if slot
	       (setcdr slot coding-system)
	     (setq network-coding-system-alist
		   (cons (cons regexp coding-system)
			 network-coding-system-alist)))))))

;;;###autoload
(defun coding-system-plist (coding-system)
  "Return property list of CODING-SYSTEM."
  (let ((found nil)

	  'pre-write-conversion pre-write-conversion
	  'unification-table unification-table)))

;;;###autoload
(defun coding-system-equal (coding-system-1 coding-system-2)
  "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
Two coding systems are identical if two symbols are equal
or one is an alias of the other."
  (or (eq coding-system-1 coding-system-2)
      (equal (coding-system-plist coding-system-1)
	     (coding-system-plist coding-system-2))))

;;;###autoload
(defun prefer-coding-system (coding-system)
  (interactive "zPrefered coding system: ")
  (if (not (and coding-system (coding-system-p coding-system)))
      (error "Invalid coding system `%s'" coding-system))
  (let ((coding-category (coding-system-category coding-system))
	(parent (coding-system-parent coding-system)))
    (if (not coding-category)
	;; CODING-SYSTEM is no-conversion or undecided.
	(error "Can't prefer the coding system `%s'" coding-system))
    (set coding-category (or parent coding-system))
    (if (not (eq coding-category (car coding-category-list)))
	;; We must change the order.
	(setq coding-category-list
	      (cons coding-category
		    (delq coding-category coding-category-list))))
    (if (and parent (interactive-p))
	(message "Highest priority is set to %s (parent of %s)"
		 parent coding-system))
    ))


;;; Composite charcater manipulations.

;;;###autoload

(defun compose-chars-component (ch)
  (if (< ch 128)
      (format "\240%c" (+ ch 128))
    (let ((str (char-to-string ch)))
      (if (cmpcharp ch)
	  (substring str (if (= (aref str 1) ?\xFF) 2 1))
	(aset str 0 (+ (aref str 0) ?\x20))
	str))))

;; Return a string for composition rule RULE to be embedded in
;; multibyte form of composite character.