From 54b226f7e59fd83c0f83dc0e76c6dac99d19a1c3 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Thu, 22 Jan 1998 01:42:20 +0000 Subject: [PATCH] (set-language-info): Doc-string describes `coding-priority' KEY. (set-language-environment-coding-systems): New function. (list-subset-p): New function. (select-safe-coding-system): New function. (set-language-info): New optional args DESCRIBE-MAP and SETUP-MAP. (set-language-info-alist): New optionla arg PARENTS. Call set-language-info with apropriate DESCRIBE-MAP and SETUP-MAP args. (set-language-environment-coding-systems): New function. (prefer-coding-system): Call update-iso-coding-systems. --- lisp/international/mule-cmds.el | 215 ++++++++++++++++++++++++++------ 1 file changed, 179 insertions(+), 36 deletions(-) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 583f0d09c6d..088e388a139 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -213,6 +213,7 @@ This also sets the following values: ;; CODING-SYSTEM is no-conversion or undecided. (error "Can't prefer the coding system `%s'" coding-system)) (set coding-category (or base coding-system)) + (update-iso-coding-systems) (if (not (eq coding-category (car coding-category-list))) ;; We must change the order. (setq coding-category-list @@ -223,6 +224,113 @@ This also sets the following values: base coding-system)) (set-default-coding-systems (or base coding-system)))) +(defun list-subset-p (list1 list2) + "Return non-nil if all elements in LIST1 are included in LIST2. +Comparison done with EQ." + (catch 'tag + (while list1 + (or (memq (car list1) list2) + (throw 'tag nil)) + (setq list1 (cdr list1))) + t)) + +(defun find-safe-coding-system (from to) + "Return a list of proper coding systems to encode a text between FROM and TO. +All coding systems in the list can safely encode any multibyte characters +in the text. + +If the text contains no multibyte charcters, return a list of a single +element `undecided'. + +Kludgy feature: if FROM is a string, the string is the target text, +and TO is ignored." + (let ((charset-list (if (stringp from) (find-charset-string from) + (find-charset-region from to)))) + (if (and (= (length charset-list) 1) + (eq 'ascii (car charset-list))) + '(undecided) + (let ((l coding-system-list) + (prefered-codings + (mapcar (function + (lambda (x) + (get-charset-property x 'prefered-coding-system))) + charset-list)) + codings coding safe) + (while l + (setq coding (car l) l (cdr l)) + (if (and (eq coding (coding-system-base coding)) + (setq safe (coding-system-get coding 'safe-charsets)) + (or (eq safe t) + (list-subset-p charset-list safe))) + ;; We put the higher priority to coding systems included + ;; in PREFERED-CODINGS, and within them, put the higher + ;; priority to coding systems which support smaller + ;; number of charsets. + (let ((priority + (logior (if (coding-system-get coding 'mime-charset) + 256 0) + (if (memq coding prefered-codings) 128 0) + (if (> (coding-system-type coding) 0) 64 0) + (if (consp safe) (- 64 (length safe)) 0)))) + (setq codings (cons (cons priority coding) codings))))) + (mapcar 'cdr + (sort codings (function (lambda (x y) (> (car x) (car y)))))) + )))) + +(defun select-safe-coding-system (from to &optional default-coding-system) + "Return a coding system which can encode a text between FROM and TO. + +Optional arg DEFAULT-CODING-SYSTEM specifies a coding system to be +checked at first. If omitted, buffer-file-coding-system of the +current buffer is used. + +If the text contains some multibyte characters and +DEFAULT-CODING-SYSTEM can't encode them, ask a user to select one from +a list of coding systems which can encode the text, and return the +selected one. + +In other cases, return DEFAULT-CODING-SYSTEM. + +Kludgy feature: if FROM is a string, the string is the target text, +and TO is ignored." + (or default-coding-system + (setq default-coding-system buffer-file-coding-system)) + (let ((safe-coding-systems (find-safe-coding-system from to))) + (if (or (eq (car safe-coding-systems) 'undecided) + (and default-coding-system + (memq (coding-system-base default-coding-system) + safe-coding-systems))) + default-coding-system + + ;; Ask a user to select a proper coding system. + (save-window-excursion + ;; At first, show a helpful message. + (with-output-to-temp-buffer "*Warning*" + (save-excursion + (set-buffer standard-output) + (insert (format "\ +The target text contains a multibyte character which can't be +encoded safely by the coding system %s. + +Please select one from the following safe coding systems:\n" + default-coding-system)) + (let ((pos (point)) + (fill-prefix " ")) + (mapcar (function (lambda (x) (princ " ") (princ x))) + safe-coding-systems) + (fill-region-as-paragraph pos (point))))) + + ;; Read a coding system. + (let* ((safe-names (mapcar (lambda (x) (list (symbol-name x))) + safe-coding-systems)) + (name (completing-read + (format "Select coding system (default %s): " + (car safe-coding-systems)) + safe-names nil t nil nil (car (car safe-names))))) + (intern name)))))) + +(setq select-safe-coding-system-function 'select-safe-coding-system) + ;;; Language support staffs. @@ -244,37 +352,38 @@ KEY is a symbol denoting the kind of required information." (if lang-slot (cdr (assq key (cdr lang-slot)))))) -(defun set-language-info (language-name key info) +(defun set-language-info (language-name key info + &optional describe-map setup-map) "Set for LANGUAGE-NAME the information INFO under KEY. KEY is a symbol denoting the kind of information. -INFO is any Lisp object which contains the actual information. +INFO is any Lisp object which contains the actual information specific + to LANGUAGE-NAME. Currently, the following KEYs are used by Emacs: -charset: list of symbols whose values are charsets specific to the language. +charset: list of charsets. + +coding-system: list of coding systems. -coding-system: list of coding systems specific to the language. +coding-priority: list of coding systems ordered by priority. tutorial: a tutorial file name written in the language. sample-text: one line short text containing characters of the language. documentation: t or a string describing how Emacs supports the language. - If a string is specified, it is shown before any other information - of the language by the command `describe-language-environment'. + If a string is specified, it is shown before any other information + of the language by the command `describe-language-environment'. setup-function: a function to call for setting up environment - convenient for a user of the language. - -If KEY is documentation or setup-function, you can also specify -a cons cell as INFO, in which case, the car part should be -a normal value as INFO for KEY (as described above), -and the cdr part should be a symbol whose value is a menu keymap -in which an entry for the language is defined. But, only the car part -is actually set as the information. + convenient for a user of the language. We will define more KEYs in the future. To avoid conflict, -if you want to use your own KEY values, make them start with `user-'." +if you want to use your own KEY values, make them start with `user-'. + +Optional 4th and 5th args DESCRIBE-MAP and SETUP-MAP are keymaps to +register LANGUAGE-NAME in the menu of `Mule'->`Describe Language +Environment' and `Mule'->`Setup Language Environment' respectively." (if (symbolp language-name) (setq language-name (symbol-name language-name))) (let (lang-slot key-slot) @@ -289,36 +398,57 @@ if you want to use your own KEY values, make them start with `user-'." (setcdr lang-slot (cons key-slot (cdr lang-slot))))) ;; Setup menu. (cond ((eq key 'documentation) - (define-key-after - (if (consp info) - (prog1 (symbol-value (cdr info)) - (setq info (car info))) - describe-language-environment-map) - (vector (intern language-name)) - (cons language-name 'describe-specified-language-support) - t)) + (define-key-after describe-map (vector (intern language-name)) + (cons language-name 'describe-specified-language-support) t)) ((eq key 'setup-function) - (define-key-after - (if (consp info) - (prog1 (symbol-value (cdr info)) - (setq info (car info))) - setup-language-environment-map) - (vector (intern language-name)) - (cons language-name 'setup-specified-language-environment) - t))) + (define-key-after setup-map (vector (intern language-name)) + (cons language-name 'setup-specified-language-environment) t))) (setcdr key-slot info) )) -(defun set-language-info-alist (language-name alist) +(defun set-language-info-alist (language-name alist &optional parents) "Set for LANGUAGE-NAME the information in ALIST. ALIST is an alist of KEY and INFO. See the documentation of -`set-langauge-info' for the meanings of KEY and INFO." +`set-langauge-info' for the meanings of KEY and INFO. + +Optional arg PARENTS is a list of parent language environments ordered +from the highest to the lower. If it is nil, we make LANGUAGE-NAME +the top level language environment." (if (symbolp language-name) (setq language-name (symbol-name language-name))) - (while alist - (set-language-info language-name (car (car alist)) (cdr (car alist))) - (setq alist (cdr alist)))) + (let ((describe-map describe-language-environment-map) + (setup-map setup-language-environment-map)) + (if parents + (let ((l parents) + map parent-symbol parent) + (while l + (if (symbolp (setq parent-symbol (car l))) + (setq parent (symbol-name parent)) + (setq parent parent-symbol parent-symbol (intern parent))) + (setq map (lookup-key describe-map (vector parent-symbol))) + (if (not map) + (progn + (setq map (intern (format "describe-%s-environment-map" + (downcase parent)))) + (define-prefix-command map) + (define-key-after describe-map (vector parent-symbol) + (cons parent map) t))) + (setq describe-map (symbol-value map)) + (setq map (lookup-key setup-map (vector parent-symbol))) + (if (not map) + (progn + (setq map (intern (format "setup-%s-environment-map" + (downcase parent)))) + (define-prefix-command map) + (define-key-after setup-map (vector parent-symbol) + (cons parent map) t))) + (setq setup-map (symbol-value map)) + (setq l (cdr l))))) + (while alist + (set-language-info language-name (car (car alist)) (cdr (car alist)) + describe-map setup-map) + (setq alist (cdr alist))))) (defun read-language-name (key prompt &optional default) "Read language name which has information for KEY, prompting with PROMPT. @@ -698,6 +828,19 @@ and sometimes other things." (run-hooks 'set-language-environment-hook) (force-mode-line-update t)) +(defun set-language-environment-coding-systems (language-name) + "Do various coding system setups for language environment LANGUAGE-NAME." + (let* ((priority (get-language-info language-name 'coding-priority)) + (default-coding (car priority))) + (if priority + (let ((categories (mapcar 'coding-system-category priority))) + (set-default-coding-systems default-coding) + (set-coding-priority categories) + (while priority + (set (car categories) (car priority)) + (setq priority (cdr priority) categories (cdr categories))) + (update-iso-coding-systems))))) + ;; Print all arguments with `princ', then print "\n". (defsubst princ-list (&rest args) (while args (princ (car args)) (setq args (cdr args))) -- 2.39.2