X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d29ee6b1a110cf5d170a10317a96acbbd4a1c68b..430c6cede235d6c1b9197fdc30faddb20569b71a:/lisp/international/mule-cmds.el diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 111c45dd50..c5b05d629a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1,9 +1,9 @@ ;;; mule-cmds.el --- commands for multilingual environment -*-coding: iso-2022-7bit -*- -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 +;; 2005, 2006, 2007, 2008 ;; National Institute of Advanced Industrial Science and Technology (AIST) ;; Registration Number H14PRO021 ;; Copyright (C) 2003 @@ -14,10 +14,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -25,20 +25,16 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: -(eval-when-compile - (defvar dos-codepage) - (autoload 'widget-value "wid-edit")) +(defvar dos-codepage) +(autoload 'widget-value "wid-edit") (defvar mac-system-coding-system) -(defvar mac-system-locale) ;;; MULE related key bindings and menus. @@ -151,7 +147,7 @@ t) (define-key-after set-coding-system-map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq initial-window-system '(x w32 mac))) + :enable (null (memq initial-window-system '(x w32 ns))) :help "How to encode terminal output") t) (define-key-after set-coding-system-map [separator-3] @@ -267,7 +263,7 @@ wrong, use this command again to toggle back to the right mode." (force-mode-line-update)) (defun view-hello-file () - "Display the HELLO file which list up many languages and characters." + "Display the HELLO file, which lists many languages and characters." (interactive) ;; We have to decode the file in any environment. (let ((default-enable-multibyte-characters t) @@ -946,6 +942,7 @@ It is highly recommended to fix it before writing to a file." (let ((codings (find-coding-systems-region from to)) (coding-system nil) + (tick (if (not (stringp from)) (buffer-modified-tick))) safe rejected unsafe) (if (eq (car codings) 'undecided) ;; Any coding system is ok. @@ -1011,6 +1008,8 @@ It is highly recommended to fix it before writing to a file." %s specified by file contents. Really save (else edit coding cookies \ and try again)? " coding-system auto-cs)) (error "Save aborted")))) + (when (and tick (/= tick (buffer-modified-tick))) + (error "Cancelled because the buffer was modified")) coding-system))) (setq select-safe-coding-system-function 'select-safe-coding-system) @@ -1302,7 +1301,10 @@ This is the input method activated automatically by the command (put 'input-method-function 'permanent-local t) (defvar input-method-history nil - "History list for some commands that read input methods.") + "History list of input methods read from the minibuffer. + +Maximum length of the history list is determined by the value +of `history-length', which see.") (make-variable-buffer-local 'input-method-history) (put 'input-method-history 'permanent-local t) @@ -1503,7 +1505,7 @@ which marks the variable `default-input-method' as set for Custom buffers." (when interactive (customize-mark-as-set 'default-input-method))))))) -(eval-when-compile (autoload 'help-buffer "help-mode")) +(autoload 'help-buffer "help-mode") (defun describe-input-method (input-method) "Describe input method INPUT-METHOD." @@ -1769,7 +1771,11 @@ The default status is as follows: ;; (set-terminal-coding-system-internal nil) ;; (set-keyboard-coding-system-internal nil) - (set-unibyte-charset 'iso-8859-1)) + ;; Back in Emacs-20, it was necessary to provide some fallback implicit + ;; conversion, because almost no packages handled coding-system issues. + ;; Nowadays it'd just paper over bugs. + ;; (set-unibyte-charset 'iso-8859-1) + ) (reset-language-environment) @@ -1835,6 +1841,9 @@ specifies the character set for the major languages of Western Europe." (if (functionp func) (funcall func))) + (setq current-iso639-language + (get-language-info language-name 'iso639-language)) + (run-hooks 'set-language-environment-hook) (force-mode-line-update t)) @@ -1900,6 +1909,9 @@ Setting this variable directly does not take effect. See (features (repeat symbol)) (unibyte-display coding-system))))) +(declare-function x-server-vendor "xfns.c" (&optional terminal)) +(declare-function x-server-version "xfns.c" (&optional terminal)) + (defun standard-display-european-internal () ;; Actually set up direct output of non-ASCII characters. (standard-display-8bit (if (eq window-system 'pc) 128 160) 255) @@ -1958,7 +1970,11 @@ Setting this variable directly does not take effect. See (or (and (charsetp nonascii) (get-charset-property nonascii :ascii-compatible-p)) (setq nonascii 'iso-8859-1)) - (set-unibyte-charset nonascii))) + ;; Back in Emacs-20, it was necessary to provide some fallback implicit + ;; conversion, because almost no packages handled coding-system issues. + ;; Nowadays it'd just paper over bugs. + ;; (set-unibyte-charset nonascii) + )) (defun set-language-environment-charset (language-name) "Do various charset setups for language environment LANGUAGE-NAME." @@ -2416,6 +2432,19 @@ is returned. Thus, for instance, if charset \"ISO8859-2\", ;; too, for setting things such as calendar holidays, ps-print paper ;; size, spelling dictionary. +(defun locale-translate (locale) + "Expand LOCALE according to `locale-translation-file-name', if possible. +For example, translate \"swedish\" into \"sv_SE.ISO8859-1\"." + (if locale-translation-file-name + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents locale-translation-file-name) + (if (re-search-forward + (concat "^" (regexp-quote locale) ":?[ \t]+") nil t) + (buffer-substring (point) (line-end-position)) + locale)) + locale)) + (defun set-locale-environment (&optional locale-name frame) "Set up multi-lingual environment for using LOCALE-NAME. This sets the language environment, the coding system priority, @@ -2472,29 +2501,8 @@ See also `locale-charset-language-names', `locale-language-names', (= 0 (length locale))) ; nil or empty string (setq locale (getenv (pop vars) frame))))) - (unless locale - ;; The two tests are kept separate so the byte-compiler sees - ;; that mac-get-preference is only called after checking its existence. - (when (fboundp 'mac-get-preference) - (setq locale (mac-get-preference "AppleLocale")) - (unless locale - (let ((languages (mac-get-preference "AppleLanguages"))) - (unless (= (length languages) 0) ; nil or empty vector - (setq locale (aref languages 0))))))) - (unless (or locale (not (boundp 'mac-system-locale))) - (setq locale mac-system-locale)) - (when locale - - ;; Translate "swedish" into "sv_SE.ISO8859-1", and so on, - ;; using the translation file that many systems have. - (when locale-translation-file-name - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-file-contents locale-translation-file-name) - (when (re-search-forward - (concat "^" (regexp-quote locale) ":?[ \t]+") nil t) - (setq locale (buffer-substring (point) (line-end-position)))))) + (setq locale (locale-translate locale)) ;; Leave the system locales alone if the caller did not specify ;; an explicit locale name, as their defaults are set from @@ -2502,8 +2510,16 @@ See also `locale-charset-language-names', `locale-language-names', ;; want to set them to the same value as LC_CTYPE. (when locale-name (setq system-messages-locale locale) - (setq system-time-locale locale)) + (setq system-time-locale locale))) + + (setq woman-locale + (or system-messages-locale + (let ((msglocale (getenv "LC_MESSAGES" frame))) + (if (zerop (length msglocale)) + locale + (locale-translate msglocale))))) + (when locale (setq locale (downcase locale)) (let ((language-name @@ -2517,8 +2533,7 @@ See also `locale-charset-language-names', `locale-language-names', (when locale (if (string-match "\\.\\([^@]+\\)" locale) (locale-charset-to-coding-system - (match-string 1 locale)))) - (and (eq system-type 'macos) mac-system-coding-system)))) + (match-string 1 locale))))))) (if (consp language-name) ;; locale-language-names specify both lang-env and coding. @@ -2559,7 +2574,7 @@ See also `locale-charset-language-names', `locale-language-names', ;; only). At least X and MS Windows can generate ;; multilingual input. ;; XXX This was disabled unless `window-system', but that - ;; leads to buggy behaviour when a tty frame is opened + ;; leads to buggy behavior when a tty frame is opened ;; later. Setting the keyboard coding system has no adverse ;; effect on X, so let's do it anyway. -- Lorentey (let ((kcs (or coding-system @@ -2579,21 +2594,7 @@ See also `locale-charset-language-names', `locale-language-names', ;; Fixme: perhaps prefer-coding-system should set this too. ;; But it's not the time to do such a fundamental change. (setq default-sendmail-coding-system coding-system) - (setq locale-coding-system coding-system)) - - (when (get-language-info current-language-environment 'coding-priority) - (let ((codeset (locale-info 'codeset)) - (coding-system (car (coding-system-priority-list)))) - (when codeset - (let ((cs (coding-system-aliases coding-system)) - result) - (while (and cs (not result)) - (setq result - (locale-charset-match-p (symbol-name (pop cs)) - (locale-info 'codeset)))) - (unless result - (message "Warning: Default coding system `%s' disagrees with -system codeset `%s' for this locale." coding-system codeset)))))))) + (setq locale-coding-system coding-system)))) ;; On Windows, override locale-coding-system, ;; default-file-name-coding-system, keyboard-coding-system, @@ -2787,32 +2788,40 @@ If there's no description string for VALUE, return nil." (function (lambda (x) (format "#x%02X" x)))) str " ")) -(defun encode-coding-char (char coding-system) +(defun encode-coding-char (char coding-system &optional charset) "Encode CHAR by CODING-SYSTEM and return the resulting string. -If CODING-SYSTEM can't safely encode CHAR, return nil." - (let ((str1 (string-as-multibyte (string char))) - (str2 (string-as-multibyte (string char char))) +If CODING-SYSTEM can't safely encode CHAR, return nil. +The 3rd optional argument CHARSET, if non-nil, is a charset preferred +on encoding." + (let* ((str1 (string-as-multibyte (string char))) + (str2 (string-as-multibyte (string char char))) + (found (find-coding-systems-string str1)) enc1 enc2 i1 i2) - (when (memq (coding-system-base coding-system) - (find-coding-systems-string str1)) - ;; We must find the encoded string of CHAR. But, just encoding - ;; CHAR will put extra control sequences (usually to designate - ;; ASCII charset) at the tail if type of CODING is ISO 2022. - ;; To exclude such tailing bytes, we at first encode one-char - ;; string and two-char string, then check how many bytes at the - ;; tail of both encoded strings are the same. - - (setq enc1 (encode-coding-string str1 coding-system) - i1 (length enc1) - enc2 (encode-coding-string str2 coding-system) - i2 (length enc2)) - (while (and (> i1 0) (= (aref enc1 (1- i1)) (aref enc2 (1- i2)))) - (setq i1 (1- i1) i2 (1- i2))) - - ;; Now (substring enc1 i1) and (substring enc2 i2) are the same, - ;; and they are the extra control sequences at the tail to - ;; exclude. - (substring enc2 0 i2)))) + (if (and (consp found) + (eq (car found) 'undecided)) + str1 + (when (memq (coding-system-base coding-system) found) + ;; We must find the encoded string of CHAR. But, just encoding + ;; CHAR will put extra control sequences (usually to designate + ;; ASCII charset) at the tail if type of CODING is ISO 2022. + ;; To exclude such tailing bytes, we at first encode one-char + ;; string and two-char string, then check how many bytes at the + ;; tail of both encoded strings are the same. + + (when charset + (put-text-property 0 1 'charset charset str1) + (put-text-property 0 2 'charset charset str2)) + (setq enc1 (encode-coding-string str1 coding-system) + i1 (length enc1) + enc2 (encode-coding-string str2 coding-system) + i2 (length enc2)) + (while (and (> i1 0) (= (aref enc1 (1- i1)) (aref enc2 (1- i2)))) + (setq i1 (1- i1) i2 (1- i2))) + + ;; Now (substring enc1 i1) and (substring enc2 i2) are the same, + ;; and they are the extra control sequences at the tail to + ;; exclude. + (substring enc2 0 i2))))) ;; Backwards compatibility. These might be better with :init-value t, ;; but that breaks loadup. @@ -2828,16 +2837,63 @@ If CODING-SYSTEM can't safely encode CHAR, return nil." (defvar nonascii-insert-offset 0 "This variable is obsolete.") (defvar nonascii-translation-table nil "This variable is obsolete.") +(defvar ucs-names nil + "Alist of cached (CHAR-NAME . CHAR-CODE) pairs.") + +(defun ucs-names () + "Return alist of (CHAR-NAME . CHAR-CODE) pairs cached in `ucs-names'." + (or ucs-names + (setq ucs-names + (let (name names) + (dotimes (c #xEFFFF) + (unless (or + (and (>= c #x3400 ) (<= c #x4dbf )) ; CJK Ideograph Extension A + (and (>= c #x4e00 ) (<= c #x9fff )) ; CJK Ideograph + (and (>= c #xd800 ) (<= c #xfaff )) ; Private/Surrogate + (and (>= c #x20000) (<= c #x2ffff)) ; CJK Ideograph Extension B + ) + (if (setq name (get-char-code-property c 'name)) + (setq names (cons (cons name c) names))) + (if (setq name (get-char-code-property c 'old-name)) + (setq names (cons (cons name c) names))))) + names)))) + +(defvar ucs-completions (lazy-completion-table ucs-completions ucs-names) + "Lazy completion table for completing on Unicode character names.") + +(defun read-char-by-name (prompt) + "Read a character by its Unicode name or hex number string. +Display PROMPT and read a string that represents a character by its +Unicode property `name' or `old-name'. You can type a few of first +letters of the Unicode name and use completion. This function also +accepts a hexadecimal number of Unicode code point or a number in +hash notation, e.g. #o21430 for octal, #x2318 for hex, or #10r8984 +for decimal. Returns a character as a number." + (let* ((completion-ignore-case t) + (input (completing-read prompt ucs-completions))) + (cond + ((string-match "^[0-9a-fA-F]+$" input) + (string-to-number input 16)) + ((string-match "^#" input) + (read input)) + (t + (cdr (assoc input (ucs-names))))))) + (defun ucs-insert (arg) "Insert a character of the given Unicode code point. -Interactively, prompts for a hex string giving the code." - (interactive "sUnicode (hex): ") - (or (integerp arg) +Interactively, prompts for a Unicode character name or a hex number +using `read-char-by-name'." + (interactive (list (read-char-by-name "Unicode (name or hex): "))) + (if (stringp arg) (setq arg (string-to-number arg 16))) - (if (or (< arg 0) (> arg #x10FFFF)) - (error "Not a Unicode character code: 0x%X" arg)) - (insert arg)) - + (cond + ((not (integerp arg)) + (error "Not a Unicode character code: %S" arg)) + ((or (< arg 0) (> arg #x10FFFF)) + (error "Not a Unicode character code: 0x%X" arg))) + (insert-and-inherit arg)) + +(define-key ctl-x-map "8\r" 'ucs-insert) ;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc ;;; mule-cmds.el ends here