From e7ef8fa272460322c6947ae188d97e772d0673f4 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Tue, 10 Jun 1997 00:56:20 +0000 Subject: (set-coding-system-alist): Deleted. (string-to-sequence): Doc string modified. (coding-system-list): Add optional arg BASE-ONLY. (coding-system-base): New function. (coding-system-plist): New function. (coding-system-equal): New function. (coding-system-unification-table): New function. --- lisp/international/mule-util.el | 186 +++++++++++++++++++++++++++------------- 1 file changed, 125 insertions(+), 61 deletions(-) diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el index 2cd442c47b6..97404446c69 100644 --- a/lisp/international/mule-util.el +++ b/lisp/international/mule-util.el @@ -30,8 +30,7 @@ ;;;###autoload (defun string-to-sequence (string type) "Convert STRING to a sequence of TYPE which contains characters in STRING. -TYPE should be `list' or `vector'. -Multibyte characters are conserned." +TYPE should be `list' or `vector'." (or (eq type 'list) (eq type 'vector) (error "Invalid type: %s" type)) (let* ((len (length string)) @@ -200,67 +199,132 @@ Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil ;; Coding system related functions. ;;;###autoload -(defun set-coding-system-alist (target-type regexp coding-system - &optional operation) - "Update `coding-system-alist' according to the arguments. -TARGET-TYPE specifies a type of the target: `file', `process', or `network'. - TARGET-TYPE tells which slots of coding-system-alist should be affected. - If `file', it affects slots for insert-file-contents and write-region. - If `process', it affects slots for call-process, call-process-region, and - start-process. - If `network', it affects a slot for open-network-process. -REGEXP is a regular expression matching a target of I/O operation. -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. -Optional arg OPERATION if non-nil specifies directly one of slots above. - The valid value is: insert-file-contents, write-region, - call-process, call-process-region, start-process, or open-network-stream. -If OPERATION is specified, TARGET-TYPE is ignored. -See the documentation of `coding-system-alist' for more detail." - (or (stringp regexp) - (error "Invalid regular expression: %s" regexp)) - (or (memq target-type '(file process network)) - (error "Invalid target type: %s" target-type)) - (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))) - (let ((op-list (if operation (list operation) - (cond ((eq target-type 'file) - '(insert-file-contents write-region)) - ((eq target-type 'process) - '(call-process call-process-region start-process)) - (t ; i.e. (eq target-type network) - '(open-network-stream))))) - slot) - (while op-list - (setq slot (assq (car op-list) coding-system-alist)) - (if slot - (let ((chain (cdr slot))) - (if (catch 'tag - (while chain - (if (string= regexp (car (car chain))) - (progn - (setcdr (car chain) coding-system) - (throw 'tag nil))) - (setq chain (cdr chain))) - t) - (setcdr slot (cons (cons regexp coding-system) (cdr slot))))) - (setq coding-system-alist - (cons (cons (car op-list) (list (cons regexp coding-system))) - coding-system-alist))) - (setq op-list (cdr op-list))))) - -;;;###autoload -(defun coding-system-list () - "Return a list of all existing coding systems." +(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))))) - 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) + coding-spec eol-type + post-read-conversion pre-write-conversion + unification-table) + (while (not found) + (or eol-type + (setq eol-type (get coding-system 'eol-type))) + (or post-read-conversion + (setq post-read-conversion + (get coding-system 'post-read-conversion))) + (or pre-write-conversion + (setq pre-write-conversion + (get coding-system 'pre-write-conversion))) + (or unification-table + (setq unification-table + (get coding-system 'unification-table))) + (setq coding-spec (get coding-system 'coding-system)) + (if (and coding-spec (symbolp coding-spec)) + (setq coding-system coding-spec) + (setq found t))) + (if (not coding-spec) + (error "Invalid coding system: %s" coding-system)) + (list 'coding-spec coding-spec + 'eol-type eol-type + 'post-read-conversion post-read-conversion + '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. -- cgit v1.2.1