1;;; mule-cmds.el --- commands for mulitilingual environment -*-coding: iso-2022-7bit -*- 2 3;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 6;; 2005, 2006, 2007 7;; National Institute of Advanced Industrial Science and Technology (AIST) 8;; Registration Number H14PRO021 9 10;; Keywords: mule, multilingual 11 12;; This file is part of GNU Emacs. 13 14;; GNU Emacs is free software; you can redistribute it and/or modify 15;; it under the terms of the GNU General Public License as published by 16;; the Free Software Foundation; either version 2, or (at your option) 17;; any later version. 18 19;; GNU Emacs is distributed in the hope that it will be useful, 20;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22;; GNU General Public License for more details. 23 24;; You should have received a copy of the GNU General Public License 25;; along with GNU Emacs; see the file COPYING. If not, write to the 26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 27;; Boston, MA 02110-1301, USA. 28 29;;; Commentary: 30 31;;; Code: 32 33(eval-when-compile 34 (defvar dos-codepage) 35 (autoload 'widget-value "wid-edit")) 36 37(defvar mac-system-coding-system) 38(defvar mac-system-locale) 39 40;;; MULE related key bindings and menus. 41 42(defvar mule-keymap (make-sparse-keymap) 43 "Keymap for Mule (Multilingual environment) specific commands.") 44 45;; Keep "C-x C-m ..." for mule specific commands. 46(define-key ctl-x-map "\C-m" mule-keymap) 47 48(define-key mule-keymap "f" 'set-buffer-file-coding-system) 49(define-key mule-keymap "r" 'revert-buffer-with-coding-system) 50(define-key mule-keymap "F" 'set-file-name-coding-system) 51(define-key mule-keymap "t" 'set-terminal-coding-system) 52(define-key mule-keymap "k" 'set-keyboard-coding-system) 53(define-key mule-keymap "p" 'set-buffer-process-coding-system) 54(define-key mule-keymap "x" 'set-selection-coding-system) 55(define-key mule-keymap "X" 'set-next-selection-coding-system) 56(define-key mule-keymap "\C-\\" 'set-input-method) 57(define-key mule-keymap "c" 'universal-coding-system-argument) 58(define-key mule-keymap "l" 'set-language-environment) 59 60(defvar mule-menu-keymap 61 (make-sparse-keymap "Mule (Multilingual Environment)") 62 "Keymap for Mule (Multilingual environment) menu specific commands.") 63 64(defvar describe-language-environment-map 65 (make-sparse-keymap "Describe Language Environment")) 66 67(defvar setup-language-environment-map 68 (make-sparse-keymap "Set Language Environment")) 69 70(defvar set-coding-system-map 71 (make-sparse-keymap "Set Coding System")) 72 73(define-key-after mule-menu-keymap [set-language-environment] 74 (list 'menu-item "Set Language Environment" setup-language-environment-map)) 75(define-key-after mule-menu-keymap [separator-mule] 76 '("--") 77 t) 78(define-key-after mule-menu-keymap [toggle-input-method] 79 '(menu-item "Toggle Input Method" toggle-input-method) 80 t) 81(define-key-after mule-menu-keymap [set-input-method] 82 '(menu-item "Select Input Method..." set-input-method) 83 t) 84(define-key-after mule-menu-keymap [describe-input-method] 85 '(menu-item "Describe Input Method" describe-input-method)) 86(define-key-after mule-menu-keymap [separator-input-method] 87 '("--") 88 t) 89(define-key-after mule-menu-keymap [set-various-coding-system] 90 (list 'menu-item "Set Coding Systems" set-coding-system-map 91 :enable 'default-enable-multibyte-characters)) 92(define-key-after mule-menu-keymap [view-hello-file] 93 '(menu-item "Show Multi-lingual Text" view-hello-file 94 :enable (file-readable-p 95 (expand-file-name "HELLO" data-directory)) 96 :help "Display file which says HELLO in many languages") 97 t) 98(define-key-after mule-menu-keymap [separator-coding-system] 99 '("--") 100 t) 101(define-key-after mule-menu-keymap [describe-language-environment] 102 (list 'menu-item "Describe Language Environment" 103 describe-language-environment-map 104 :help "Show multilingual settings for a specific language") 105 t) 106(define-key-after mule-menu-keymap [describe-input-method] 107 '(menu-item "Describe Input Method..." describe-input-method 108 :help "Keyboard layout for a specific input method") 109 t) 110(define-key-after mule-menu-keymap [describe-coding-system] 111 '(menu-item "Describe Coding System..." describe-coding-system) 112 t) 113(define-key-after mule-menu-keymap [list-character-sets] 114 '(menu-item "List Character Sets" list-character-sets 115 :help "Show table of available character sets")) 116(define-key-after mule-menu-keymap [mule-diag] 117 '(menu-item "Show All of Mule Status" mule-diag 118 :help "Display multilingual environment settings") 119 t) 120 121(define-key-after set-coding-system-map [universal-coding-system-argument] 122 '(menu-item "For Next Command" universal-coding-system-argument 123 :help "Coding system to be used by next command") 124 t) 125(define-key-after set-coding-system-map [separator-1] 126 '("--") 127 t) 128(define-key-after set-coding-system-map [set-buffer-file-coding-system] 129 '(menu-item "For Saving This Buffer" set-buffer-file-coding-system 130 :help "How to encode this buffer when saved") 131 t) 132(define-key-after set-coding-system-map [revert-buffer-with-coding-system] 133 '(menu-item "For Reverting This File Now" revert-buffer-with-coding-system 134 :enable buffer-file-name 135 :help "Revisit this file immediately using specified coding system") 136 t) 137(define-key-after set-coding-system-map [set-file-name-coding-system] 138 '(menu-item "For File Name" set-file-name-coding-system 139 :help "How to decode/encode file names") 140 t) 141(define-key-after set-coding-system-map [separator-2] 142 '("--") 143 t) 144 145(define-key-after set-coding-system-map [set-keyboard-coding-system] 146 '(menu-item "For Keyboard" set-keyboard-coding-system 147 :help "How to decode keyboard input") 148 t) 149(define-key-after set-coding-system-map [set-terminal-coding-system] 150 '(menu-item "For Terminal" set-terminal-coding-system 151 :enable (null (memq window-system '(x w32 mac))) 152 :help "How to encode terminal output") 153 t) 154(define-key-after set-coding-system-map [separator-3] 155 '("--") 156 t) 157(define-key-after set-coding-system-map [set-selection-coding-system] 158 '(menu-item "For X Selections/Clipboard" set-selection-coding-system 159 :visible (display-selections-p) 160 :help "How to en/decode data to/from selection/clipboard") 161 t) 162(define-key-after set-coding-system-map [set-next-selection-coding-system] 163 '(menu-item "For Next X Selection" set-next-selection-coding-system 164 :visible (display-selections-p) 165 :help "How to en/decode next selection/clipboard operation") 166 t) 167(define-key-after set-coding-system-map [set-buffer-process-coding-system] 168 '(menu-item "For I/O with Subprocess" set-buffer-process-coding-system 169 :visible (fboundp 'start-process) 170 :enable (get-buffer-process (current-buffer)) 171 :help "How to en/decode I/O from/to subprocess connected to this buffer") 172 t) 173 174 175(define-key setup-language-environment-map 176 [Default] '(menu-item "Default" setup-specified-language-environment)) 177 178(define-key describe-language-environment-map 179 [Default] '(menu-item "Default" describe-specified-language-support)) 180 181;; This should be a single character key binding because users use it 182;; very frequently while editing multilingual text. Now we can use 183;; only two such keys: "\C-\\" and "\C-^", but the latter is not 184;; convenient because it requires shifting on most keyboards. An 185;; alternative is "\C-\]" which is now bound to `abort-recursive-edit' 186;; but it won't be used that frequently. 187(define-key global-map "\C-\\" 'toggle-input-method) 188 189;; This is no good because people often type Shift-SPC 190;; meaning to type SPC. -- rms. 191;; ;; Here's an alternative key binding for X users (Shift-SPACE). 192;; (define-key global-map [?\S- ] 'toggle-input-method) 193 194;;; Mule related hyperlinks. 195(defconst help-xref-mule-regexp-template 196 (purecopy (concat "\\(\\<\\(" 197 "\\(coding system\\)\\|" 198 "\\(input method\\)\\|" 199 "\\(character set\\)\\|" 200 "\\(charset\\)" 201 "\\)\\s-+\\)?" 202 ;; Note starting with word-syntax character: 203 "`\\(\\sw\\(\\sw\\|\\s_\\)+\\)'"))) 204 205(defun coding-system-change-eol-conversion (coding-system eol-type) 206 "Return a coding system which differs from CODING-SYSTEM in eol conversion. 207The returned coding system converts end-of-line by EOL-TYPE 208but text as the same way as CODING-SYSTEM. 209EOL-TYPE should be `unix', `dos', `mac', or nil. 210If EOL-TYPE is nil, the returned coding system detects 211how end-of-line is formatted automatically while decoding. 212 213EOL-TYPE can be specified by an integer 0, 1, or 2. 214They means `unix', `dos', and `mac' respectively." 215 (if (symbolp eol-type) 216 (setq eol-type (cond ((eq eol-type 'unix) 0) 217 ((eq eol-type 'dos) 1) 218 ((eq eol-type 'mac) 2) 219 (t eol-type)))) 220 ;; We call `coding-system-base' before `coding-system-eol-type', 221 ;; because the coding-system may not be initialized until then. 222 (let* ((base (coding-system-base coding-system)) 223 (orig-eol-type (coding-system-eol-type coding-system))) 224 (cond ((vectorp orig-eol-type) 225 (if (not eol-type) 226 coding-system 227 (aref orig-eol-type eol-type))) 228 ((not eol-type) 229 base) 230 ((= eol-type orig-eol-type) 231 coding-system) 232 ((progn (setq orig-eol-type (coding-system-eol-type base)) 233 (vectorp orig-eol-type)) 234 (aref orig-eol-type eol-type))))) 235 236(defun coding-system-change-text-conversion (coding-system coding) 237 "Return a coding system which differs from CODING-SYSTEM in text conversion. 238The returned coding system converts text by CODING 239but end-of-line as the same way as CODING-SYSTEM. 240If CODING is nil, the returned coding system detects 241how text is formatted automatically while decoding." 242 (let ((eol-type (coding-system-eol-type coding-system))) 243 (coding-system-change-eol-conversion 244 (if coding coding 'undecided) 245 (if (numberp eol-type) (aref [unix dos mac] eol-type))))) 246 247(defun toggle-enable-multibyte-characters (&optional arg) 248 "Change whether this buffer uses multibyte characters. 249With arg, use multibyte characters if the arg is positive. 250 251Note that this command does not convert the byte contents of 252the buffer; it only changes the way those bytes are interpreted. 253In general, therefore, this command *changes* the sequence of 254characters that the current buffer contains. 255 256We suggest you avoid using use this command unless you know what you 257are doing. If you use it by mistake, and the buffer is now displayed 258wrong, use this command again to toggle back to the right mode." 259 (interactive "P") 260 (let ((new-flag 261 (if (null arg) (null enable-multibyte-characters) 262 (> (prefix-numeric-value arg) 0)))) 263 (set-buffer-multibyte new-flag)) 264 (force-mode-line-update)) 265 266(defun view-hello-file () 267 "Display the HELLO file which list up many languages and characters." 268 (interactive) 269 ;; We have to decode the file in any environment. 270 (let ((default-enable-multibyte-characters t) 271 (coding-system-for-read 'iso-2022-7bit)) 272 (view-file (expand-file-name "HELLO" data-directory)))) 273 274(defun universal-coding-system-argument (coding-system) 275 "Execute an I/O command using the specified coding system." 276 (interactive 277 (let ((default (and buffer-file-coding-system 278 (not (eq (coding-system-type buffer-file-coding-system) 279 t)) 280 buffer-file-coding-system))) 281 (list (read-coding-system 282 (if default 283 (format "Coding system for following command (default %s): " default) 284 "Coding system for following command: ") 285 default)))) 286 (let* ((keyseq (read-key-sequence 287 (format "Command to execute with %s:" coding-system))) 288 (cmd (key-binding keyseq)) 289 prefix) 290 291 (when (eq cmd 'universal-argument) 292 (call-interactively cmd) 293 294 ;; Process keys bound in `universal-argument-map'. 295 (while (progn 296 (setq keyseq (read-key-sequence nil t) 297 cmd (key-binding keyseq t)) 298 (not (eq cmd 'universal-argument-other-key))) 299 (let ((current-prefix-arg prefix-arg) 300 ;; Have to bind `last-command-char' here so that 301 ;; `digit-argument', for instance, can compute the 302 ;; prefix arg. 303 (last-command-char (aref keyseq 0))) 304 (call-interactively cmd))) 305 306 ;; This is the final call to `universal-argument-other-key', which 307 ;; set's the final `prefix-arg. 308 (let ((current-prefix-arg prefix-arg)) 309 (call-interactively cmd)) 310 311 ;; Read the command to execute with the given prefix arg. 312 (setq prefix prefix-arg 313 keyseq (read-key-sequence nil t) 314 cmd (key-binding keyseq))) 315 316 (let ((coding-system-for-read coding-system) 317 (coding-system-for-write coding-system) 318 (coding-system-require-warning t) 319 (current-prefix-arg prefix)) 320 (message "") 321 (call-interactively cmd)))) 322 323(defun set-default-coding-systems (coding-system) 324 "Set default value of various coding systems to CODING-SYSTEM. 325This sets the following coding systems: 326 o coding system of a newly created buffer 327 o default coding system for subprocess I/O 328This also sets the following values: 329 o default value used as `file-name-coding-system' for converting file names 330 if CODING-SYSTEM is ASCII-compatible. 331 o default value for the command `set-terminal-coding-system' (not on MSDOS) 332 o default value for the command `set-keyboard-coding-system' 333 if CODING-SYSTEM is ASCII-compatible.." 334 (check-coding-system coding-system) 335 (setq-default buffer-file-coding-system coding-system) 336 (if (fboundp 'ucs-set-table-for-input) 337 (dolist (buffer (buffer-list)) 338 (or (local-variable-p 'buffer-file-coding-system buffer) 339 (ucs-set-table-for-input buffer)))) 340 341 (if (eq system-type 'darwin) 342 ;; The file-name coding system on Darwin systems is always utf-8. 343 (setq default-file-name-coding-system 'utf-8) 344 (if (and default-enable-multibyte-characters 345 (or (not coding-system) 346 (not (coding-system-get coding-system 'ascii-incompatible)))) 347 (setq default-file-name-coding-system coding-system))) 348 ;; If coding-system is nil, honor that on MS-DOS as well, so 349 ;; that they could reset the terminal coding system. 350 (unless (and (eq window-system 'pc) coding-system) 351 (setq default-terminal-coding-system coding-system)) 352 (if (or (not coding-system) 353 (not (coding-system-get coding-system 'ascii-incompatible))) 354 (setq default-keyboard-coding-system coding-system)) 355 ;; Preserve eol-type from existing default-process-coding-systems. 356 ;; On non-unix-like systems in particular, these may have been set 357 ;; carefully by the user, or by the startup code, to deal with the 358 ;; users shell appropriately, so should not be altered by changing 359 ;; language environment. 360 (let ((output-coding 361 (coding-system-change-text-conversion 362 (car default-process-coding-system) coding-system)) 363 (input-coding 364 (coding-system-change-text-conversion 365 (cdr default-process-coding-system) coding-system))) 366 (setq default-process-coding-system 367 (cons output-coding input-coding)))) 368 369(defun prefer-coding-system (coding-system) 370 "Add CODING-SYSTEM at the front of the priority list for automatic detection. 371This also sets the following coding systems: 372 o coding system of a newly created buffer 373 o default coding system for subprocess I/O 374This also sets the following values: 375 o default value used as `file-name-coding-system' for converting file names. 376 o default value for the command `set-terminal-coding-system' (not on MSDOS) 377 o default value for the command `set-keyboard-coding-system' 378 379If CODING-SYSTEM specifies a certain type of EOL conversion, the coding 380systems set by this function will use that type of EOL conversion. 381 382This command does not change the default value of terminal coding system 383for MS-DOS terminal, because DOS terminals only support a single coding 384system, and Emacs automatically sets the default to that coding system at 385startup. 386 387A coding system that requires automatic detection of text 388encoding (e.g. undecided, unix) can't be preferred. 389 390See also `coding-category-list' and `coding-system-category'." 391 (interactive "zPrefer coding system: ") 392 (if (not (and coding-system (coding-system-p coding-system))) 393 (error "Invalid coding system `%s'" coding-system)) 394 (let ((coding-category (coding-system-category coding-system)) 395 (base (coding-system-base coding-system)) 396 (eol-type (coding-system-eol-type coding-system))) 397 (if (not coding-category) 398 ;; CODING-SYSTEM is no-conversion or undecided. 399 (error "Can't prefer the coding system `%s'" coding-system)) 400 (set coding-category (or base coding-system)) 401 ;; Changing the binding of a coding category requires this call. 402 (update-coding-systems-internal) 403 (or (eq coding-category (car coding-category-list)) 404 ;; We must change the order. 405 (set-coding-priority (list coding-category))) 406 (if (and base (interactive-p)) 407 (message "Highest priority is set to %s (base of %s)" 408 base coding-system)) 409 ;; If they asked for specific EOL conversion, honor that. 410 (if (memq eol-type '(0 1 2)) 411 (setq coding-system 412 (coding-system-change-eol-conversion base eol-type)) 413 (setq coding-system base)) 414 (set-default-coding-systems coding-system))) 415 416(defvar sort-coding-systems-predicate nil 417 "If non-nil, a predicate function to sort coding systems. 418 419It is called with two coding systems, and should return t if the first 420one is \"less\" than the second. 421 422The function `sort-coding-systems' use it.") 423 424(defun sort-coding-systems (codings) 425 "Sort coding system list CODINGS by a priority of each coding system. 426Returns the sorted list. CODINGS is modified by side effects. 427 428If a coding system is most preferred, it has the highest priority. 429Otherwise, a coding system corresponds to some MIME charset has higher 430priorities. Among them, a coding system included in `coding-system' 431key of the current language environment has higher priorities. See 432also the documentation of `language-info-alist'. 433 434If the variable `sort-coding-systems-predicate' (which see) is 435non-nil, it is used to sort CODINGS in the different way than above." 436 (if sort-coding-systems-predicate 437 (sort codings sort-coding-systems-predicate) 438 (let* ((from-categories (mapcar #'(lambda (x) (symbol-value x)) 439 coding-category-list)) 440 (most-preferred (car from-categories)) 441 (lang-preferred (get-language-info current-language-environment 442 'coding-system)) 443 (func (function 444 (lambda (x) 445 (let ((base (coding-system-base x))) 446 ;; We calculate the priority number 0..255 by 447 ;; using the 8 bits PMMLCEII as this: 448 ;; P: 1 iff most preferred. 449 ;; MM: greater than 0 iff mime-charset. 450 ;; L: 1 iff one of the current lang. env.'s codings. 451 ;; C: 1 iff one of codings listed in the category list. 452 ;; E: 1 iff not XXX-with-esc 453 ;; II: if iso-2022 based, 0..3, else 1. 454 (logior 455 (lsh (if (eq base most-preferred) 1 0) 7) 456 (lsh 457 (let ((mime (coding-system-get base 'mime-charset))) 458 ;; Prefer coding systems corresponding to a 459 ;; MIME charset. 460 (if mime 461 ;; Lower utf-16 priority so that we 462 ;; normally prefer utf-8 to it, and put 463 ;; x-ctext below that. 464 (cond ((string-match "utf-16" 465 (symbol-name mime)) 466 2) 467 ((string-match "^x-" (symbol-name mime)) 468 1) 469 (t 3)) 470 0)) 471 5) 472 (lsh (if (memq base lang-preferred) 1 0) 4) 473 (lsh (if (memq base from-categories) 1 0) 3) 474 (lsh (if (string-match "-with-esc\\'" 475 (symbol-name base)) 476 0 1) 2) 477 (if (eq (coding-system-type base) 2) 478 ;; For ISO based coding systems, prefer 479 ;; one that doesn't use escape sequences. 480 (let ((flags (coding-system-flags base))) 481 (if (or (consp (aref flags 0)) 482 (consp (aref flags 1)) 483 (consp (aref flags 2)) 484 (consp (aref flags 3))) 485 (if (or (aref flags 8) (aref flags 9)) 486 0 487 1) 488 2)) 489 1))))))) 490 (sort codings (function (lambda (x y) 491 (> (funcall func x) (funcall func y)))))))) 492 493(defun find-coding-systems-region (from to) 494 "Return a list of proper coding systems to encode a text between FROM and TO. 495If FROM is a string, find coding systems in that instead of the buffer. 496All coding systems in the list can safely encode any multibyte characters 497in the text. 498 499If the text contains no multibyte characters, return a list of a single 500element `undecided'." 501 (let ((codings (find-coding-systems-region-internal from to))) 502 (if (eq codings t) 503 ;; The text contains only ASCII characters. Any coding 504 ;; systems are safe. 505 '(undecided) 506 ;; We need copy-sequence because sorting will alter the argument. 507 (sort-coding-systems (copy-sequence codings))))) 508 509(defun find-coding-systems-string (string) 510 "Return a list of proper coding systems to encode STRING. 511All coding systems in the list can safely encode any multibyte characters 512in STRING. 513 514If STRING contains no multibyte characters, return a list of a single 515element `undecided'." 516 (find-coding-systems-region string nil)) 517 518(defun find-coding-systems-for-charsets (charsets) 519 "Return a list of proper coding systems to encode characters of CHARSETS. 520CHARSETS is a list of character sets. 521It actually checks at most the first 96 characters of each charset. 522So, if a charset of dimension two is included in CHARSETS, the value may 523contain a coding system that can't encode all characters of the charset." 524 (cond ((or (null charsets) 525 (and (= (length charsets) 1) 526 (eq 'ascii (car charsets)))) 527 '(undecided)) 528 ((or (memq 'eight-bit-control charsets) 529 (memq 'eight-bit-graphic charsets)) 530 '(raw-text emacs-mule)) 531 (t 532 (let ((codings t) 533 charset l str) 534 (while (and codings charsets) 535 (setq charset (car charsets) charsets (cdr charsets)) 536 (unless (eq charset 'ascii) 537 (setq str (make-string 96 32)) 538 (if (= (charset-dimension charset) 1) 539 (if (= (charset-chars charset) 96) 540 (dotimes (i 96) 541 (aset str i (make-char charset (+ i 32)))) 542 (dotimes (i 94) 543 (aset str i (make-char charset (+ i 33))))) 544 (if (= (charset-chars charset) 96) 545 (dotimes (i 96) 546 (aset str i (make-char charset 32 (+ i 32)))) 547 (dotimes (i 94) 548 (aset str i (make-char charset 33 (+ i 33)))))) 549 (setq l (find-coding-systems-string str)) 550 (if (eq codings t) 551 (setq codings l) 552 (let ((ll nil)) 553 (dolist (elt codings) 554 (if (memq elt l) 555 (setq ll (cons elt ll)))) 556 (setq codings ll))))) 557 codings)))) 558 559(defun find-multibyte-characters (from to &optional maxcount excludes) 560 "Find multibyte characters in the region specified by FROM and TO. 561If FROM is a string, find multibyte characters in the string. 562The return value is an alist of the following format: 563 ((CHARSET COUNT CHAR ...) ...) 564where 565 CHARSET is a character set, 566 COUNT is a number of characters, 567 CHARs are the characters found from the character set. 568Optional 3rd arg MAXCOUNT limits how many CHARs are put in the above list. 569Optional 4th arg EXCLUDE is a list of character sets to be ignored. 570 571For invalid characters, CHARs are actually strings." 572 (let ((chars nil) 573 charset char) 574 (if (stringp from) 575 (let ((idx 0)) 576 (while (setq idx (string-match "[^\000-\177]" from idx)) 577 (setq char (aref from idx) 578 charset (char-charset char)) 579 (if (eq charset 'unknown) 580 (setq char (match-string 0))) 581 (if (or (memq charset '(unknown 582 eight-bit-control eight-bit-graphic)) 583 (not (or (eq excludes t) (memq charset excludes)))) 584 (let ((slot (assq charset chars))) 585 (if slot 586 (if (not (memq char (nthcdr 2 slot))) 587 (let ((count (nth 1 slot))) 588 (setcar (cdr slot) (1+ count)) 589 (if (or (not maxcount) (< count maxcount)) 590 (nconc slot (list char))))) 591 (setq chars (cons (list charset 1 char) chars))))) 592 (setq idx (1+ idx)))) 593 (save-excursion 594 (goto-char from) 595 (while (re-search-forward "[^\000-\177]" to t) 596 (setq char (preceding-char) 597 charset (char-charset char)) 598 (if (eq charset 'unknown) 599 (setq char (match-string 0))) 600 (if (or (memq charset '(unknown eight-bit-control eight-bit-graphic)) 601 (not (or (eq excludes t) (memq charset excludes)))) 602 (let ((slot (assq charset chars))) 603 (if slot 604 (if (not (member char (nthcdr 2 slot))) 605 (let ((count (nth 1 slot))) 606 (setcar (cdr slot) (1+ count)) 607 (if (or (not maxcount) (< count maxcount)) 608 (nconc slot (list char))))) 609 (setq chars (cons (list charset 1 char) chars)))))))) 610 (nreverse chars))) 611 612 613(defun search-unencodable-char (coding-system) 614 "Search forward from point for a character that is not encodable. 615It asks which coding system to check. 616If such a character is found, set point after that character. 617Otherwise, don't move point. 618 619When called from a program, the value is a position of the found character, 620or nil if all characters are encodable." 621 (interactive 622 (list (let ((default (or buffer-file-coding-system 'us-ascii))) 623 (read-coding-system 624 (format "Coding-system (default %s): " default) 625 default)))) 626 (let ((pos (unencodable-char-position (point) (point-max) coding-system))) 627 (if pos 628 (goto-char (1+ pos)) 629 (message "All following characters are encodable by %s" coding-system)) 630 pos)) 631 632 633(defvar last-coding-system-specified nil 634 "Most recent coding system explicitly specified by the user when asked. 635This variable is set whenever Emacs asks the user which coding system 636to use in order to write a file. If you set it to nil explicitly, 637then call `write-region', then afterward this variable will be non-nil 638only if the user was explicitly asked and specified a coding system.") 639 640(defvar select-safe-coding-system-accept-default-p nil 641 "If non-nil, a function to control the behavior of coding system selection. 642The meaning is the same as the argument ACCEPT-DEFAULT-P of the 643function `select-safe-coding-system' (which see). This variable 644overrides that argument.") 645 646(defun select-safe-coding-system-interactively (from to codings unsafe 647 &optional rejected default) 648 "Select interactively a coding system for the region FROM ... TO. 649FROM can be a string, as in `write-region'. 650CODINGS is the list of base coding systems known to be safe for this region, 651 typically obtained with `find-coding-systems-region'. 652UNSAFE is a list of coding systems known to be unsafe for this region. 653REJECTED is a list of coding systems which were safe but for some reason 654 were not recommended in the particular context. 655DEFAULT is the coding system to use by default in the query." 656 ;; At first, if some defaults are unsafe, record at most 11 657 ;; problematic characters and their positions for them by turning 658 ;; (CODING ...) 659 ;; into 660 ;; ((CODING (POS . CHAR) (POS . CHAR) ...) ...) 661 (if unsafe 662 (setq unsafe 663 (mapcar #'(lambda (coding) 664 (cons coding 665 (if (stringp from) 666 (mapcar #'(lambda (pos) 667 (cons pos (aref from pos))) 668 (unencodable-char-position 669 0 (length from) coding 670 11 from)) 671 (mapcar #'(lambda (pos) 672 (cons pos (char-after pos))) 673 (unencodable-char-position 674 from to coding 11))))) 675 unsafe))) 676 677 ;; Change each safe coding system to the corresponding 678 ;; mime-charset name if it is also a coding system. Such a name 679 ;; is more friendly to users. 680 (let ((l codings) 681 mime-charset) 682 (while l 683 (setq mime-charset (coding-system-get (car l) 'mime-charset)) 684 (if (and mime-charset (coding-system-p mime-charset)) 685 (setcar l mime-charset)) 686 (setq l (cdr l)))) 687 688 ;; Don't offer variations with locking shift, which you 689 ;; basically never want. 690 (let (l) 691 (dolist (elt codings (setq codings (nreverse l))) 692 (unless (or (eq 'coding-category-iso-7-else 693 (coding-system-category elt)) 694 (eq 'coding-category-iso-8-else 695 (coding-system-category elt))) 696 (push elt l)))) 697 698 ;; Remove raw-text, emacs-mule and no-conversion unless nothing 699 ;; else is available. 700 (setq codings 701 (or (delq 'raw-text 702 (delq 'emacs-mule 703 (delq 'no-conversion codings))) 704 '(raw-text emacs-mule no-conversion))) 705 706 (let ((window-configuration (current-window-configuration)) 707 (bufname (buffer-name)) 708 coding-system) 709 (save-excursion 710 ;; If some defaults are unsafe, make sure the offending 711 ;; buffer is displayed. 712 (when (and unsafe (not (stringp from))) 713 (pop-to-buffer bufname) 714 (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x))) 715 unsafe)))) 716 ;; Then ask users to select one from CODINGS while showing 717 ;; the reason why none of the defaults are not used. 718 (with-output-to-temp-buffer "*Warning*" 719 (with-current-buffer standard-output 720 (if (and (null rejected) (null unsafe)) 721 (insert "No default coding systems to try for " 722 (if (stringp from) 723 (format "string \"%s\"." from) 724 (format "buffer `%s'." bufname))) 725 (insert 726 "These default coding systems were tried to encode" 727 (if (stringp from) 728 (concat " \"" (if (> (length from) 10) 729 (concat (substring from 0 10) "...\"") 730 (concat from "\""))) 731 (format " text\nin the buffer `%s'" bufname)) 732 ":\n") 733 (let ((pos (point)) 734 (fill-prefix " ")) 735 (dolist (x (append rejected unsafe)) 736 (princ " ") (princ (car x))) 737 (insert "\n") 738 (fill-region-as-paragraph pos (point))) 739 (when rejected 740 (insert "These safely encode the text in the buffer, 741but are not recommended for encoding text in this context, 742e.g., for sending an email message.\n ") 743 (dolist (x rejected) 744 (princ " ") (princ x)) 745 (insert "\n")) 746 (when unsafe 747 (insert (if rejected "The other coding systems" 748 "However, each of them") 749 " encountered characters it couldn't encode:\n") 750 (dolist (coding unsafe) 751 (insert (format " %s cannot encode these:" (car coding))) 752 (let ((i 0) 753 (func1 754 #'(lambda (bufname pos) 755 (when (buffer-live-p (get-buffer bufname)) 756 (pop-to-buffer bufname) 757 (goto-char pos)))) 758 (func2 759 #'(lambda (bufname pos coding) 760 (when (buffer-live-p (get-buffer bufname)) 761 (pop-to-buffer bufname) 762 (if (< (point) pos) 763 (goto-char pos) 764 (forward-char 1) 765 (search-unencodable-char coding) 766 (forward-char -1)))))) 767 (dolist (elt (cdr coding)) 768 (insert " ") 769 (if (stringp from) 770 (insert (if (< i 10) (cdr elt) "...")) 771 (if (< i 10) 772 (insert-text-button 773 (cdr elt) 774 :type 'help-xref 775 'face 'link 776 'help-echo 777 "mouse-2, RET: jump to this character" 778 'help-function func1 779 'help-args (list bufname (car elt))) 780 (insert-text-button 781 "..." 782 :type 'help-xref 783 'face 'link 784 'help-echo 785 "mouse-2, RET: next unencodable character" 786 'help-function func2 787 'help-args (list bufname (car elt) 788 (car coding))))) 789 (setq i (1+ i)))) 790 (insert "\n")) 791 (insert (substitute-command-keys "\ 792 793Click on a character (or switch to this window by `\\[other-window]'\n\ 794and select the characters by RET) to jump to the place it appears,\n\ 795where `\\[universal-argument] \\[what-cursor-position]' will give information about it.\n")))) 796 (insert (substitute-command-keys "\nSelect \ 797one of the safe coding systems listed below,\n\ 798or cancel the writing with \\[keyboard-quit] and edit the buffer\n\ 799 to remove or modify the problematic characters,\n\ 800or specify any other coding system (and risk losing\n\ 801 the problematic characters).\n\n")) 802 (let ((pos (point)) 803 (fill-prefix " ")) 804 (dolist (x codings) 805 (princ " ") (princ x)) 806 (insert "\n") 807 (fill-region-as-paragraph pos (point))))) 808 809 ;; Read a coding system. 810 (setq coding-system 811 (read-coding-system 812 (format "Select coding system (default %s): " default) 813 default)) 814 (setq last-coding-system-specified coding-system)) 815 816 (kill-buffer "*Warning*") 817 (set-window-configuration window-configuration) 818 coding-system)) 819 820(defun select-safe-coding-system (from to &optional default-coding-system 821 accept-default-p file) 822 "Ask a user to select a safe coding system from candidates. 823The candidates of coding systems which can safely encode a text 824between FROM and TO are shown in a popup window. Among them, the most 825proper one is suggested as the default. 826 827The list of `buffer-file-coding-system' of the current buffer, 828the `default-buffer-file-coding-system', and the 829most preferred coding system (if it corresponds to a MIME charset) is 830treated as the default coding system list. Among them, the first one 831that safely encodes the text is normally selected silently and 832returned without any user interaction. See also the command 833`prefer-coding-system'. 834 835However, the user is queried if the chosen coding system is 836inconsistent with what would be selected by `find-auto-coding' from 837coding cookies &c. if the contents of the region were read from a 838file. (That could lead to data corruption in a file subsequently 839re-visited and edited.) 840 841Optional 3rd arg DEFAULT-CODING-SYSTEM specifies a coding system or a 842list of coding systems to be prepended to the default coding system 843list. However, if DEFAULT-CODING-SYSTEM is a list and the first 844element is t, the cdr part is used as the default coding system list, 845i.e. `buffer-file-coding-system', `default-buffer-file-coding-system', 846and the most preferred coding system are not used. 847 848Optional 4th arg ACCEPT-DEFAULT-P, if non-nil, is a function to 849determine the acceptability of the silently selected coding system. 850It is called with that coding system, and should return nil if it 851should not be silently selected and thus user interaction is required. 852 853Optional 5th arg FILE is the file name to use for this purpose. 854That is different from `buffer-file-name' when handling `write-region' 855\(for example). 856 857The variable `select-safe-coding-system-accept-default-p', if 858non-nil, overrides ACCEPT-DEFAULT-P. 859 860Kludgy feature: if FROM is a string, the string is the target text, 861and TO is ignored." 862 (if (and default-coding-system 863 (not (listp default-coding-system))) 864 (setq default-coding-system (list default-coding-system))) 865 866 (let ((no-other-defaults nil) 867 auto-cs) 868 (unless (or (stringp from) find-file-literally) 869 ;; Find an auto-coding that is specified for the the current 870 ;; buffer and file from the region FROM and TO. 871 (save-excursion 872 (save-restriction 873 (widen) 874 (goto-char from) 875 (setq auto-cs (find-auto-coding (or file buffer-file-name "") 876 (- to from))) 877 (if auto-cs 878 (if (coding-system-p (car auto-cs)) 879 (setq auto-cs (car auto-cs)) 880 (display-warning 881 :warning 882 (format "\ 883Invalid coding system `%s' is specified 884for the current buffer/file by the %s. 885It is highly recommended to fix it before writing to a file." 886 (car auto-cs) 887 (if (eq (cdr auto-cs) :coding) ":coding tag" 888 (format "variable `%s'" (cdr auto-cs))))) 889 (or (yes-or-no-p "Really proceed with writing? ") 890 (error "Save aborted")) 891 (setq auto-cs nil)))))) 892 893 (if (eq (car default-coding-system) t) 894 (setq no-other-defaults t 895 default-coding-system (cdr default-coding-system))) 896 897 ;; Change elements of the list to (coding . base-coding). 898 (setq default-coding-system 899 (mapcar (function (lambda (x) (cons x (coding-system-base x)))) 900 default-coding-system)) 901 902 (if (and auto-cs (not no-other-defaults)) 903 ;; If the file has a coding cookie, try to use it before anything 904 ;; else (i.e. before default-coding-system which will typically come 905 ;; from file-coding-system-alist). 906 (let ((base (coding-system-base auto-cs))) 907 (or (memq base '(nil undecided)) 908 (rassq base default-coding-system) 909 (push (cons auto-cs base) default-coding-system)))) 910 911 (unless no-other-defaults 912 ;; If buffer-file-coding-system is not nil nor undecided, append it 913 ;; to the defaults. 914 (if buffer-file-coding-system 915 (let ((base (coding-system-base buffer-file-coding-system))) 916 (or (eq base 'undecided) 917 (rassq base default-coding-system) 918 (setq default-coding-system 919 (append default-coding-system 920 (list (cons buffer-file-coding-system base))))))) 921 922 ;; If default-buffer-file-coding-system is not nil nor undecided, 923 ;; append it to the defaults. 924 (if default-buffer-file-coding-system 925 (let ((base (coding-system-base default-buffer-file-coding-system))) 926 (or (eq base 'undecided) 927 (rassq base default-coding-system) 928 (setq default-coding-system 929 (append default-coding-system 930 (list (cons default-buffer-file-coding-system 931 base))))))) 932 933 ;; If the most preferred coding system has the property mime-charset, 934 ;; append it to the defaults. 935 (let ((tail coding-category-list) 936 preferred base) 937 (while (and tail (not (setq preferred (symbol-value (car tail))))) 938 (setq tail (cdr tail))) 939 (and (coding-system-p preferred) 940 (setq base (coding-system-base preferred)) 941 (coding-system-get preferred 'mime-charset) 942 (not (rassq base default-coding-system)) 943 (setq default-coding-system 944 (append default-coding-system 945 (list (cons preferred base))))))) 946 947 (if select-safe-coding-system-accept-default-p 948 (setq accept-default-p select-safe-coding-system-accept-default-p)) 949 950 ;; Decide the eol-type from the top of the default codings, 951 ;; buffer-file-coding-system, or 952 ;; default-buffer-file-coding-system. 953 (if default-coding-system 954 (let ((default-eol-type (coding-system-eol-type 955 (caar default-coding-system)))) 956 (if (and (vectorp default-eol-type) buffer-file-coding-system) 957 (setq default-eol-type (coding-system-eol-type 958 buffer-file-coding-system))) 959 (if (and (vectorp default-eol-type) default-buffer-file-coding-system) 960 (setq default-eol-type (coding-system-eol-type 961 default-buffer-file-coding-system))) 962 (if (and default-eol-type (not (vectorp default-eol-type))) 963 (dolist (elt default-coding-system) 964 (setcar elt (coding-system-change-eol-conversion 965 (car elt) default-eol-type)))))) 966 967 (let ((codings (find-coding-systems-region from to)) 968 (coding-system nil) 969 safe rejected unsafe) 970 (if (eq (car codings) 'undecided) 971 ;; Any coding system is ok. 972 (setq coding-system (caar default-coding-system)) 973 ;; Reverse the list so that elements are accumulated in safe, 974 ;; rejected, and unsafe in the correct order. 975 (setq default-coding-system (nreverse default-coding-system)) 976 977 ;; Classify the defaults into safe, rejected, and unsafe. 978 (dolist (elt default-coding-system) 979 (if (memq (cdr elt) codings) 980 (if (and (functionp accept-default-p) 981 (not (funcall accept-default-p (cdr elt)))) 982 (push (car elt) rejected) 983 (push (car elt) safe)) 984 (push (car elt) unsafe))) 985 (if safe 986 (setq coding-system (car safe)))) 987 988 ;; If all the defaults failed, ask a user. 989 (when (not coding-system) 990 (setq coding-system (select-safe-coding-system-interactively 991 from to codings unsafe rejected (car codings)))) 992 993 ;; Check we're not inconsistent with what `coding:' spec &c would 994 ;; give when file is re-read. 995 ;; But don't do this if we explicitly ignored the cookie 996 ;; by using `find-file-literally'. 997 (when (and auto-cs 998 (not (and 999 coding-system 1000 (memq (coding-system-type coding-system) '(0 5))))) 1001 ;; Merge coding-system and auto-cs as far as possible. 1002 (if (not coding-system) 1003 (setq coding-system auto-cs) 1004 (if (not auto-cs) 1005 (setq auto-cs coding-system) 1006 (let ((eol-type-1 (coding-system-eol-type coding-system)) 1007 (eol-type-2 (coding-system-eol-type auto-cs))) 1008 (if (eq (coding-system-base coding-system) 'undecided) 1009 (setq coding-system (coding-system-change-text-conversion 1010 coding-system auto-cs)) 1011 (if (eq (coding-system-base auto-cs) 'undecided) 1012 (setq auto-cs (coding-system-change-text-conversion 1013 auto-cs coding-system)))) 1014 (if (vectorp eol-type-1) 1015 (or (vectorp eol-type-2) 1016 (setq coding-system (coding-system-change-eol-conversion 1017 coding-system eol-type-2))) 1018 (if (vectorp eol-type-2) 1019 (setq auto-cs (coding-system-change-eol-conversion 1020 auto-cs eol-type-1))))))) 1021 1022 (if (and auto-cs 1023 ;; Don't barf if writing a compressed file, say. 1024 ;; This check perhaps isn't ideal, but is probably 1025 ;; the best thing to do. 1026 (not (auto-coding-alist-lookup (or file buffer-file-name ""))) 1027 (not (coding-system-equal coding-system auto-cs))) 1028 (unless (yes-or-no-p 1029 (format "Selected encoding %s disagrees with \ 1030%s specified by file contents. Really save (else edit coding cookies \ 1031and try again)? " coding-system auto-cs)) 1032 (error "Save aborted")))) 1033 coding-system))) 1034 1035(setq select-safe-coding-system-function 'select-safe-coding-system) 1036 1037(defun select-message-coding-system () 1038 "Return a coding system to encode the outgoing message of the current buffer. 1039It at first tries the first coding system found in these variables 1040in this order: 1041 (1) local value of `buffer-file-coding-system' 1042 (2) value of `sendmail-coding-system' 1043 (3) value of `default-sendmail-coding-system' 1044 (4) value of `default-buffer-file-coding-system' 1045If the found coding system can't encode the current buffer, 1046or none of them are bound to a coding system, 1047it asks the user to select a proper coding system." 1048 (let ((coding (or (and (local-variable-p 'buffer-file-coding-system) 1049 buffer-file-coding-system) 1050 sendmail-coding-system 1051 default-sendmail-coding-system 1052 default-buffer-file-coding-system))) 1053 (if (eq coding 'no-conversion) 1054 ;; We should never use no-conversion for outgoing mail. 1055 (setq coding nil)) 1056 (if (fboundp select-safe-coding-system-function) 1057 (setq coding 1058 (funcall select-safe-coding-system-function 1059 (point-min) (point-max) coding 1060 (function (lambda (x) 1061 (coding-system-get x 'mime-charset)))))) 1062 (if coding 1063 ;; Be sure to use LF for end-of-line. 1064 (setq coding (coding-system-change-eol-conversion coding 'unix)) 1065 ;; No coding system is decided. Usually this is the case that 1066 ;; the current buffer contains only ASCII. So, we hope 1067 ;; iso-8859-1 works. 1068 (setq coding 'iso-8859-1-unix)) 1069 coding)) 1070 1071;;; Language support stuff. 1072 1073(defvar language-info-alist nil 1074 "Alist of language environment definitions. 1075Each element looks like: 1076 (LANGUAGE-NAME . ((KEY . INFO) ...)) 1077where LANGUAGE-NAME is a string, the name of the language environment, 1078KEY is a symbol denoting the kind of information, and 1079INFO is the data associated with KEY. 1080Meaningful values for KEY include 1081 1082 documentation value is documentation of what this language environment 1083 is meant for, and how to use it. 1084 charset value is a list of the character sets used by this 1085 language environment. 1086 sample-text value is an expression which is evalled to generate 1087 a line of text written using characters appropriate 1088 for this language environment. 1089 setup-function value is a function to call to switch to this 1090 language environment. 1091 exit-function value is a function to call to leave this 1092 language environment. 1093 coding-system value is a list of coding systems that are good 1094 for saving text written in this language environment. 1095 This list serves as suggestions to the user; 1096 in effect, as a kind of documentation. 1097 coding-priority value is a list of coding systems for this language 1098 environment, in order of decreasing priority. 1099 This is used to set up the coding system priority 1100 list when you switch to this language environment. 1101 nonascii-translation 1102 value is a translation table to be set in the 1103 variable `nonascii-translation-table' in this 1104 language environment, or a character set from 1105 which `nonascii-insert-offset' is calculated. 1106 input-method value is a default input method for this language 1107 environment. 1108 features value is a list of features requested in this 1109 language environment. 1110 ctext-non-standard-encodings 1111 value is a list of non-standard encoding 1112 names used in extended segments of CTEXT. 1113 See the variable 1114 `ctext-non-standard-encodings' for more 1115 detail. 1116 1117The following keys take effect only when multibyte characters are 1118globally disabled, i.e. the value of `default-enable-multibyte-characters' 1119is nil. 1120 1121 unibyte-syntax value is a library name to load to set 1122 unibyte 8-bit character syntaxes for this 1123 language environment. 1124 1125 unibyte-display value is a coding system to encode characters 1126 for the terminal. Characters in the range 1127 of 160 to 255 display not as octal escapes, 1128 but as non-ASCII characters in this language 1129 environment.") 1130 1131(defun get-language-info (lang-env key) 1132 "Return information listed under KEY for language environment LANG-ENV. 1133KEY is a symbol denoting the kind of information. 1134For a list of useful values for KEY and their meanings, 1135see `language-info-alist'." 1136 (if (symbolp lang-env) 1137 (setq lang-env (symbol-name lang-env))) 1138 (let ((lang-slot (assoc-string lang-env language-info-alist t))) 1139 (if lang-slot 1140 (cdr (assq key (cdr lang-slot)))))) 1141 1142(defun set-language-info (lang-env key info) 1143 "Modify part of the definition of language environment LANG-ENV. 1144Specifically, this stores the information INFO under KEY 1145in the definition of this language environment. 1146KEY is a symbol denoting the kind of information. 1147INFO is the value for that information. 1148 1149For a list of useful values for KEY and their meanings, 1150see `language-info-alist'." 1151 (if (symbolp lang-env) 1152 (setq lang-env (symbol-name lang-env))) 1153 (set-language-info-internal lang-env key info) 1154 (if (equal lang-env current-language-environment) 1155 (cond ((eq key 'coding-priority) 1156 (set-language-environment-coding-systems lang-env)) 1157 ((eq key 'input-method) 1158 (set-language-environment-input-method lang-env)) 1159 ((eq key 'nonascii-translation) 1160 (set-language-environment-nonascii-translation lang-env)) 1161 ((eq key 'charset) 1162 (set-language-environment-charset lang-env)) 1163 ((eq key 'overriding-fontspec) 1164 (set-language-environment-fontset lang-env)) 1165 ((and (not default-enable-multibyte-characters) 1166 (or (eq key 'unibyte-syntax) (eq key 'unibyte-display))) 1167 (set-language-environment-unibyte lang-env))))) 1168 1169(defun set-language-info-internal (lang-env key info) 1170 "Internal use only. 1171Arguments are the same as `set-language-info'." 1172 (let (lang-slot key-slot) 1173 (setq lang-slot (assoc lang-env language-info-alist)) 1174 (if (null lang-slot) ; If no slot for the language, add it. 1175 (setq lang-slot (list lang-env) 1176 language-info-alist (cons lang-slot language-info-alist))) 1177 (setq key-slot (assq key lang-slot)) 1178 (if (null key-slot) ; If no slot for the key, add it. 1179 (progn 1180 (setq key-slot (list key)) 1181 (setcdr lang-slot (cons key-slot (cdr lang-slot))))) 1182 (setcdr key-slot (purecopy info)) 1183 ;; Update the custom-type of `current-language-environment'. 1184 (put 'current-language-environment 'custom-type 1185 (cons 'choice (mapcar 1186 (lambda (lang) 1187 (list 'const lang)) 1188 (sort (mapcar 'car language-info-alist) 'string<)))))) 1189 1190(defun set-language-info-alist (lang-env alist &optional parents) 1191 "Store ALIST as the definition of language environment LANG-ENV. 1192ALIST is an alist of KEY and INFO values. See the documentation of 1193`language-info-alist' for the meanings of KEY and INFO. 1194 1195Optional arg PARENTS is a list of parent menu names; it specifies 1196where to put this language environment in the 1197Describe Language Environment and Set Language Environment menus. 1198For example, (\"European\") means to put this language environment 1199in the European submenu in each of those two menus." 1200 (if (symbolp lang-env) 1201 (setq lang-env (symbol-name lang-env))) 1202 (let ((describe-map describe-language-environment-map) 1203 (setup-map setup-language-environment-map)) 1204 (if parents 1205 (let ((l parents) 1206 map parent-symbol parent prompt) 1207 (while l 1208 (if (symbolp (setq parent-symbol (car l))) 1209 (setq parent (symbol-name parent)) 1210 (setq parent parent-symbol parent-symbol (intern parent))) 1211 (setq map (lookup-key describe-map (vector parent-symbol))) 1212 ;; This prompt string is for define-prefix-command, so 1213 ;; that the map it creates will be suitable for a menu. 1214 (or map (setq prompt (format "%s Environment" parent))) 1215 (if (not map) 1216 (progn 1217 (setq map (intern (format "describe-%s-environment-map" 1218 (downcase parent)))) 1219 (define-prefix-command map nil prompt) 1220 (define-key-after describe-map (vector parent-symbol) 1221 (cons parent map) t))) 1222 (setq describe-map (symbol-value map)) 1223 (setq map (lookup-key setup-map (vector parent-symbol))) 1224 (if (not map) 1225 (progn 1226 (setq map (intern (format "setup-%s-environment-map" 1227 (downcase parent)))) 1228 (define-prefix-command map nil prompt) 1229 (define-key-after setup-map (vector parent-symbol) 1230 (cons parent map) t))) 1231 (setq setup-map (symbol-value map)) 1232 (setq l (cdr l))))) 1233 1234 ;; Set up menu items for this language env. 1235 (let ((doc (assq 'documentation alist))) 1236 (when doc 1237 (define-key-after describe-map (vector (intern lang-env)) 1238 (cons lang-env 'describe-specified-language-support) t))) 1239 (define-key-after setup-map (vector (intern lang-env)) 1240 (cons lang-env 'setup-specified-language-environment) t) 1241 1242 (dolist (elt alist) 1243 (set-language-info-internal lang-env (car elt) (cdr elt))) 1244 1245 (if (equal lang-env current-language-environment) 1246 (set-language-environment lang-env)))) 1247 1248(defun read-language-name (key prompt &optional default) 1249 "Read a language environment name which has information for KEY. 1250If KEY is nil, read any language environment. 1251Prompt with PROMPT. DEFAULT is the default choice of language environment. 1252This returns a language environment name as a string." 1253 (let* ((completion-ignore-case t) 1254 (name (completing-read prompt 1255 language-info-alist 1256 (and key 1257 (function (lambda (elm) (and (listp elm) (assq key elm))))) 1258 t nil nil default))) 1259 (if (and (> (length name) 0) 1260 (or (not key) 1261 (get-language-info name key))) 1262 name))) 1263 1264;;; Multilingual input methods. 1265(defgroup leim nil 1266 "LEIM: Libraries of Emacs Input Methods." 1267 :group 'mule) 1268 1269(defconst leim-list-file-name "leim-list.el" 1270 "Name of LEIM list file. 1271This file contains a list of libraries of Emacs input methods (LEIM) 1272in the format of Lisp expression for registering each input method. 1273Emacs loads this file at startup time.") 1274 1275(defvar leim-list-header (format 1276";;; %s -- list of LEIM (Library of Emacs Input Method) -*-coding: iso-2022-7bit;-*- 1277;; 1278;; This file contains a list of LEIM (Library of Emacs Input Method) 1279;; methods in the same directory as this file. Loading this file 1280;; registers all the input methods in Emacs. 1281;; 1282;; Each entry has the form: 1283;; (register-input-method 1284;; INPUT-METHOD LANGUAGE-NAME ACTIVATE-FUNC 1285;; TITLE DESCRIPTION 1286;; ARG ...) 1287;; See the function `register-input-method' for the meanings of the arguments. 1288;; 1289;; If this directory is included in load-path, Emacs automatically 1290;; loads this file at startup time. 1291 1292" 1293 leim-list-file-name) 1294 "Header to be inserted in LEIM list file.") 1295 1296(defvar leim-list-entry-regexp "^(register-input-method" 1297 "Regexp matching head of each entry in LEIM list file. 1298See also the variable `leim-list-header'") 1299 1300(defvar update-leim-list-functions 1301 '(quail-update-leim-list-file) 1302 "List of functions to call to update LEIM list file. 1303Each function is called with one arg, LEIM directory name.") 1304 1305(defun update-leim-list-file (&rest dirs) 1306 "Update LEIM list file in directories DIRS." 1307 (let ((functions update-leim-list-functions)) 1308 (while functions 1309 (apply (car functions) dirs) 1310 (setq functions (cdr functions))))) 1311 1312(defvar current-input-method nil 1313 "The current input method for multilingual text. 1314If nil, that means no input method is activated now.") 1315(make-variable-buffer-local 'current-input-method) 1316(put 'current-input-method 'permanent-local t) 1317 1318(defvar current-input-method-title nil 1319 "Title string of the current input method shown in mode line.") 1320(make-variable-buffer-local 'current-input-method-title) 1321(put 'current-input-method-title 'permanent-local t) 1322 1323(defcustom default-input-method nil 1324 "*Default input method for multilingual text (a string). 1325This is the input method activated automatically by the command 1326`toggle-input-method' (\\[toggle-input-method])." 1327 :link '(custom-manual "(emacs)Input Methods") 1328 :group 'mule 1329 :type '(choice (const nil) (string 1330 :completion-ignore-case t 1331 :complete-function widget-string-complete 1332 :completion-alist input-method-alist 1333 :prompt-history input-method-history)) 1334 :set-after '(current-language-environment)) 1335 1336(put 'input-method-function 'permanent-local t) 1337 1338(defvar input-method-history nil 1339 "History list for some commands that read input methods.") 1340(make-variable-buffer-local 'input-method-history) 1341(put 'input-method-history 'permanent-local t) 1342 1343(defvar inactivate-current-input-method-function nil 1344 "Function to call for inactivating the current input method. 1345Every input method should set this to an appropriate value when activated. 1346This function is called with no argument. 1347 1348This function should never change the value of `current-input-method'. 1349It is set to nil by the function `inactivate-input-method'.") 1350(make-variable-buffer-local 'inactivate-current-input-method-function) 1351(put 'inactivate-current-input-method-function 'permanent-local t) 1352 1353(defvar describe-current-input-method-function nil 1354 "Function to call for describing the current input method. 1355This function is called with no argument.") 1356(make-variable-buffer-local 'describe-current-input-method-function) 1357(put 'describe-current-input-method-function 'permanent-local t) 1358 1359(defvar input-method-alist nil 1360 "Alist of input method names vs how to use them. 1361Each element has the form: 1362 (INPUT-METHOD LANGUAGE-ENV ACTIVATE-FUNC TITLE DESCRIPTION ARGS...) 1363See the function `register-input-method' for the meanings of the elements.") 1364 1365(defun register-input-method (input-method lang-env &rest args) 1366 "Register INPUT-METHOD as an input method for language environment LANG-ENV. 1367 1368INPUT-METHOD and LANG-ENV are symbols or strings. 1369ACTIVATE-FUNC is a function to call to activate this method. 1370TITLE is a string to show in the mode line when this method is active. 1371DESCRIPTION is a string describing this method and what it is good for. 1372The ARGS, if any, are passed as arguments to ACTIVATE-FUNC. 1373All told, the arguments to ACTIVATE-FUNC are INPUT-METHOD and the ARGS. 1374 1375This function is mainly used in the file \"leim-list.el\" which is 1376created at Emacs build time, registering all Quail input methods 1377contained in the Emacs distribution. 1378 1379In case you want to register a new Quail input method by yourself, be 1380careful to use the same input method title as given in the third 1381parameter of `quail-define-package'. (If the values are different, the 1382string specified in this function takes precedence.) 1383 1384The commands `describe-input-method' and `list-input-methods' need 1385these duplicated values to show some information about input methods 1386without loading the relevant Quail packages. 1387\n(fn INPUT-METHOD LANG-ENV ACTIVATE-FUNC TITLE DESCRIPTION &rest ARGS)" 1388 (if (symbolp lang-env) 1389 (setq lang-env (symbol-name lang-env))) 1390 (if (symbolp input-method) 1391 (setq input-method (symbol-name input-method))) 1392 (let ((info (cons lang-env args)) 1393 (slot (assoc input-method input-method-alist))) 1394 (if slot 1395 (setcdr slot info) 1396 (setq slot (cons input-method info)) 1397 (setq input-method-alist (cons slot input-method-alist))))) 1398 1399(defun read-input-method-name (prompt &optional default inhibit-null) 1400 "Read a name of input method from a minibuffer prompting with PROMPT. 1401If DEFAULT is non-nil, use that as the default, 1402and substitute it into PROMPT at the first `%s'. 1403If INHIBIT-NULL is non-nil, null input signals an error. 1404 1405The return value is a string." 1406 (if default 1407 (setq prompt (format prompt default))) 1408 (let* ((completion-ignore-case t) 1409 ;; As it is quite normal to change input method in the 1410 ;; minibuffer, we must enable it even if 1411 ;; enable-recursive-minibuffers is currently nil. 1412 (enable-recursive-minibuffers t) 1413 ;; This binding is necessary because input-method-history is 1414 ;; buffer local. 1415 (input-method (completing-read prompt input-method-alist 1416 nil t nil 'input-method-history 1417 default))) 1418 (if (and input-method (symbolp input-method)) 1419 (setq input-method (symbol-name input-method))) 1420 (if (> (length input-method) 0) 1421 input-method 1422 (if inhibit-null 1423 (error "No valid input method is specified"))))) 1424 1425(defun activate-input-method (input-method) 1426 "Switch to input method INPUT-METHOD for the current buffer. 1427If some other input method is already active, turn it off first. 1428If INPUT-METHOD is nil, deactivate any current input method." 1429 (if (and input-method (symbolp input-method)) 1430 (setq input-method (symbol-name input-method))) 1431 (if (and current-input-method 1432 (not (string= current-input-method input-method))) 1433 (inactivate-input-method)) 1434 (unless (or current-input-method (null input-method)) 1435 (let ((slot (assoc input-method input-method-alist))) 1436 (if (null slot) 1437 (error "Can't activate input method `%s'" input-method)) 1438 (setq current-input-method-title nil) 1439 (let ((func (nth 2 slot))) 1440 (if (functionp func) 1441 (apply (nth 2 slot) input-method (nthcdr 5 slot)) 1442 (if (and (consp func) (symbolp (car func)) (symbolp (cdr func))) 1443 (progn 1444 (require (cdr func)) 1445 (apply (car func) input-method (nthcdr 5 slot))) 1446 (error "Can't activate input method `%s'" input-method)))) 1447 (setq current-input-method input-method) 1448 (or (stringp current-input-method-title) 1449 (setq current-input-method-title (nth 3 slot))) 1450 (unwind-protect 1451 (run-hooks 'input-method-activate-hook) 1452 (force-mode-line-update))))) 1453 1454(defun inactivate-input-method () 1455 "Turn off the current input method." 1456 (when current-input-method 1457 (if input-method-history 1458 (unless (string= current-input-method (car input-method-history)) 1459 (setq input-method-history 1460 (cons current-input-method 1461 (delete current-input-method input-method-history)))) 1462 (setq input-method-history (list current-input-method))) 1463 (unwind-protect 1464 (funcall inactivate-current-input-method-function) 1465 (unwind-protect 1466 (run-hooks 'input-method-inactivate-hook) 1467 (setq current-input-method nil 1468 input-method-function nil 1469 current-input-method-title nil) 1470 (force-mode-line-update))))) 1471 1472(defun set-input-method (input-method &optional interactive) 1473 "Select and activate input method INPUT-METHOD for the current buffer. 1474This also sets the default input method to the one you specify. 1475If INPUT-METHOD is nil, this function turns off the input method, and 1476also causes you to be prompted for a name of an input method the next 1477time you invoke \\[toggle-input-method]. 1478When called interactively, the optional arg INTERACTIVE is non-nil, 1479which marks the variable `default-input-method' as set for Custom buffers. 1480 1481To deactivate the input method interactively, use \\[toggle-input-method]. 1482To deactivate it programmatically, use \\[inactivate-input-method]." 1483 (interactive 1484 (let* ((default (or (car input-method-history) default-input-method))) 1485 (list (read-input-method-name 1486 (if default "Select input method (default %s): " "Select input method: ") 1487 default t) 1488 t))) 1489 (activate-input-method input-method) 1490 (setq default-input-method input-method) 1491 (when interactive 1492 (customize-mark-as-set 'default-input-method)) 1493 default-input-method) 1494 1495(defun toggle-input-method (&optional arg interactive) 1496 "Enable or disable multilingual text input method for the current buffer. 1497Only one input method can be enabled at any time in a given buffer. 1498 1499The normal action is to enable an input method if none was 1500enabled, and disable the current one otherwise. Which input method 1501to enable can be determined in various ways--either the one most 1502recently used, or the one specified by `default-input-method', or 1503as a last resort by reading the name of an input method in the 1504minibuffer. 1505 1506With a prefix argument, read an input method name with the minibuffer 1507and enable that one. The default is the most recent input method specified 1508\(not including the currently active input method, if any). 1509 1510When called interactively, the optional arg INTERACTIVE is non-nil, 1511which marks the variable `default-input-method' as set for Custom buffers." 1512 1513 (interactive "P\np") 1514 (if (and current-input-method (not arg)) 1515 (inactivate-input-method) 1516 (let ((default (or (car input-method-history) default-input-method))) 1517 (if (and arg default (equal current-input-method default) 1518 (> (length input-method-history) 1)) 1519 (setq default (nth 1 input-method-history))) 1520 (activate-input-method 1521 (if (or arg (not default)) 1522 (progn 1523 (read-input-method-name 1524 (if default "Input method (default %s): " "Input method: " ) 1525 default t)) 1526 default)) 1527 (unless default-input-method 1528 (prog1 1529 (setq default-input-method current-input-method) 1530 (when interactive 1531 (customize-mark-as-set 'default-input-method))))))) 1532 1533(defun describe-input-method (input-method) 1534 "Describe input method INPUT-METHOD." 1535 (interactive 1536 (list (read-input-method-name 1537 "Describe input method (default current choice): "))) 1538 (if (and input-method (symbolp input-method)) 1539 (setq input-method (symbol-name input-method))) 1540 (help-setup-xref (list #'describe-input-method 1541 (or input-method current-input-method)) 1542 (interactive-p)) 1543 1544 (if (null input-method) 1545 (describe-current-input-method) 1546 (let ((current current-input-method)) 1547 (condition-case nil 1548 (progn 1549 (save-excursion 1550 (activate-input-method input-method) 1551 (describe-current-input-method)) 1552 (activate-input-method current)) 1553 (error 1554 (activate-input-method current) 1555 (help-setup-xref (list #'describe-input-method input-method) 1556 (interactive-p)) 1557 (with-output-to-temp-buffer (help-buffer) 1558 (let ((elt (assoc input-method input-method-alist))) 1559 (princ (format 1560 "Input method: %s (`%s' in mode line) for %s\n %s\n" 1561 input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))) 1562 1563(defun describe-current-input-method () 1564 "Describe the input method currently in use. 1565This is a subroutine for `describe-input-method'." 1566 (if current-input-method 1567 (if (and (symbolp describe-current-input-method-function) 1568 (fboundp describe-current-input-method-function)) 1569 (funcall describe-current-input-method-function) 1570 (message "No way to describe the current input method `%s'" 1571 current-input-method) 1572 (ding)) 1573 (error "No input method is activated now"))) 1574 1575(defun read-multilingual-string (prompt &optional initial-input input-method) 1576 "Read a multilingual string from minibuffer, prompting with string PROMPT. 1577The input method selected last time is activated in minibuffer. 1578If optional second arg INITIAL-INPUT is non-nil, insert it in the minibuffer 1579initially. 1580Optional 3rd argument INPUT-METHOD specifies the input method 1581to be activated instead of the one selected last time. It is a symbol 1582or a string." 1583 (setq input-method 1584 (or input-method 1585 current-input-method 1586 default-input-method 1587 (read-input-method-name "Input method: " nil t))) 1588 (if (and input-method (symbolp input-method)) 1589 (setq input-method (symbol-name input-method))) 1590 (let ((prev-input-method current-input-method)) 1591 (unwind-protect 1592 (progn 1593 (activate-input-method input-method) 1594 (read-string prompt initial-input nil nil t)) 1595 (activate-input-method prev-input-method)))) 1596 1597;; Variables to control behavior of input methods. All input methods 1598;; should react to these variables. 1599 1600(defcustom input-method-verbose-flag 'default 1601 "*A flag to control extra guidance given by input methods. 1602The value should be nil, t, `complex-only', or `default'. 1603 1604The extra guidance is done by showing list of available keys in echo 1605area. When you use the input method in the minibuffer, the guidance 1606is shown at the bottom short window (split from the existing window). 1607 1608If the value is t, extra guidance is always given, if the value is 1609nil, extra guidance is always suppressed. 1610 1611If the value is `complex-only', only complex input methods such as 1612`chinese-py' and `japanese' give extra guidance. 1613 1614If the value is `default', complex input methods always give extra 1615guidance, but simple input methods give it only when you are not in 1616the minibuffer. 1617 1618See also the variable `input-method-highlight-flag'." 1619 :type '(choice (const :tag "Always" t) (const :tag "Never" nil) 1620 (const complex-only) (const default)) 1621 :group 'mule) 1622 1623(defcustom input-method-highlight-flag t 1624 "*If this flag is non-nil, input methods highlight partially-entered text. 1625For instance, while you are in the middle of a Quail input method sequence, 1626the text inserted so far is temporarily underlined. 1627The underlining goes away when you finish or abort the input method sequence. 1628See also the variable `input-method-verbose-flag'." 1629 :type 'boolean 1630 :group 'mule) 1631 1632(defvar input-method-activate-hook nil 1633 "Normal hook run just after an input method is activated. 1634 1635The variable `current-input-method' keeps the input method name 1636just activated.") 1637 1638(defvar input-method-inactivate-hook nil 1639 "Normal hook run just after an input method is inactivated. 1640 1641The variable `current-input-method' still keeps the input method name 1642just inactivated.") 1643 1644(defvar input-method-after-insert-chunk-hook nil 1645 "Normal hook run just after an input method insert some chunk of text.") 1646 1647(defvar input-method-exit-on-first-char nil 1648 "This flag controls when an input method returns. 1649Usually, the input method does not return while there's a possibility 1650that it may find a different translation if a user types another key. 1651But, it this flag is non-nil, the input method returns as soon as 1652the current key sequence gets long enough to have some valid translation.") 1653 1654(defvar input-method-use-echo-area nil 1655 "This flag controls how an input method shows an intermediate key sequence. 1656Usually, the input method inserts the intermediate key sequence, 1657or candidate translations corresponding to the sequence, 1658at point in the current buffer. 1659But, if this flag is non-nil, it displays them in echo area instead.") 1660 1661(defvar input-method-exit-on-invalid-key nil 1662 "This flag controls the behavior of an input method on invalid key input. 1663Usually, when a user types a key which doesn't start any character 1664handled by the input method, the key is handled by turning off the 1665input method temporarily. After that key, the input method is re-enabled. 1666But, if this flag is non-nil, the input method is never back on.") 1667 1668 1669(defvar set-language-environment-hook nil 1670 "Normal hook run after some language environment is set. 1671 1672When you set some hook function here, that effect usually should not 1673be inherited to another language environment. So, you had better set 1674another function in `exit-language-environment-hook' (which see) to 1675cancel the effect.") 1676 1677(defvar exit-language-environment-hook nil 1678 "Normal hook run after exiting from some language environment. 1679When this hook is run, the variable `current-language-environment' 1680is still bound to the language environment being exited. 1681 1682This hook is mainly used for canceling the effect of 1683`set-language-environment-hook' (which-see).") 1684 1685(put 'setup-specified-language-environment 'apropos-inhibit t) 1686 1687(defun setup-specified-language-environment () 1688 "Switch to a specified language environment." 1689 (interactive) 1690 (let (language-name) 1691 (if (and (symbolp last-command-event) 1692 (or (not (eq last-command-event 'Default)) 1693 (setq last-command-event 'English)) 1694 (setq language-name (symbol-name last-command-event))) 1695 (prog1 1696 (set-language-environment language-name) 1697 (customize-mark-as-set 'current-language-environment)) 1698 (error "Bogus calling sequence")))) 1699 1700(defcustom current-language-environment "English" 1701 "The last language environment specified with `set-language-environment'. 1702This variable should be set only with \\[customize], which is equivalent 1703to using the function `set-language-environment'." 1704 :link '(custom-manual "(emacs)Language Environments") 1705 :set (lambda (symbol value) (set-language-environment value)) 1706 :get (lambda (x) 1707 (or (car-safe (assoc-string 1708 (if (symbolp current-language-environment) 1709 (symbol-name current-language-environment) 1710 current-language-environment) 1711 language-info-alist t)) 1712 "English")) 1713 ;; custom type will be updated with `set-language-info'. 1714 :type (if language-info-alist 1715 (cons 'choice (mapcar 1716 (lambda (lang) 1717 (list 'const lang)) 1718 (sort (mapcar 'car language-info-alist) 'string<))) 1719 'string) 1720 :initialize 'custom-initialize-default 1721 :group 'mule) 1722 1723(defun reset-language-environment () 1724 "Reset multilingual environment of Emacs to the default status. 1725 1726The default status is as follows: 1727 1728 The default value of `buffer-file-coding-system' is nil. 1729 The default coding system for process I/O is nil. 1730 The default value for the command `set-terminal-coding-system' is nil. 1731 The default value for the command `set-keyboard-coding-system' is nil. 1732 1733 The order of priorities of coding categories and the coding system 1734 bound to each category are as follows 1735 coding category coding system 1736 -------------------------------------------------- 1737 coding-category-iso-8-1 iso-latin-1 1738 coding-category-iso-8-2 iso-latin-1 1739 coding-category-utf-8 mule-utf-8 1740 coding-category-utf-16-be mule-utf-16be-with-signature 1741 coding-category-utf-16-le mule-utf-16le-with-signature 1742 coding-category-iso-7-tight iso-2022-jp 1743 coding-category-iso-7 iso-2022-7bit 1744 coding-category-iso-7-else iso-2022-7bit-lock 1745 coding-category-iso-8-else iso-2022-8bit-ss2 1746 coding-category-emacs-mule emacs-mule 1747 coding-category-raw-text raw-text 1748 coding-category-sjis japanese-shift-jis 1749 coding-category-big5 chinese-big5 1750 coding-category-ccl nil 1751 coding-category-binary no-conversion" 1752 (interactive) 1753 ;; This function formerly set default-enable-multibyte-characters to t, 1754 ;; but that is incorrect. It should not alter the unibyte/multibyte choice. 1755 1756 (setq coding-category-iso-7-tight 'iso-2022-jp 1757 coding-category-iso-7 'iso-2022-7bit 1758 coding-category-iso-8-1 'iso-latin-1 1759 coding-category-iso-8-2 'iso-latin-1 1760 coding-category-iso-7-else 'iso-2022-7bit-lock 1761 coding-category-iso-8-else 'iso-2022-8bit-ss2 1762 coding-category-emacs-mule 'emacs-mule 1763 coding-category-raw-text 'raw-text 1764 coding-category-sjis 'japanese-shift-jis 1765 coding-category-big5 'chinese-big5 1766 coding-category-utf-16-be 'mule-utf-16be-with-signature 1767 coding-category-utf-16-le 'mule-utf-16le-with-signature 1768 coding-category-utf-8 'mule-utf-8 1769 coding-category-ccl nil 1770 coding-category-binary 'no-conversion) 1771 1772 (set-coding-priority 1773 '(coding-category-iso-8-1 1774 coding-category-iso-8-2 1775 coding-category-utf-8 1776 coding-category-utf-16-be 1777 coding-category-utf-16-le 1778 coding-category-iso-7-tight 1779 coding-category-iso-7 1780 coding-category-iso-7-else 1781 coding-category-iso-8-else 1782 coding-category-emacs-mule 1783 coding-category-raw-text 1784 coding-category-sjis 1785 coding-category-big5 1786 coding-category-ccl 1787 coding-category-binary)) 1788 1789 ;; Changing the binding of a coding category requires this call. 1790 (update-coding-systems-internal) 1791 1792 (set-default-coding-systems nil) 1793 (setq default-sendmail-coding-system 'iso-latin-1) 1794 ;; On Darwin systems, this should be utf-8, but when this file is loaded 1795 ;; utf-8 is not yet defined, so we set it in set-locale-environment instead. 1796 (setq default-file-name-coding-system 'iso-latin-1) 1797 ;; Preserve eol-type from existing default-process-coding-systems. 1798 ;; On non-unix-like systems in particular, these may have been set 1799 ;; carefully by the user, or by the startup code, to deal with the 1800 ;; users shell appropriately, so should not be altered by changing 1801 ;; language environment. 1802 (let ((output-coding 1803 ;; When bootstrapping, coding-systems are not defined yet, so 1804 ;; we need to catch the error from check-coding-system. 1805 (condition-case nil 1806 (coding-system-change-text-conversion 1807 (car default-process-coding-system) 'undecided) 1808 (coding-system-error 'undecided))) 1809 (input-coding 1810 (condition-case nil 1811 (coding-system-change-text-conversion 1812 (cdr default-process-coding-system) 'iso-latin-1) 1813 (coding-system-error 'iso-latin-1)))) 1814 (setq default-process-coding-system 1815 (cons output-coding input-coding))) 1816 1817 ;; Don't alter the terminal and keyboard coding systems here. 1818 ;; The terminal still supports the same coding system 1819 ;; that it supported a minute ago. 1820 ;; (set-terminal-coding-system-internal nil) 1821 ;; (set-keyboard-coding-system-internal nil) 1822 1823 (setq nonascii-translation-table nil 1824 nonascii-insert-offset 0) 1825 1826 ;; Don't invoke fontset-related functions if fontsets aren't 1827 ;; supported in this build of Emacs. 1828 (and (fboundp 'fontset-list) 1829 (set-overriding-fontspec-internal nil))) 1830 1831(reset-language-environment) 1832 1833(defun set-display-table-and-terminal-coding-system (language-name &optional coding-system) 1834 "Set up the display table and terminal coding system for LANGUAGE-NAME." 1835 (let ((coding (get-language-info language-name 'unibyte-display))) 1836 (if (and coding 1837 (or (not coding-system) 1838 (coding-system-equal coding coding-system))) 1839 (standard-display-european-internal) 1840 ;; The following 2 lines undo the 8-bit display that we set up 1841 ;; in standard-display-european-internal, which see. This is in 1842 ;; case the user has used standard-display-european earlier in 1843 ;; this session. (The MS-DOS port doesn't use that setup, so it 1844 ;; doesn't need to undo it.) 1845 (when standard-display-table 1846 (dotimes (i 128) 1847 (aset standard-display-table (+ i 128) nil)))) 1848 (or (eq window-system 'pc) 1849 (set-terminal-coding-system (or coding-system coding))))) 1850 1851(defun set-language-environment (language-name) 1852 "Set up multi-lingual environment for using LANGUAGE-NAME. 1853This sets the coding system priority and the default input method 1854and sometimes other things. LANGUAGE-NAME should be a string 1855which is the name of a language environment. For example, \"Latin-1\" 1856specifies the character set for the major languages of Western Europe." 1857 (interactive (list (read-language-name 1858 nil 1859 "Set language environment (default English): "))) 1860 (if language-name 1861 (if (symbolp language-name) 1862 (setq language-name (symbol-name language-name))) 1863 (setq language-name "English")) 1864 (let ((slot (assoc-string language-name language-info-alist t))) 1865 (unless slot 1866 (error "Language environment not defined: %S" language-name)) 1867 (setq language-name (car slot))) 1868 (if current-language-environment 1869 (let ((func (get-language-info current-language-environment 1870 'exit-function))) 1871 (run-hooks 'exit-language-environment-hook) 1872 (if (functionp func) (funcall func)))) 1873 1874 (reset-language-environment) 1875 ;; The features might set up coding systems. 1876 (let ((required-features (get-language-info language-name 'features))) 1877 (while required-features 1878 (require (car required-features)) 1879 (setq required-features (cdr required-features)))) 1880 1881 (setq current-language-environment language-name) 1882 1883 (set-language-environment-coding-systems language-name) 1884 (set-language-environment-input-method language-name) 1885 (set-language-environment-nonascii-translation language-name) 1886 (set-language-environment-charset language-name) 1887 (set-language-environment-fontset language-name) 1888 ;; Unibyte setups if necessary. 1889 (unless default-enable-multibyte-characters 1890 (set-language-environment-unibyte language-name)) 1891 1892 (let ((func (get-language-info language-name 'setup-function))) 1893 (if (functionp func) 1894 (funcall func))) 1895 1896 (run-hooks 'set-language-environment-hook) 1897 (force-mode-line-update t)) 1898 1899(defun standard-display-european-internal () 1900 ;; Actually set up direct output of non-ASCII characters. 1901 (standard-display-8bit (if (eq window-system 'pc) 128 160) 255) 1902 ;; Unibyte Emacs on MS-DOS wants to display all 8-bit characters with 1903 ;; the native font, and codes 160 and 146 stand for something very 1904 ;; different there. 1905 (or (and (eq window-system 'pc) (not default-enable-multibyte-characters)) 1906 (progn 1907 ;; Most X fonts used to do the wrong thing for latin-1 code 160. 1908 (unless (and (eq window-system 'x) 1909 ;; XFree86 4 has fixed the fonts. 1910 (string= "The XFree86 Project, Inc" (x-server-vendor)) 1911 (> (aref (number-to-string (nth 2 (x-server-version))) 0) 1912 ?3)) 1913 ;; Make non-line-break space display as a plain space. 1914 (aset standard-display-table 160 [32])) 1915 ;; Most Windows programs send out apostrophes as \222. Most X fonts 1916 ;; don't contain a character at that position. Map it to the ASCII 1917 ;; apostrophe. [This is actually RIGHT SINGLE QUOTATION MARK, 1918 ;; U+2019, normally from the windows-1252 character set. XFree 4 1919 ;; fonts probably have the appropriate glyph at this position, 1920 ;; so they could use standard-display-8bit. It's better to use a 1921 ;; proper windows-1252 coding system. --fx] 1922 (aset standard-display-table 146 [39])))) 1923 1924(defun set-language-environment-coding-systems (language-name) 1925 "Do various coding system setups for language environment LANGUAGE-NAME." 1926 (let* ((priority (get-language-info language-name 'coding-priority)) 1927 (default-coding (car priority)) 1928 (eol-type (coding-system-eol-type default-buffer-file-coding-system))) 1929 (if priority 1930 (let ((categories (mapcar 'coding-system-category priority))) 1931 (set-default-coding-systems 1932 (if (memq eol-type '(0 1 2 unix dos mac)) 1933 (coding-system-change-eol-conversion default-coding eol-type) 1934 default-coding)) 1935 (setq default-sendmail-coding-system default-coding) 1936 (set-coding-priority categories) 1937 (while priority 1938 (set (car categories) (car priority)) 1939 (setq priority (cdr priority) categories (cdr categories))) 1940 ;; Changing the binding of a coding category requires this call. 1941 (update-coding-systems-internal))))) 1942 1943(defun set-language-environment-input-method (language-name) 1944 "Do various input method setups for language environment LANGUAGE-NAME." 1945 (let ((input-method (get-language-info language-name 'input-method))) 1946 (when input-method 1947 (setq default-input-method input-method) 1948 (if input-method-history 1949 (setq input-method-history 1950 (cons input-method 1951 (delete input-method input-method-history))))))) 1952 1953(defun set-language-environment-nonascii-translation (language-name) 1954 "Do unibyte/multibyte translation setup for language environment LANGUAGE-NAME." 1955 (let ((nonascii (get-language-info language-name 'nonascii-translation)) 1956 (dos-table 1957 (if (eq window-system 'pc) 1958 (intern 1959 (format "cp%d-nonascii-translation-table" dos-codepage))))) 1960 (cond 1961 ((char-table-p nonascii) 1962 (setq nonascii-translation-table nonascii)) 1963 ((and (eq window-system 'pc) (boundp dos-table)) 1964 ;; DOS terminals' default is to use a special non-ASCII translation 1965 ;; table as appropriate for the installed codepage. 1966 (setq nonascii-translation-table (symbol-value dos-table))) 1967 ((charsetp nonascii) 1968 (setq nonascii-insert-offset (- (make-char nonascii) 128)))))) 1969 1970(defun set-language-environment-charset (language-name) 1971 "Do various charset setups for language environment LANGUAGE-NAME." 1972 (if (and utf-translate-cjk-mode 1973 (not (eq utf-translate-cjk-lang-env language-name)) 1974 (catch 'tag 1975 (dolist (charset (get-language-info language-name 'charset)) 1976 (if (memq charset utf-translate-cjk-charsets) 1977 (throw 'tag t))) 1978 nil)) 1979 (utf-translate-cjk-load-tables))) 1980 1981(defun set-language-environment-fontset (language-name) 1982 "Do various fontset setups for language environment LANGUAGE-NAME." 1983 ;; Don't invoke fontset-related functions if fontsets aren't 1984 ;; supported in this build of Emacs. 1985 (if (fboundp 'fontset-list) 1986 (set-overriding-fontspec-internal 1987 (get-language-info language-name 'overriding-fontspec)))) 1988 1989(defun set-language-environment-unibyte (language-name) 1990 "Do various unibyte-mode setups for language environment LANGUAGE-NAME." 1991 ;; Syntax and case table. 1992 (let ((syntax (get-language-info language-name 'unibyte-syntax))) 1993 (if syntax 1994 (let ((set-case-syntax-set-multibyte nil)) 1995 (load syntax nil t)) 1996 ;; No information for syntax and case. Reset to the defaults. 1997 (let ((syntax-table (standard-syntax-table)) 1998 (standard-table (standard-case-table)) 1999 (case-table (make-char-table 'case-table)) 2000 (ch (if (eq window-system 'pc) 128 160))) 2001 (while (< ch 256) 2002 (modify-syntax-entry ch " " syntax-table) 2003 (setq ch (1+ ch))) 2004 (dotimes (i 128) 2005 (aset case-table i (aref standard-table i))) 2006 (set-char-table-extra-slot case-table 0 nil) 2007 (set-char-table-extra-slot case-table 1 nil) 2008 (set-char-table-extra-slot case-table 2 nil) 2009 (set-standard-case-table case-table)) 2010 (let ((list (buffer-list))) 2011 (while list 2012 (with-current-buffer (car list) 2013 (set-case-table (standard-case-table))) 2014 (setq list (cdr list)))))) 2015 (set-display-table-and-terminal-coding-system language-name)) 2016 2017(defsubst princ-list (&rest args) 2018 "Print all arguments with `princ', then print \"\n\"." 2019 (while args (princ (car args)) (setq args (cdr args))) 2020 (princ "\n")) 2021 2022(put 'describe-specified-language-support 'apropos-inhibit t) 2023 2024;; Print language-specific information such as input methods, 2025;; charsets, and coding systems. This function is intended to be 2026;; called from the menu: 2027;; [menu-bar mule describe-language-environment LANGUAGE] 2028;; and should not run it by `M-x describe-current-input-method-function'. 2029(defun describe-specified-language-support () 2030 "Describe how Emacs supports the specified language environment." 2031 (interactive) 2032 (let (language-name) 2033 (if (not (and (symbolp last-command-event) 2034 (or (not (eq last-command-event 'Default)) 2035 (setq last-command-event 'English)) 2036 (setq language-name (symbol-name last-command-event)))) 2037 (error "Bogus calling sequence")) 2038 (describe-language-environment language-name))) 2039 2040(defun describe-language-environment (language-name) 2041 "Describe how Emacs supports language environment LANGUAGE-NAME." 2042 (interactive 2043 (list (read-language-name 2044 'documentation 2045 "Describe language environment (default current choice): "))) 2046 (if (null language-name) 2047 (setq language-name current-language-environment)) 2048 (if (or (null language-name) 2049 (null (get-language-info language-name 'documentation))) 2050 (error "No documentation for the specified language")) 2051 (if (symbolp language-name) 2052 (setq language-name (symbol-name language-name))) 2053 (dolist (feature (get-language-info language-name 'features)) 2054 (require feature)) 2055 (let ((doc (get-language-info language-name 'documentation))) 2056 (help-setup-xref (list #'describe-language-environment language-name) 2057 (interactive-p)) 2058 (with-output-to-temp-buffer (help-buffer) 2059 (save-excursion 2060 (set-buffer standard-output) 2061 (insert language-name " language environment\n\n") 2062 (if (stringp doc) 2063 (insert doc "\n\n")) 2064 (condition-case nil 2065 (let ((str (eval (get-language-info language-name 'sample-text)))) 2066 (if (stringp str) 2067 (insert "Sample text:\n " str "\n\n"))) 2068 (error nil)) 2069 (let ((input-method (get-language-info language-name 'input-method)) 2070 (l (copy-sequence input-method-alist))) 2071 (insert "Input methods") 2072 (when input-method 2073 (insert " (default " input-method ")") 2074 (setq input-method (assoc input-method input-method-alist)) 2075 (setq l (cons input-method (delete input-method l)))) 2076 (insert ":\n") 2077 (while l 2078 (when (string= language-name (nth 1 (car l))) 2079 (insert " " (car (car l))) 2080 (search-backward (car (car l))) 2081 (help-xref-button 0 'help-input-method (car (car l))) 2082 (goto-char (point-max)) 2083 (insert " (\"" 2084 (if (stringp (nth 3 (car l))) 2085 (nth 3 (car l)) 2086 (car (nth 3 (car l)))) 2087 "\" in mode line)\n")) 2088 (setq l (cdr l))) 2089 (insert "\n")) 2090 (insert "Character sets:\n") 2091 (let ((l (get-language-info language-name 'charset))) 2092 (if (null l) 2093 (insert " nothing specific to " language-name "\n") 2094 (while l 2095 (insert " " (symbol-name (car l))) 2096 (search-backward (symbol-name (car l))) 2097 (help-xref-button 0 'help-character-set (car l)) 2098 (goto-char (point-max)) 2099 (insert ": " (charset-description (car l)) "\n") 2100 (setq l (cdr l))))) 2101 (insert "\n") 2102 (insert "Coding systems:\n") 2103 (let ((l (get-language-info language-name 'coding-system))) 2104 (if (null l) 2105 (insert " nothing specific to " language-name "\n") 2106 (while l 2107 (insert " " (symbol-name (car l))) 2108 (search-backward (symbol-name (car l))) 2109 (help-xref-button 0 'help-coding-system (car l)) 2110 (goto-char (point-max)) 2111 (insert " (`" 2112 (coding-system-mnemonic (car l)) 2113 "' in mode line):\n\t" 2114 (coding-system-doc-string (car l)) 2115 "\n") 2116 (let ((aliases (coding-system-get (car l) 2117 'alias-coding-systems))) 2118 (when aliases 2119 (insert "\t(alias:") 2120 (while aliases 2121 (insert " " (symbol-name (car aliases))) 2122 (setq aliases (cdr aliases))) 2123 (insert ")\n"))) 2124 (setq l (cdr l))))))))) 2125 2126;;; Locales. 2127 2128(defvar locale-translation-file-name nil 2129 "File name for the system's file of locale-name aliases, or nil if none.") 2130 2131;; The following definitions might as well be marked as constants and 2132;; purecopied, since they're normally used on startup, and probably 2133;; should reflect the facilities of the base Emacs. 2134(defconst locale-language-names 2135 (purecopy 2136 '( 2137 ;; Locale names of the form LANGUAGE[_TERRITORY][.CODESET][@MODIFIER] 2138 ;; as specified in the Single Unix Spec, Version 2. 2139 ;; LANGUAGE is a language code taken from ISO 639:1988 (E/F) 2140 ;; with additions from ISO 639/RA Newsletter No.1/1989; 2141 ;; see Internet RFC 2165 (1997-06) and 2142 ;; http://www.evertype.com/standards/iso639/iso639-en.html 2143 ;; TERRITORY is a country code taken from ISO 3166 2144 ;; http://www.din.de/gremien/nas/nabd/iso3166ma/codlstp1/en_listp1.html. 2145 ;; CODESET and MODIFIER are implementation-dependent. 2146 2147 ;; jasonr comments: MS Windows uses three letter codes for 2148 ;; languages instead of the two letter ISO codes that POSIX 2149 ;; uses. In most cases the first two letters are the same, so 2150 ;; most of the regexps in locale-language-names work. Japanese 2151 ;; and Chinese are exceptions, which are listed in the 2152 ;; non-standard section at the bottom of locale-language-names. 2153 2154 ("aa_DJ" . "Latin-1") ; Afar 2155 ("aa" . "UTF-8") 2156 ;; ab Abkhazian 2157 ("af" . "Latin-1") ; Afrikaans 2158 ("am" "Ethiopic" utf-8) ; Amharic 2159 ("an" . "Latin-9") ; Aragonese 2160 ; ar Arabic glibc uses 8859-6 2161 ; as Assamese 2162 ; ay Aymara 2163 ("az" . "UTF-8") ; Azerbaijani 2164 ; ba Bashkir 2165 ("be" "Belarusian" cp1251) ; Belarusian [Byelorussian until early 1990s] 2166 ("bg" "Bulgarian" cp1251) ; Bulgarian 2167 ; bh Bihari 2168 ; bi Bislama 2169 ("bn" . "UTF-8") ; Bengali, Bangla 2170 ("bo" . "Tibetan") 2171 ("br" . "Latin-1") ; Breton 2172 ("bs" . "Latin-2") ; Bosnian 2173 ("byn" . "UTF-8") ; Bilin; Blin 2174 ("ca" . "Latin-1") ; Catalan 2175 ; co Corsican 2176 ("cs" "Czech" iso-8859-2) 2177 ("cy" "Welsh" iso-8859-14) 2178 ("da" . "Latin-1") ; Danish 2179 ("de" "German" iso-8859-1) 2180 ; dv Divehi 2181 ; dz Bhutani 2182 ("el" "Greek" iso-8859-7) 2183 ;; Users who specify "en" explicitly typically want Latin-1, not ASCII. 2184 ;; That's actually what the GNU locales define, modulo things like 2185 ;; en_IN -- fx. 2186 ("en_IN" "English" utf-8) ; glibc uses utf-8 for English in India 2187 ("en" "English" iso-8859-1) ; English 2188 ("eo" . "Esperanto") ; Esperanto 2189 ("es" "Spanish" iso-8859-1) 2190 ("et" . "Latin-1") ; Estonian 2191 ("eu" . "Latin-1") ; Basque 2192 ("fa" . "UTF-8") ; Persian 2193 ("fi" . "Latin-1") ; Finnish 2194 ("fj" . "Latin-1") ; Fiji 2195 ("fo" . "Latin-1") ; Faroese 2196 ("fr" "French" iso-8859-1) ; French 2197 ("fy" . "Latin-1") ; Frisian 2198 ("ga" . "Latin-1") ; Irish Gaelic (new orthography) 2199 ("gd" . "Latin-9") ; Scots Gaelic 2200 ("gez" "Ethiopic" utf-8) ; Geez 2201 ("gl" . "Latin-1") ; Gallegan; Galician 2202 ; gn Guarani 2203 ("gu" . "UTF-8") ; Gujarati 2204 ("gv" . "Latin-1") ; Manx Gaelic 2205 ; ha Hausa 2206 ("he" "Hebrew" iso-8859-8) 2207 ("hi" "Devanagari" utf-8) ; Hindi 2208 ("hr" "Croatian" iso-8859-2) ; Croatian 2209 ("hu" . "Latin-2") ; Hungarian 2210 ; hy Armenian 2211 ; ia Interlingua 2212 ("id" . "Latin-1") ; Indonesian 2213 ; ie Interlingue 2214 ; ik Inupiak 2215 ("is" . "Latin-1") ; Icelandic 2216 ("it" "Italian" iso-8859-1) ; Italian 2217 ; iu Inuktitut 2218 ("iw" "Hebrew" iso-8859-8) 2219 ("ja" "Japanese" euc-jp) 2220 ; jw Javanese 2221 ("ka" "Georgian" georgian-ps) ; Georgian 2222 ; kk Kazakh 2223 ("kl" . "Latin-1") ; Greenlandic 2224 ; km Cambodian 2225 ("kn" "Kannada" utf-8) 2226 ("ko" "Korean" euc-kr) 2227 ; ks Kashmiri 2228 ; ku Kurdish 2229 ("kw" . "Latin-1") ; Cornish 2230 ; ky Kirghiz 2231 ("la" . "Latin-1") ; Latin 2232 ("lb" . "Latin-1") ; Luxemburgish 2233 ("lg" . "Laint-6") ; Ganda 2234 ; ln Lingala 2235 ("lo" "Lao" utf-8) ; Laothian 2236 ("lt" "Lithuanian" iso-8859-13) 2237 ("lv" . "Latvian") ; Latvian, Lettish 2238 ; mg Malagasy 2239 ("mi" . "Latin-7") ; Maori 2240 ("mk" "Cyrillic-ISO" iso-8859-5) ; Macedonian 2241 ("ml" "Malayalam" utf-8) 2242 ("mn" . "UTF-8") ; Mongolian 2243 ; mo Moldavian 2244 ("mr" "Devanagari" utf-8) ; Marathi 2245 ("ms" . "Latin-1") ; Malay 2246 ("mt" . "Latin-3") ; Maltese 2247 ; my Burmese 2248 ; na Nauru 2249 ("nb" . "Latin-1") ; Norwegian 2250 ("ne" "Devanagari" utf-8) ; Nepali 2251 ("nl" "Dutch" iso-8859-1) 2252 ("no" . "Latin-1") ; Norwegian 2253 ("oc" . "Latin-1") ; Occitan 2254 ("om_ET" . "UTF-8") ; (Afan) Oromo 2255 ("om" . "Latin-1") ; (Afan) Oromo 2256 ; or Oriya 2257 ("pa" . "UTF-8") ; Punjabi 2258 ("pl" . "Latin-2") ; Polish 2259 ; ps Pashto, Pushto 2260 ("pt" . "Latin-1") ; Portuguese 2261 ; qu Quechua 2262 ("rm" . "Latin-1") ; Rhaeto-Romanic 2263 ; rn Kirundi 2264 ("ro" "Romanian" iso-8859-2) 2265 ("ru_RU" "Russian" iso-8859-5) 2266 ("ru_UA" "Russian" koi8-u) 2267 ; rw Kinyarwanda 2268 ("sa" . "Devanagari") ; Sanskrit 2269 ; sd Sindhi 2270 ("se" . "UTF-8") ; Northern Sami 2271 ; sg Sangho 2272 ("sh" . "Latin-2") ; Serbo-Croatian 2273 ; si Sinhalese 2274 ("sid" . "UTF-8") ; Sidamo 2275 ("sk" "Slovak" iso-8859-2) 2276 ("sl" "Slovenian" iso-8859-2) 2277 ; sm Samoan 2278 ; sn Shona 2279 ("so_ET" "UTF-8") ; Somali 2280 ("so" "Latin-1") ; Somali 2281 ("sq" . "Latin-1") ; Albanian 2282 ("sr_YU@cyrillic" . "Cyrillic-ISO") ; Serbian (Cyrillic alphabet) 2283 ("sr" . "Latin-2") ; Serbian (Latin alphabet) 2284 ; ss Siswati 2285 ("st" . "Latin-1") ; Sesotho 2286 ; su Sundanese 2287 ("sv" "Swedish" iso-8859-1) ; Swedish 2288 ("sw" . "Latin-1") ; Swahili 2289 ("ta" "Tamil" utf-8) 2290 ("te" . "UTF-8") ; Telugu 2291 ("tg" "Tajik" koi8-t) 2292 ("th" "Thai" tis-620) 2293 ("ti" "Ethiopic" utf-8) ; Tigrinya 2294 ("tig_ER" . "UTF-8") ; Tigre 2295 ; tk Turkmen 2296 ("tl" . "Latin-1") ; Tagalog 2297 ; tn Setswana 2298 ; to Tonga 2299 ("tr" "Turkish" iso-8859-9) 2300 ; ts Tsonga 2301 ("tt" . "UTF-8") ; Tatar 2302 ; tw Twi 2303 ; ug Uighur 2304 ("uk" "Ukrainian" koi8-u) 2305 ("ur" . "UTF-8") ; Urdu 2306 ("uz_UZ@cyrillic" . "UTF-8"); Uzbek 2307 ("uz" . "Latin-1") ; Uzbek 2308 ("vi" "Vietnamese" utf-8) 2309 ; vo Volapuk 2310 ("wa" . "Latin-1") ; Walloon 2311 ; wo Wolof 2312 ("xh" . "Latin-1") ; Xhosa 2313 ("yi" . "Windows-1255") ; Yiddish 2314 ; yo Yoruba 2315 ; za Zhuang 2316 ("zh_HK" . "Chinese-Big5") 2317 ("zh_TW" . "Chinese-Big5") 2318 ("zh_CN" . "Chinese-GB") 2319 ("zh" . "Chinese-GB") 2320 ; zh_CN.GB18030/GB18030 \ 2321 ; zh_CN.GBK/GBK \ 2322 ; zh_HK/BIG5-HKSCS \ 2323 ("zu" . "Latin-1") ; Zulu 2324 2325 ;; ISO standard locales 2326 ("c$" . "ASCII") 2327 ("posix$" . "ASCII") 2328 2329 ;; The "IPA" Emacs language environment does not correspond 2330 ;; to any ISO 639 code, so let it stand for itself. 2331 ("ipa$" . "IPA") 2332 2333 ;; Nonstandard or obsolete language codes 2334 ("cz" . "Czech") ; e.g. Solaris 2.6 2335 ("ee" . "Latin-4") ; Estonian, e.g. X11R6.4 2336 ("iw" . "Hebrew") ; e.g. X11R6.4 2337 ("sp" . "Cyrillic-ISO") ; Serbian (Cyrillic alphabet), e.g. X11R6.4 2338 ("su" . "Latin-1") ; Finnish, e.g. Solaris 2.6 2339 ("jp" . "Japanese") ; e.g. MS Windows 2340 ("chs" . "Chinese-GB") ; MS Windows Chinese Simplified 2341 ("cht" . "Chinese-BIG5") ; MS Windows Chinese Traditional 2342 ("gbz" . "UTF-8") ; MS Windows Dari Persian 2343 ("div" . "UTF-8") ; MS Windows Divehi (Maldives) 2344 ("wee" . "Latin-2") ; MS Windows Lower Sorbian 2345 ("wen" . "Latin-2") ; MS Windows Upper Sorbian 2346 )) 2347 "Alist of locale regexps vs the corresponding languages and coding systems. 2348Each element has these form: 2349 \(LOCALE-REGEXP LANG-ENV CODING-SYSTEM) 2350The first element whose LOCALE-REGEXP matches the start of a 2351downcased locale specifies the LANG-ENV \(language environtment) 2352and CODING-SYSTEM corresponding to that locale. If there is no 2353appropriate language environment, the element may have this form: 2354 \(LOCALE-REGEXP . LANG-ENV) 2355In this case, LANG-ENV is one of generic language environments for an 2356specific encoding such as \"Latin-1\" and \"UTF-8\".") 2357 2358(defconst locale-charset-language-names 2359 (purecopy 2360 '((".*8859[-_]?1\\>" . "Latin-1") 2361 (".*8859[-_]?2\\>" . "Latin-2") 2362 (".*8859[-_]?3\\>" . "Latin-3") 2363 (".*8859[-_]?4\\>" . "Latin-4") 2364 (".*8859[-_]?9\\>" . "Latin-5") 2365 (".*8859[-_]?14\\>" . "Latin-8") 2366 (".*8859[-_]?15\\>" . "Latin-9") 2367 (".*utf\\(?:-?8\\)?\\>" . "UTF-8") 2368 ;; utf-8@euro exists, so put this last. (@euro really specifies 2369 ;; the currency, rather than the charset.) 2370 (".*@euro\\>" . "Latin-9"))) 2371 "List of pairs of locale regexps and charset language names. 2372The first element whose locale regexp matches the start of a downcased locale 2373specifies the language name whose charset corresponds to that locale. 2374This language name is used if the locale is not listed in 2375`locale-language-names'") 2376 2377(defconst locale-preferred-coding-systems 2378 (purecopy 2379 '((".*8859[-_]?1\\>" . iso-8859-1) 2380 (".*8859[-_]?2\\>" . iso-8859-2) 2381 (".*8859[-_]?3\\>" . iso-8859-3) 2382 (".*8859[-_]?4\\>" . iso-8859-4) 2383 (".*8859[-_]?9\\>" . iso-8859-9) 2384 (".*8859[-_]?14\\>" . iso-8859-14) 2385 (".*8859[-_]?15\\>" . iso-8859-15) 2386 (".*utf\\(?:-?8\\)?" . utf-8) 2387 ;; utf-8@euro exists, so put this after utf-8. (@euro really 2388 ;; specifies the currency, rather than the charset.) 2389 (".*@euro" . iso-8859-15) 2390 ("koi8-?r" . koi8-r) 2391 ("koi8-?u" . koi8-u) 2392 ("tcvn" . tcvn) 2393 ("big5" . big5) 2394 ("euc-?tw" . euc-tw) 2395 ;; We don't support GBK, but as it is upper compatible with 2396 ;; GB-2312, we setup the default coding system to gb2312. 2397 ("gbk" . gb2312) 2398 ;; We don't support BIG5-HKSCS, but as it is upper compatible with 2399 ;; BIG5, we setup the default coding system to big5. 2400 ("big5hkscs" . big5) 2401 ("ja.*[._]euc" . japanese-iso-8bit) 2402 ("ja.*[._]jis7" . iso-2022-jp) 2403 ("ja.*[._]pck" . japanese-shift-jis) 2404 ("ja.*[._]sjis" . japanese-shift-jis) 2405 ("jpn" . japanese-shift-jis) ; MS-Windows uses this. 2406 )) 2407 "List of pairs of locale regexps and preferred coding systems. 2408The first element whose locale regexp matches the start of a downcased locale 2409specifies the coding system to prefer when using that locale. 2410This coding system is used if the locale specifies a specific charset.") 2411 2412(defun locale-name-match (key alist) 2413 "Search for KEY in ALIST, which should be a list of regexp-value pairs. 2414Return the value corresponding to the first regexp that matches the 2415start of KEY, or nil if there is no match." 2416 (let (element) 2417 (while (and alist (not element)) 2418 (if (string-match (concat "\\`\\(?:" (car (car alist)) "\\)") key) 2419 (setq element (car alist))) 2420 (setq alist (cdr alist))) 2421 (cdr element))) 2422 2423(defun locale-charset-match-p (charset1 charset2) 2424 "Whether charset names (strings) CHARSET1 and CHARSET2 are equivalent. 2425Matching is done ignoring case and any hyphens and underscores in the 2426names. E.g. `ISO_8859-1' and `iso88591' both match `iso-8859-1'." 2427 (setq charset1 (replace-regexp-in-string "[-_]" "" charset1)) 2428 (setq charset2 (replace-regexp-in-string "[-_]" "" charset2)) 2429 (eq t (compare-strings charset1 nil nil charset2 nil nil t))) 2430 2431(defvar locale-charset-alist nil 2432 "Coding system alist keyed on locale-style charset name. 2433Used by `locale-charset-to-coding-system'.") 2434 2435(defun locale-charset-to-coding-system (charset) 2436 "Find coding system corresponding to CHARSET. 2437CHARSET is any sort of non-Emacs charset name, such as might be used 2438in a locale codeset, or elsewhere. It is matched to a coding system 2439first by case-insensitive lookup in `locale-charset-alist'. Then 2440matches are looked for in the coding system list, treating case and 2441the characters `-' and `_' as insignificant. The coding system base 2442is returned. Thus, for instance, if charset \"ISO8859-2\", 2443`iso-latin-2' is returned." 2444 (or (car (assoc-string charset locale-charset-alist t)) 2445 (let ((cs coding-system-alist) 2446 c) 2447 (while (and (not c) cs) 2448 (if (locale-charset-match-p charset (caar cs)) 2449 (setq c (intern (caar cs))) 2450 (pop cs))) 2451 (if c (coding-system-base c))))) 2452 2453;; Fixme: This ought to deal with the territory part of the locale 2454;; too, for setting things such as calendar holidays, ps-print paper 2455;; size, spelling dictionary. 2456 2457(defun set-locale-environment (&optional locale-name) 2458 "Set up multi-lingual environment for using LOCALE-NAME. 2459This sets the language environment, the coding system priority, 2460the default input method and sometimes other things. 2461 2462LOCALE-NAME should be a string which is the name of a locale supported 2463by the system. Often it is of the form xx_XX.CODE, where xx is a 2464language, XX is a country, and CODE specifies a character set and 2465coding system. For example, the locale name \"ja_JP.EUC\" might name 2466a locale for Japanese in Japan using the `japanese-iso-8bit' 2467coding-system. The name may also have a modifier suffix, e.g. `@euro' 2468or `@cyrillic'. 2469 2470If LOCALE-NAME is nil, its value is taken from the environment 2471variables LC_ALL, LC_CTYPE and LANG (the first one that is set). 2472 2473The locale names supported by your system can typically be found in a 2474directory named `/usr/share/locale' or `/usr/lib/locale'. LOCALE-NAME 2475will be translated according to the table specified by 2476`locale-translation-file-name'. 2477 2478See also `locale-charset-language-names', `locale-language-names', 2479`locale-preferred-coding-systems' and `locale-coding-system'." 2480 (interactive "sSet environment for locale: ") 2481 2482 ;; Do this at runtime for the sake of binaries possibly transported 2483 ;; to a system without X. 2484 (setq locale-translation-file-name 2485 (let ((files 2486 '("/usr/share/X11/locale/locale.alias" ; e.g. X11R7 2487 "/usr/lib/X11/locale/locale.alias" ; e.g. X11R6.4 2488 "/usr/X11R6/lib/X11/locale/locale.alias" ; XFree86, e.g. RedHat 4.2 2489 "/usr/openwin/lib/locale/locale.alias" ; e.g. Solaris 2.6 2490 ;; 2491 ;; The following name appears after the X-related names above, 2492 ;; since the X-related names are what X actually uses. 2493 "/usr/share/locale/locale.alias" ; GNU/Linux sans X 2494 ))) 2495 (while (and files (not (file-exists-p (car files)))) 2496 (setq files (cdr files))) 2497 (car files))) 2498 2499 (let ((locale locale-name)) 2500 2501 (unless locale 2502 ;; Use the first of these three environment variables 2503 ;; that has a nonempty value. 2504 (let ((vars '("LC_ALL" "LC_CTYPE" "LANG"))) 2505 (while (and vars 2506 (= 0 (length locale))) ; nil or empty string 2507 (setq locale (getenv (pop vars)))))) 2508 2509 (unless locale 2510 ;; The two tests are kept separate so the byte-compiler sees 2511 ;; that mac-get-preference is only called after checking its existence. 2512 (when (fboundp 'mac-get-preference) 2513 (setq locale (mac-get-preference "AppleLocale")) 2514 (unless locale 2515 (let ((languages (mac-get-preference "AppleLanguages"))) 2516 (unless (= (length languages) 0) ; nil or empty vector 2517 (setq locale (aref languages 0))))))) 2518 (unless (or locale (not (boundp 'mac-system-locale))) 2519 (setq locale mac-system-locale)) 2520 2521 (when locale 2522 2523 ;; Translate "swedish" into "sv_SE.ISO8859-1", and so on, 2524 ;; using the translation file that many systems have. 2525 (when locale-translation-file-name 2526 (with-temp-buffer 2527 (insert-file-contents locale-translation-file-name) 2528 (when (re-search-forward 2529 (concat "^" (regexp-quote locale) ":?[ \t]+") nil t) 2530 (setq locale (buffer-substring (point) (line-end-position)))))) 2531 2532 ;; Leave the system locales alone if the caller did not specify 2533 ;; an explicit locale name, as their defaults are set from 2534 ;; LC_MESSAGES and LC_TIME, not LC_CTYPE, and the user might not 2535 ;; want to set them to the same value as LC_CTYPE. 2536 (when locale-name 2537 (setq system-messages-locale locale) 2538 (setq system-time-locale locale)) 2539 2540 (setq locale (downcase locale)) 2541 2542 (let ((language-name 2543 (locale-name-match locale locale-language-names)) 2544 (charset-language-name 2545 (locale-name-match locale locale-charset-language-names)) 2546 (default-eol-type (coding-system-eol-type 2547 default-buffer-file-coding-system)) 2548 (coding-system 2549 (or (locale-name-match locale locale-preferred-coding-systems) 2550 (when locale 2551 (if (string-match "\\.\\([^@]+\\)" locale) 2552 (locale-charset-to-coding-system 2553 (match-string 1 locale)))) 2554 (and (eq system-type 'macos) mac-system-coding-system)))) 2555 2556 (if (consp language-name) 2557 ;; locale-language-names specify both lang-env and coding. 2558 ;; But, what specified in locale-preferred-coding-systems 2559 ;; has higher priority. 2560 (setq coding-system (or coding-system 2561 (nth 1 language-name)) 2562 language-name (car language-name)) 2563 ;; Otherwise, if locale is not listed in locale-language-names, 2564 ;; use what listed in locale-charset-language-names. 2565 (if (not language-name) 2566 (setq language-name charset-language-name))) 2567 2568 ;; If a specific EOL conversion was specified in the default 2569 ;; buffer-file-coding-system, preserve it in the coding system 2570 ;; we will be using from now on. 2571 (if (and (memq default-eol-type '(0 1 2 unix dos mac)) 2572 coding-system 2573 (coding-system-p coding-system)) 2574 (setq coding-system (coding-system-change-eol-conversion 2575 coding-system default-eol-type))) 2576 2577 (when language-name 2578 2579 ;; Set up for this character set. This is now the right way 2580 ;; to do it for both unibyte and multibyte modes. 2581 (set-language-environment language-name) 2582 2583 ;; If default-enable-multibyte-characters is nil, 2584 ;; we are using single-byte characters, 2585 ;; so the display table and terminal coding system are irrelevant. 2586 (when default-enable-multibyte-characters 2587 (set-display-table-and-terminal-coding-system 2588 language-name coding-system)) 2589 2590 ;; Set the `keyboard-coding-system' if appropriate (tty 2591 ;; only). At least X and MS Windows can generate 2592 ;; multilingual input. 2593 (unless window-system 2594 (let ((kcs (or coding-system 2595 (car (get-language-info language-name 2596 'coding-system))))) 2597 (if kcs (set-keyboard-coding-system kcs)))) 2598 2599 (setq locale-coding-system 2600 (car (get-language-info language-name 'coding-priority)))) 2601 2602 (when (and coding-system 2603 (not (coding-system-equal coding-system 2604 locale-coding-system))) 2605 (prefer-coding-system coding-system) 2606 ;; Fixme: perhaps prefer-coding-system should set this too. 2607 ;; But it's not the time to do such a fundamental change. 2608 (setq default-sendmail-coding-system coding-system) 2609 (setq locale-coding-system coding-system)))) 2610 2611 ;; On Windows, override locale-coding-system, 2612 ;; keyboard-coding-system with system codepage. Note: 2613 ;; selection-coding-system is already set in w32select.c. 2614 (when (boundp 'w32-ansi-code-page) 2615 (let ((code-page-coding (intern (format "cp%d" w32-ansi-code-page)))) 2616 (when (coding-system-p code-page-coding) 2617 (setq locale-coding-system code-page-coding) 2618 (set-keyboard-coding-system code-page-coding) 2619 (set-terminal-coding-system code-page-coding)))) 2620 2621 (when (eq system-type 'darwin) 2622 ;; On Darwin, file names are always encoded in utf-8, no matter 2623 ;; the locale. 2624 (setq default-file-name-coding-system 'utf-8) 2625 ;; Mac OS X's Terminal.app by default uses utf-8 regardless of 2626 ;; the locale. 2627 (when (and (null window-system) 2628 (equal (getenv "TERM_PROGRAM") "Apple_Terminal")) 2629 (set-terminal-coding-system 'utf-8) 2630 (set-keyboard-coding-system 'utf-8))) 2631 2632 ;; Default to A4 paper if we're not in a C, POSIX or US locale. 2633 ;; (See comments in Flocale_info.) 2634 (let ((locale locale) 2635 (paper (locale-info 'paper))) 2636 (if paper 2637 ;; This will always be null at the time of writing. 2638 (cond 2639 ((equal paper '(216 279)) 2640 (setq ps-paper-type 'letter)) 2641 ((equal paper '(210 297)) 2642 (setq ps-paper-type 'a4))) 2643 (let ((vars '("LC_ALL" "LC_PAPER" "LANG"))) 2644 (while (and vars (= 0 (length locale))) 2645 (setq locale (getenv (pop vars))))) 2646 (when locale 2647 ;; As of glibc 2.2.5, these are the only US Letter locales, 2648 ;; and the rest are A4. 2649 (setq ps-paper-type 2650 (or (locale-name-match locale '(("c$" . letter) 2651 ("posix$" . letter) 2652 (".._us" . letter) 2653 (".._pr" . letter) 2654 (".._ca" . letter) 2655 ("enu$" . letter) ; Windows 2656 ("esu$" . letter) 2657 ("enc$" . letter) 2658 ("frc$" . letter))) 2659 'a4)))))) 2660 nil) 2661 2662;;; Charset property 2663 2664(defun get-charset-property (charset propname) 2665 "Return the value of CHARSET's PROPNAME property. 2666This is the last value stored with 2667 (put-charset-property CHARSET PROPNAME VALUE)." 2668 (and (not (eq charset 'composition)) 2669 (plist-get (charset-plist charset) propname))) 2670 2671(defun put-charset-property (charset propname value) 2672 "Store CHARSETS's PROPNAME property with value VALUE. 2673It can be retrieved with `(get-charset-property CHARSET PROPNAME)'." 2674 (or (eq charset 'composition) 2675 (set-charset-plist charset 2676 (plist-put (charset-plist charset) propname value)))) 2677 2678;;; Character code property 2679(put 'char-code-property-table 'char-table-extra-slots 0) 2680 2681(defvar char-code-property-table 2682 (make-char-table 'char-code-property-table) 2683 "Char-table containing a property list of each character code. 2684 2685See also the documentation of `get-char-code-property' and 2686`put-char-code-property'.") 2687 2688(defun get-char-code-property (char propname) 2689 "Return the value of CHAR's PROPNAME property in `char-code-property-table'." 2690 (let ((plist (aref char-code-property-table char))) 2691 (if (listp plist) 2692 (car (cdr (memq propname plist)))))) 2693 2694(defun put-char-code-property (char propname value) 2695 "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. 2696It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." 2697 (let ((plist (aref char-code-property-table char))) 2698 (if plist 2699 (let ((slot (memq propname plist))) 2700 (if slot 2701 (setcar (cdr slot) value) 2702 (nconc plist (list propname value)))) 2703 (aset char-code-property-table char (list propname value))))) 2704 2705 2706;; Pretty description of encoded string 2707 2708;; Alist of ISO 2022 control code vs the corresponding mnemonic string. 2709(defvar iso-2022-control-alist 2710 '((?\x1b . "ESC") 2711 (?\x0e . "SO") 2712 (?\x0f . "SI") 2713 (?\x8e . "SS2") 2714 (?\x8f . "SS3") 2715 (?\x9b . "CSI"))) 2716 2717(defun encoded-string-description (str coding-system) 2718 "Return a pretty description of STR that is encoded by CODING-SYSTEM." 2719 (setq str (string-as-unibyte str)) 2720 (mapconcat 2721 (if (and coding-system (eq (coding-system-type coding-system) 2)) 2722 ;; Try to get a pretty description for ISO 2022 escape sequences. 2723 (function (lambda (x) (or (cdr (assq x iso-2022-control-alist)) 2724 (format "#x%02X" x)))) 2725 (function (lambda (x) (format "#x%02X" x)))) 2726 str " ")) 2727 2728(defun encode-coding-char (char coding-system) 2729 "Encode CHAR by CODING-SYSTEM and return the resulting string. 2730If CODING-SYSTEM can't safely encode CHAR, return nil." 2731 (let ((str1 (string-as-multibyte (char-to-string char))) 2732 (str2 (string-as-multibyte (make-string 2 char))) 2733 (safe-chars (and coding-system 2734 (coding-system-get coding-system 'safe-chars))) 2735 (charset (char-charset char)) 2736 enc1 enc2 i1 i2) 2737 (when (or (eq safe-chars t) 2738 (eq charset 'ascii) 2739 (and safe-chars (aref safe-chars char))) 2740 ;; We must find the encoded string of CHAR. But, just encoding 2741 ;; CHAR will put extra control sequences (usually to designate 2742 ;; ASCII charset) at the tail if type of CODING is ISO 2022. 2743 ;; To exclude such tailing bytes, we at first encode one-char 2744 ;; string and two-char string, then check how many bytes at the 2745 ;; tail of both encoded strings are the same. 2746 2747 (setq enc1 (encode-coding-string str1 coding-system) 2748 i1 (length enc1) 2749 enc2 (encode-coding-string str2 coding-system) 2750 i2 (length enc2)) 2751 (while (and (> i1 0) (= (aref enc1 (1- i1)) (aref enc2 (1- i2)))) 2752 (setq i1 (1- i1) i2 (1- i2))) 2753 2754 ;; Now (substring enc1 i1) and (substring enc2 i2) are the same, 2755 ;; and they are the extra control sequences at the tail to 2756 ;; exclude. 2757 (substring enc2 0 i2)))) 2758 2759 2760;; arch-tag: b382c432-4b36-460e-bf4c-05efd0bb18dc 2761;;; mule-cmds.el ends here 2762