Mercurial > hg > xemacs-beta
comparison lisp/mule/mule-cmds.el @ 428:3ecd8885ac67 r21-2-22
Import from CVS: tag r21-2-22
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 11:28:15 +0200 |
| parents | |
| children | 84b14dcb0985 |
comparison
equal
deleted
inserted
replaced
| 427:0a0253eac470 | 428:3ecd8885ac67 |
|---|---|
| 1 ;;; mule-cmds.el --- Commands for multilingual environment | |
| 2 | |
| 3 ;; Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN. | |
| 4 ;; Licensed to the Free Software Foundation. | |
| 5 ;; Copyright (C) 1997 MORIOKA Tomohiko | |
| 6 | |
| 7 ;; Keywords: mule, multilingual | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
| 11 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 12 ;; under the terms of the GNU General Public License as published by | |
| 13 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 14 ;; any later version. | |
| 15 | |
| 16 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 19 ;; General Public License for more details. | |
| 20 | |
| 21 ;; You should have received a copy of the GNU General Public License | |
| 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 24 ;; 02111-1307, USA. | |
| 25 | |
| 26 ;;; Code: | |
| 27 | |
| 28 ;;; MULE related key bindings and menus. | |
| 29 | |
| 30 (defvar mule-keymap (make-sparse-keymap "Mule") | |
| 31 "Keymap for Mule (Multilingual environment) specific commands.") | |
| 32 | |
| 33 ;; Keep "C-x C-m ..." for mule specific commands. | |
| 34 (define-key ctl-x-map "\C-m" mule-keymap) | |
| 35 | |
| 36 (define-key mule-keymap "f" 'set-buffer-file-coding-system) | |
| 37 (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs | |
| 38 (define-key mule-keymap "t" 'set-terminal-coding-system) | |
| 39 (define-key mule-keymap "k" 'set-keyboard-coding-system) | |
| 40 (define-key mule-keymap "p" 'set-buffer-process-coding-system) | |
| 41 (define-key mule-keymap "x" 'set-selection-coding-system) | |
| 42 (define-key mule-keymap "X" 'set-next-selection-coding-system) | |
| 43 (define-key mule-keymap "\C-\\" 'set-input-method) | |
| 44 (define-key mule-keymap "c" 'universal-coding-system-argument) | |
| 45 ;;(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs | |
| 46 (define-key mule-keymap "C" 'describe-coding-system) ; XEmacs | |
| 47 (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs | |
| 48 (define-key mule-keymap "l" 'set-language-environment) | |
| 49 | |
| 50 (define-key help-map "\C-L" 'describe-language-support) | |
| 51 (define-key help-map "L" 'describe-language-environment) | |
| 52 (define-key help-map "\C-\\" 'describe-input-method) | |
| 53 (define-key help-map "I" 'describe-input-method) | |
| 54 (define-key help-map "C" 'describe-coding-system) | |
| 55 (define-key help-map "h" 'view-hello-file) | |
| 56 | |
| 57 ;; Menu for XEmacs were moved to menubar-items.el. | |
| 58 | |
| 59 | |
| 60 ;; This should be a single character key binding because users use it | |
| 61 ;; very frequently while editing multilingual text. Now we can use | |
| 62 ;; only two such keys: "\C-\\" and "\C-^", but the latter is not | |
| 63 ;; convenient because it requires shifting on most keyboards. An | |
| 64 ;; alternative is "\C-\]" which is now bound to `abort-recursive-edit' | |
| 65 ;; but it won't be used that frequently. | |
| 66 (define-key global-map "\C-\\" 'toggle-input-method) | |
| 67 | |
| 68 ;;; This is no good because people often type Shift-SPC | |
| 69 ;;; meaning to type SPC. -- rms. | |
| 70 ;;; ;; Here's an alternative key binding for X users (Shift-SPACE). | |
| 71 ;;; (define-key global-map [?\S- ] 'toggle-input-method) | |
| 72 | |
| 73 (defun coding-system-change-eol-conversion (coding-system eol-type) | |
| 74 "Return a coding system which differs from CODING-SYSTEM in eol conversion. | |
| 75 The returned coding system converts end-of-line by EOL-TYPE | |
| 76 but text as the same way as CODING-SYSTEM. | |
| 77 EOL-TYPE should be `lf', `crlf', `cr' or nil. | |
| 78 If EOL-TYPE is nil, the returned coding system detects | |
| 79 how end-of-line is formatted automatically while decoding. | |
| 80 | |
| 81 EOL-TYPE can be specified by an symbol `unix', `dos' or `mac'. | |
| 82 They means `lf', `crlf', and `cr' respectively." | |
| 83 (if (symbolp eol-type) | |
| 84 (setq eol-type (cond ((or (eq eol-type 'unix) | |
| 85 (eq eol-type 'lf)) | |
| 86 'eol-lf) | |
| 87 ((or (eq eol-type 'dos) | |
| 88 (eq eol-type 'crlf)) | |
| 89 'eol-crlf) | |
| 90 ((or (eq eol-type 'mac) | |
| 91 (eq eol-type 'cr)) | |
| 92 'eol-cr) | |
| 93 (t eol-type)))) | |
| 94 (let ((orig-eol-type (coding-system-eol-type coding-system))) | |
| 95 (if (null orig-eol-type) | |
| 96 (if (not eol-type) | |
| 97 coding-system | |
| 98 (coding-system-property coding-system eol-type)) | |
| 99 (let ((base (coding-system-base coding-system))) | |
| 100 (if (not eol-type) | |
| 101 base | |
| 102 (if (= eol-type orig-eol-type) | |
| 103 coding-system | |
| 104 (setq orig-eol-type (coding-system-eol-type base)) | |
| 105 (if (null orig-eol-type) | |
| 106 (coding-system-property base eol-type)))))))) | |
| 107 | |
| 108 ;; (defun coding-system-change-text-conversion (coding-system coding) | |
| 109 ;; "Return a coding system which differs from CODING-SYSTEM in text conversion. | |
| 110 ;; The returned coding system converts text by CODING | |
| 111 ;; but end-of-line as the same way as CODING-SYSTEM. | |
| 112 ;; If CODING is nil, the returned coding system detects | |
| 113 ;; how text is formatted automatically while decoding." | |
| 114 ;; (if (not coding) | |
| 115 ;; (coding-system-base coding-system) | |
| 116 ;; (let ((eol-type (coding-system-eol-type coding-system))) | |
| 117 ;; (coding-system-change-eol-conversion | |
| 118 ;; coding | |
| 119 ;; (if (numberp eol-type) (aref [unix dos mac] eol-type)))))) | |
| 120 | |
| 121 (defun view-hello-file () | |
| 122 "Display the HELLO file which list up many languages and characters." | |
| 123 (interactive) | |
| 124 ;; We have to decode the file in any environment. | |
| 125 (let ((coding-system-for-read 'iso-2022-7bit)) | |
| 126 (find-file-read-only (expand-file-name "HELLO" data-directory)))) | |
| 127 | |
| 128 (defun universal-coding-system-argument () | |
| 129 "Execute an I/O command using the specified coding system." | |
| 130 (interactive) | |
| 131 (let* ((default (and buffer-file-coding-system | |
| 132 (not (eq (coding-system-type buffer-file-coding-system) | |
| 133 t)) | |
| 134 (coding-system-name buffer-file-coding-system))) | |
| 135 (coding-system | |
| 136 (read-coding-system | |
| 137 (if default | |
| 138 (format "Coding system for following command (default, %s): " | |
| 139 default) | |
| 140 "Coding system for following command: ") | |
| 141 default)) | |
| 142 (keyseq (read-key-sequence | |
| 143 (format "Command to execute with %s:" coding-system))) | |
| 144 (cmd (key-binding keyseq))) | |
| 145 (let ((coding-system-for-read coding-system) | |
| 146 (coding-system-for-write coding-system)) | |
| 147 (message "") | |
| 148 (call-interactively cmd)))) | |
| 149 | |
| 150 (defun set-default-coding-systems (coding-system) | |
| 151 "Set default value of various coding systems to CODING-SYSTEM. | |
| 152 This sets the following coding systems: | |
| 153 o coding system of a newly created buffer | |
| 154 o default coding system for terminal output | |
| 155 o default coding system for keyboard input | |
| 156 o default coding system for subprocess I/O | |
| 157 o default coding system for converting file names." | |
| 158 (check-coding-system coding-system) | |
| 159 ;;(setq-default buffer-file-coding-system coding-system) | |
| 160 (set-default-buffer-file-coding-system coding-system) | |
| 161 ;; (if default-enable-multibyte-characters | |
| 162 ;; (setq default-file-name-coding-system coding-system)) | |
| 163 ;; If coding-system is nil, honor that on MS-DOS as well, so | |
| 164 ;; that they could reset the terminal coding system. | |
| 165 ;; (unless (and (eq window-system 'pc) coding-system) | |
| 166 ;; (setq default-terminal-coding-system coding-system)) | |
| 167 (setq terminal-coding-system coding-system) | |
| 168 ;;(setq default-keyboard-coding-system coding-system) | |
| 169 (setq keyboard-coding-system coding-system) | |
| 170 ;;(setq default-process-coding-system (cons coding-system coding-system)) | |
| 171 (add-hook 'comint-exec-hook | |
| 172 `(lambda () | |
| 173 (let ((proc (get-buffer-process (current-buffer)))) | |
| 174 (set-process-input-coding-system proc ',coding-system) | |
| 175 (set-process-output-coding-system proc ',coding-system))) | |
| 176 'append) | |
| 177 (setq file-name-coding-system coding-system)) | |
| 178 | |
| 179 (defun prefer-coding-system (coding-system) | |
| 180 "Add CODING-SYSTEM at the front of the priority list for automatic detection. | |
| 181 This also sets the following coding systems: | |
| 182 o coding system of a newly created buffer | |
| 183 o default coding system for terminal output | |
| 184 o default coding system for keyboard input | |
| 185 o default coding system for converting file names. | |
| 186 | |
| 187 If CODING-SYSTEM specifies a certain type of EOL conversion, the coding | |
| 188 systems set by this function will use that type of EOL conversion. | |
| 189 | |
| 190 This command does not change the default value of terminal coding system | |
| 191 for MS-DOS terminal, because DOS terminals only support a single coding | |
| 192 system, and Emacs automatically sets the default to that coding system at | |
| 193 startup." | |
| 194 (interactive "zPrefer coding system: ") | |
| 195 (if (not (and coding-system (find-coding-system coding-system))) | |
| 196 (error "Invalid coding system `%s'" coding-system)) | |
| 197 (let ((coding-category (coding-system-category coding-system)) | |
| 198 (base (coding-system-base coding-system)) | |
| 199 (eol-type (coding-system-eol-type coding-system))) | |
| 200 (if (not coding-category) | |
| 201 ;; CODING-SYSTEM is no-conversion or undecided. | |
| 202 (error "Can't prefer the coding system `%s'" coding-system)) | |
| 203 (set-coding-category-system coding-category (or base coding-system)) | |
| 204 ;; (update-coding-systems-internal) | |
| 205 (or (eq coding-category (car (coding-category-list))) | |
| 206 ;; We must change the order. | |
| 207 (set-coding-priority-list (list coding-category))) | |
| 208 (if (and base (interactive-p)) | |
| 209 (message "Highest priority is set to %s (base of %s)" | |
| 210 base coding-system)) | |
| 211 ;; If they asked for specific EOL conversion, honor that. | |
| 212 (if (memq eol-type '(lf crlf mac)) | |
| 213 (setq coding-system | |
| 214 (coding-system-change-eol-conversion base eol-type)) | |
| 215 (setq coding-system base)) | |
| 216 (set-default-coding-systems coding-system))) | |
| 217 | |
| 218 ;; (defun find-coding-systems-region-subset-p (list1 list2) | |
| 219 ;; "Return non-nil if all elements in LIST1 are included in LIST2. | |
| 220 ;; Comparison done with EQ." | |
| 221 ;; (catch 'tag | |
| 222 ;; (while list1 | |
| 223 ;; (or (memq (car list1) list2) | |
| 224 ;; (throw 'tag nil)) | |
| 225 ;; (setq list1 (cdr list1))) | |
| 226 ;; t)) | |
| 227 | |
| 228 ;; (defun find-coding-systems-region (from to) | |
| 229 ;; "Return a list of proper coding systems to encode a text between FROM and TO. | |
| 230 ;; All coding systems in the list can safely encode any multibyte characters | |
| 231 ;; in the text. | |
| 232 ;; | |
| 233 ;; If the text contains no multibyte characters, return a list of a single | |
| 234 ;; element `undecided'." | |
| 235 ;; (find-coding-systems-for-charsets (find-charset-region from to))) | |
| 236 | |
| 237 ;; (defun find-coding-systems-string (string) | |
| 238 ;; "Return a list of proper coding systems to encode STRING. | |
| 239 ;; All coding systems in the list can safely encode any multibyte characters | |
| 240 ;; in STRING. | |
| 241 ;; | |
| 242 ;; If STRING contains no multibyte characters, return a list of a single | |
| 243 ;; element `undecided'." | |
| 244 ;; (find-coding-systems-for-charsets (find-charset-string string))) | |
| 245 | |
| 246 ;; (defun find-coding-systems-for-charsets (charsets) | |
| 247 ;; "Return a list of proper coding systems to encode characters of CHARSETS. | |
| 248 ;; CHARSETS is a list of character sets." | |
| 249 ;; (if (or (null charsets) | |
| 250 ;; (and (= (length charsets) 1) | |
| 251 ;; (eq 'ascii (car charsets)))) | |
| 252 ;; '(undecided) | |
| 253 ;; (setq charsets (delq 'composition charsets)) | |
| 254 ;; (let ((l (coding-system-list 'base-only)) | |
| 255 ;; (charset-preferred-codings | |
| 256 ;; (mapcar (function | |
| 257 ;; (lambda (x) | |
| 258 ;; (if (eq x 'unknown) | |
| 259 ;; 'raw-text | |
| 260 ;; (get-charset-property x 'preferred-coding-system)))) | |
| 261 ;; charsets)) | |
| 262 ;; (priorities (mapcar (function (lambda (x) (symbol-value x))) | |
| 263 ;; coding-category-list)) | |
| 264 ;; codings coding safe) | |
| 265 ;; (if (memq 'unknown charsets) | |
| 266 ;; ;; The region contains invalid multibyte characters. | |
| 267 ;; (setq l '(raw-text))) | |
| 268 ;; (while l | |
| 269 ;; (setq coding (car l) l (cdr l)) | |
| 270 ;; (if (and (setq safe (coding-system-get coding 'safe-charsets)) | |
| 271 ;; (or (eq safe t) | |
| 272 ;; (find-coding-systems-region-subset-p charsets safe))) | |
| 273 ;; ;; We put the higher priority to coding systems included | |
| 274 ;; ;; in CHARSET-PREFERRED-CODINGS, and within them, put the | |
| 275 ;; ;; higher priority to coding systems which support smaller | |
| 276 ;; ;; number of charsets. | |
| 277 ;; (let ((priority | |
| 278 ;; (+ (if (coding-system-get coding 'mime-charset) 4096 0) | |
| 279 ;; (lsh (length (memq coding priorities)) 7) | |
| 280 ;; (if (memq coding charset-preferred-codings) 64 0) | |
| 281 ;; (if (> (coding-system-type coding) 0) 32 0) | |
| 282 ;; (if (consp safe) (- 32 (length safe)) 0)))) | |
| 283 ;; (setq codings (cons (cons priority coding) codings))))) | |
| 284 ;; (mapcar 'cdr | |
| 285 ;; (sort codings (function (lambda (x y) (> (car x) (car y)))))) | |
| 286 ;; ))) | |
| 287 | |
| 288 ;; (defun find-multibyte-characters (from to &optional maxcount excludes) | |
| 289 ;; "Find multibyte characters in the region specified by FROM and TO. | |
| 290 ;; If FROM is a string, find multibyte characters in the string. | |
| 291 ;; The return value is an alist of the following format: | |
| 292 ;; ((CHARSET COUNT CHAR ...) ...) | |
| 293 ;; where | |
| 294 ;; CHARSET is a character set, | |
| 295 ;; COUNT is a number of characters, | |
| 296 ;; CHARs are found characters of the character set. | |
| 297 ;; Optional 3rd arg MAXCOUNT limits how many CHARs are put in the above list. | |
| 298 ;; Optional 4th arg EXCLUDE is a list of character sets to be ignored. | |
| 299 ;; | |
| 300 ;; For invalid characters, CHARs are actually strings." | |
| 301 ;; (let ((chars nil) | |
| 302 ;; charset char) | |
| 303 ;; (if (stringp from) | |
| 304 ;; (let ((idx 0)) | |
| 305 ;; (while (setq idx (string-match "[^\000-\177]" from idx)) | |
| 306 ;; (setq char (aref from idx) | |
| 307 ;; charset (char-charset char)) | |
| 308 ;; (if (eq charset 'unknown) | |
| 309 ;; (setq char (match-string 0))) | |
| 310 ;; (if (or (eq charset 'unknown) | |
| 311 ;; (not (or (eq excludes t) (memq charset excludes)))) | |
| 312 ;; (let ((slot (assq charset chars))) | |
| 313 ;; (if slot | |
| 314 ;; (if (not (memq char (nthcdr 2 slot))) | |
| 315 ;; (let ((count (nth 1 slot))) | |
| 316 ;; (setcar (cdr slot) (1+ count)) | |
| 317 ;; (if (or (not maxcount) (< count maxcount)) | |
| 318 ;; (nconc slot (list char))))) | |
| 319 ;; (setq chars (cons (list charset 1 char) chars))))) | |
| 320 ;; (setq idx (1+ idx)))) | |
| 321 ;; (save-excursion | |
| 322 ;; (goto-char from) | |
| 323 ;; (while (re-search-forward "[^\000-\177]" to t) | |
| 324 ;; (setq char (preceding-char) | |
| 325 ;; charset (char-charset char)) | |
| 326 ;; (if (eq charset 'unknown) | |
| 327 ;; (setq char (match-string 0))) | |
| 328 ;; (if (or (eq charset 'unknown) | |
| 329 ;; (not (or (eq excludes t) (memq charset excludes)))) | |
| 330 ;; (let ((slot (assq charset chars))) | |
| 331 ;; (if slot | |
| 332 ;; (if (not (member char (nthcdr 2 slot))) | |
| 333 ;; (let ((count (nth 1 slot))) | |
| 334 ;; (setcar (cdr slot) (1+ count)) | |
| 335 ;; (if (or (not maxcount) (< count maxcount)) | |
| 336 ;; (nconc slot (list char))))) | |
| 337 ;; (setq chars (cons (list charset 1 char) chars)))))))) | |
| 338 ;; (nreverse chars))) | |
| 339 | |
| 340 ;; (defvar last-coding-system-specified nil | |
| 341 ;; "Most recent coding system explicitly specified by the user when asked. | |
| 342 ;; This variable is set whenever Emacs asks the user which coding system | |
| 343 ;; to use in order to write a file. If you set it to nil explicitly, | |
| 344 ;; then call `write-region', then afterward this variable will be non-nil | |
| 345 ;; only if the user was explicitly asked and specified a coding system.") | |
| 346 | |
| 347 ;; (defun select-safe-coding-system (from to &optional default-coding-system) | |
| 348 ;; "Ask a user to select a safe coding system from candidates. | |
| 349 ;; The candidates of coding systems which can safely encode a text | |
| 350 ;; between FROM and TO are shown in a popup window. | |
| 351 ;; | |
| 352 ;; Optional arg DEFAULT-CODING-SYSTEM specifies a coding system to be | |
| 353 ;; checked at first. If omitted, buffer-file-coding-system of the | |
| 354 ;; current buffer is used. | |
| 355 ;; | |
| 356 ;; If the text can be encoded safely by DEFAULT-CODING-SYSTEM, it is | |
| 357 ;; returned without any user interaction. | |
| 358 ;; | |
| 359 ;; Kludgy feature: if FROM is a string, the string is the target text, | |
| 360 ;; and TO is ignored." | |
| 361 ;; (or default-coding-system | |
| 362 ;; (setq default-coding-system buffer-file-coding-system)) | |
| 363 ;; (let* ((charsets (if (stringp from) (find-charset-string from) | |
| 364 ;; (find-charset-region from to))) | |
| 365 ;; (safe-coding-systems (find-coding-systems-for-charsets charsets))) | |
| 366 ;; (if (or (not enable-multibyte-characters) | |
| 367 ;; (eq (car safe-coding-systems) 'undecided) | |
| 368 ;; (eq default-coding-system 'no-conversion) | |
| 369 ;; (and default-coding-system | |
| 370 ;; (memq (coding-system-base default-coding-system) | |
| 371 ;; safe-coding-systems))) | |
| 372 ;; default-coding-system | |
| 373 ;; | |
| 374 ;; ;; At first, change each coding system to the corresponding | |
| 375 ;; ;; mime-charset name if it is also a coding system. | |
| 376 ;; (let ((l safe-coding-systems) | |
| 377 ;; mime-charset) | |
| 378 ;; (while l | |
| 379 ;; (setq mime-charset (coding-system-get (car l) 'mime-charset)) | |
| 380 ;; (if (and mime-charset (coding-system-p mime-charset)) | |
| 381 ;; (setcar l mime-charset)) | |
| 382 ;; (setq l (cdr l)))) | |
| 383 ;; | |
| 384 ;; (let ((non-safe-chars (find-multibyte-characters | |
| 385 ;; from to 3 | |
| 386 ;; (and default-coding-system | |
| 387 ;; (coding-system-get default-coding-system | |
| 388 ;; 'safe-charsets)))) | |
| 389 ;; show-position overlays) | |
| 390 ;; (save-excursion | |
| 391 ;; ;; Highlight characters that default-coding-system can't encode. | |
| 392 ;; (when (integerp from) | |
| 393 ;; (goto-char from) | |
| 394 ;; (let ((found nil)) | |
| 395 ;; (while (and (not found) | |
| 396 ;; (re-search-forward "[^\000-\177]" to t)) | |
| 397 ;; (setq found (assq (char-charset (preceding-char)) | |
| 398 ;; non-safe-chars)))) | |
| 399 ;; (forward-line -1) | |
| 400 ;; (setq show-position (point)) | |
| 401 ;; (save-excursion | |
| 402 ;; (while (and (< (length overlays) 256) | |
| 403 ;; (re-search-forward "[^\000-\177]" to t)) | |
| 404 ;; (let* ((char (preceding-char)) | |
| 405 ;; (charset (char-charset char))) | |
| 406 ;; (when (assq charset non-safe-chars) | |
| 407 ;; (setq overlays (cons (make-overlay (1- (point)) (point)) | |
| 408 ;; overlays)) | |
| 409 ;; (overlay-put (car overlays) 'face 'highlight)))))) | |
| 410 ;; | |
| 411 ;; ;; At last, ask a user to select a proper coding system. | |
| 412 ;; (unwind-protect | |
| 413 ;; (save-window-excursion | |
| 414 ;; (when show-position | |
| 415 ;; ;; At first, be sure to show the current buffer. | |
| 416 ;; (set-window-buffer (selected-window) (current-buffer)) | |
| 417 ;; (set-window-start (selected-window) show-position)) | |
| 418 ;; ;; Then, show a helpful message. | |
| 419 ;; (with-output-to-temp-buffer "*Warning*" | |
| 420 ;; (save-excursion | |
| 421 ;; (set-buffer standard-output) | |
| 422 ;; (insert "The target text contains the following non ASCII character(s):\n") | |
| 423 ;; (let ((len (length non-safe-chars)) | |
| 424 ;; (shown 0)) | |
| 425 ;; (while (and non-safe-chars (< shown 3)) | |
| 426 ;; (when (> (length (car non-safe-chars)) 2) | |
| 427 ;; (setq shown (1+ shown)) | |
| 428 ;; (insert (format "%25s: " (car (car non-safe-chars)))) | |
| 429 ;; (let ((l (nthcdr 2 (car non-safe-chars)))) | |
| 430 ;; (while l | |
| 431 ;; (if (or (stringp (car l)) (char-valid-p (car l))) | |
| 432 ;; (insert (car l))) | |
| 433 ;; (setq l (cdr l)))) | |
| 434 ;; (if (> (nth 1 (car non-safe-chars)) 3) | |
| 435 ;; (insert "...")) | |
| 436 ;; (insert "\n")) | |
| 437 ;; (setq non-safe-chars (cdr non-safe-chars))) | |
| 438 ;; (if (< shown len) | |
| 439 ;; (insert (format "%27s\n" "...")))) | |
| 440 ;; (insert (format "\ | |
| 441 ;; These can't be encoded safely by the coding system %s. | |
| 442 ;; | |
| 443 ;; Please select one from the following safe coding systems:\n" | |
| 444 ;; default-coding-system)) | |
| 445 ;; (let ((pos (point)) | |
| 446 ;; (fill-prefix " ")) | |
| 447 ;; (mapcar (function (lambda (x) (princ " ") (princ x))) | |
| 448 ;; safe-coding-systems) | |
| 449 ;; (fill-region-as-paragraph pos (point))))) | |
| 450 ;; | |
| 451 ;; ;; Read a coding system. | |
| 452 ;; (let* ((safe-names (mapcar (lambda (x) (list (symbol-name x))) | |
| 453 ;; safe-coding-systems)) | |
| 454 ;; (name (completing-read | |
| 455 ;; (format "Select coding system (default %s): " | |
| 456 ;; (car safe-coding-systems)) | |
| 457 ;; safe-names nil t nil nil | |
| 458 ;; (car (car safe-names))))) | |
| 459 ;; (setq last-coding-system-specified (intern name)) | |
| 460 ;; (if (integerp (coding-system-eol-type default-coding-system)) | |
| 461 ;; (setq last-coding-system-specified | |
| 462 ;; (coding-system-change-eol-conversion | |
| 463 ;; last-coding-system-specified | |
| 464 ;; (coding-system-eol-type default-coding-system)))) | |
| 465 ;; last-coding-system-specified)) | |
| 466 ;; (kill-buffer "*Warning*") | |
| 467 ;; (while overlays | |
| 468 ;; (delete-overlay (car overlays)) | |
| 469 ;; (setq overlays (cdr overlays))))))))) | |
| 470 | |
| 471 ;; (setq select-safe-coding-system-function 'select-safe-coding-system) | |
| 472 | |
| 473 ;; (defun select-message-coding-system () | |
| 474 ;; "Return a coding system to encode the outgoing message of the current buffer. | |
| 475 ;; It at first tries the first coding system found in these variables | |
| 476 ;; in this order: | |
| 477 ;; (1) local value of `buffer-file-coding-system' | |
| 478 ;; (2) value of `sendmail-coding-system' | |
| 479 ;; (3) value of `default-buffer-file-coding-system' | |
| 480 ;; (4) value of `default-sendmail-coding-system' | |
| 481 ;; If the found coding system can't encode the current buffer, | |
| 482 ;; or none of them are bound to a coding system, | |
| 483 ;; it asks the user to select a proper coding system." | |
| 484 ;; (let ((coding (or (and (local-variable-p 'buffer-file-coding-system) | |
| 485 ;; buffer-file-coding-system) | |
| 486 ;; sendmail-coding-system | |
| 487 ;; default-buffer-file-coding-system | |
| 488 ;; default-sendmail-coding-system))) | |
| 489 ;; (if (eq coding 'no-conversion) | |
| 490 ;; ;; We should never use no-conversion for outgoing mails. | |
| 491 ;; (setq coding nil)) | |
| 492 ;; (if (fboundp select-safe-coding-system-function) | |
| 493 ;; (funcall select-safe-coding-system-function | |
| 494 ;; (point-min) (point-max) coding) | |
| 495 ;; coding))) | |
| 496 | |
| 497 ;;; Language support stuff. | |
| 498 | |
| 499 (defvar language-info-alist nil | |
| 500 "Alist of language environment definitions. | |
| 501 Each element looks like: | |
| 502 (LANGUAGE-NAME . ((KEY . INFO) ...)) | |
| 503 where LANGUAGE-NAME is a string, the name of the language environment, | |
| 504 KEY is a symbol denoting the kind of information, and | |
| 505 INFO is the data associated with KEY. | |
| 506 Meaningful values for KEY include | |
| 507 | |
| 508 documentation value is documentation of what this language environment | |
| 509 is meant for, and how to use it. | |
| 510 charset value is a list of the character sets used by this | |
| 511 language environment. | |
| 512 sample-text value is one line of text, | |
| 513 written using those character sets, | |
| 514 appropriate for this language environment. | |
| 515 setup-function value is a function to call to switch to this | |
| 516 language environment. | |
| 517 exit-function value is a function to call to leave this | |
| 518 language environment. | |
| 519 coding-system value is a list of coding systems that are good | |
| 520 for saving text written in this language environment. | |
| 521 This list serves as suggestions to the user; | |
| 522 in effect, as a kind of documentation. | |
| 523 coding-priority value is a list of coding systems for this language | |
| 524 environment, in order of decreasing priority. | |
| 525 This is used to set up the coding system priority | |
| 526 list when you switch to this language environment. | |
| 527 input-method value is a default input method for this language | |
| 528 environment. | |
| 529 features value is a list of features requested in this | |
| 530 language environment. | |
| 531 tutorial value is a tutorial file name written in the language.") | |
| 532 | |
| 533 (defun get-language-info (lang-env key) | |
| 534 "Return information listed under KEY for language environment LANG-ENV. | |
| 535 KEY is a symbol denoting the kind of information. | |
| 536 For a list of useful values for KEY and their meanings, | |
| 537 see `language-info-alist'." | |
| 538 (if (symbolp lang-env) | |
| 539 (setq lang-env (symbol-name lang-env))) | |
| 540 (let ((lang-slot (assoc-ignore-case lang-env language-info-alist))) | |
| 541 (if lang-slot | |
| 542 (cdr (assq key (cdr lang-slot)))))) | |
| 543 | |
| 544 (defun set-language-info (lang-env key info) | |
| 545 "Modify part of the definition of language environment LANG-ENV. | |
| 546 Specifically, this stores the information INFO under KEY | |
| 547 in the definition of this language environment. | |
| 548 KEY is a symbol denoting the kind of information. | |
| 549 INFO is the value for that information. | |
| 550 | |
| 551 For a list of useful values for KEY and their meanings, | |
| 552 see `language-info-alist'." | |
| 553 (if (symbolp lang-env) | |
| 554 (setq lang-env (symbol-name lang-env))) | |
| 555 (let (lang-slot key-slot) | |
| 556 (setq lang-slot (assoc lang-env language-info-alist)) | |
| 557 (if (null lang-slot) ; If no slot for the language, add it. | |
| 558 (setq lang-slot (list lang-env) | |
| 559 language-info-alist (cons lang-slot language-info-alist))) | |
| 560 (setq key-slot (assq key lang-slot)) | |
| 561 (if (null key-slot) ; If no slot for the key, add it. | |
| 562 (progn | |
| 563 (setq key-slot (list key)) | |
| 564 (setcdr lang-slot (cons key-slot (cdr lang-slot))))) | |
| 565 (setcdr key-slot info))) | |
| 566 | |
| 567 (defun set-language-info-alist (lang-env alist &optional parents) | |
| 568 "Store ALIST as the definition of language environment LANG-ENV. | |
| 569 ALIST is an alist of KEY and INFO values. See the documentation of | |
| 570 `set-language-info' for the meanings of KEY and INFO." | |
| 571 (if (symbolp lang-env) | |
| 572 (setq lang-env (symbol-name lang-env))) | |
| 573 (let (; (describe-map describe-language-environment-map) | |
| 574 ; (setup-map setup-language-environment-map) | |
| 575 ) | |
| 576 ;; (if parents | |
| 577 ;; (let ((l parents) | |
| 578 ;; map parent-symbol parent) | |
| 579 ;; (while l | |
| 580 ;; (if (symbolp (setq parent-symbol (car l))) | |
| 581 ;; (setq parent (symbol-name parent)) | |
| 582 ;; (setq parent parent-symbol parent-symbol (intern parent))) | |
| 583 ;; (setq map (lookup-key describe-map (vector parent-symbol))) | |
| 584 ;; (if (not map) | |
| 585 ;; (progn | |
| 586 ;; (setq map (intern (format "describe-%s-environment-map" | |
| 587 ;; (downcase parent)))) | |
| 588 ;; (define-prefix-command map) | |
| 589 ;; (define-key-after describe-map (vector parent-symbol) | |
| 590 ;; (cons parent map) t))) | |
| 591 ;; (setq describe-map (symbol-value map)) | |
| 592 ;; (setq map (lookup-key setup-map (vector parent-symbol))) | |
| 593 ;; (if (not map) | |
| 594 ;; (progn | |
| 595 ;; (setq map (intern (format "setup-%s-environment-map" | |
| 596 ;; (downcase parent)))) | |
| 597 ;; (define-prefix-command map) | |
| 598 ;; (define-key-after setup-map (vector parent-symbol) | |
| 599 ;; (cons parent map) t))) | |
| 600 ;; (setq setup-map (symbol-value map)) | |
| 601 ;; (setq l (cdr l))))) | |
| 602 | |
| 603 ;; Set up menu items for this language env. | |
| 604 (let ((doc (assq 'documentation alist))) | |
| 605 (when doc | |
| 606 ;; (define-key-after describe-map (vector (intern lang-env)) | |
| 607 ;; (cons lang-env 'describe-specified-language-support) t) | |
| 608 (when (featurep 'menubar) | |
| 609 (eval-after-load | |
| 610 "menubar-items.elc" | |
| 611 `(add-menu-button | |
| 612 '("Mule" "Describe Language Support") | |
| 613 (vector ,lang-env | |
| 614 '(describe-language-environment ,lang-env) | |
| 615 t)))) | |
| 616 )) | |
| 617 ;; (define-key-after setup-map (vector (intern lang-env)) | |
| 618 ;; (cons lang-env 'setup-specified-language-environment) t) | |
| 619 (when (featurep 'menubar) | |
| 620 (eval-after-load | |
| 621 "menubar-items.elc" | |
| 622 `(add-menu-button | |
| 623 '("Mule" "Set Language Environment") | |
| 624 (vector ,lang-env | |
| 625 '(set-language-environment ,lang-env) | |
| 626 t)))) | |
| 627 | |
| 628 (while alist | |
| 629 (set-language-info lang-env (car (car alist)) (cdr (car alist))) | |
| 630 (setq alist (cdr alist))))) | |
| 631 | |
| 632 (defun read-language-name (key prompt &optional default) | |
| 633 "Read a language environment name which has information for KEY. | |
| 634 If KEY is nil, read any language environment. | |
| 635 Prompt with PROMPT. DEFAULT is the default choice of language environment. | |
| 636 This returns a language environment name as a string." | |
| 637 (let* ((completion-ignore-case t) | |
| 638 (name (completing-read prompt | |
| 639 language-info-alist | |
| 640 (and key | |
| 641 (function (lambda (elm) (assq key elm)))) | |
| 642 t nil nil default))) | |
| 643 (if (and (> (length name) 0) | |
| 644 (or (not key) | |
| 645 (get-language-info name key))) | |
| 646 name))) | |
| 647 | |
| 648 ;;; Multilingual input methods. | |
| 649 | |
| 650 (defconst leim-list-file-name "leim-list.el" | |
| 651 "Name of LEIM list file. | |
| 652 This file contains a list of libraries of Emacs input methods (LEIM) | |
| 653 in the format of Lisp expression for registering each input method. | |
| 654 Emacs loads this file at startup time.") | |
| 655 | |
| 656 (defvar leim-list-header (format | |
| 657 ";;; %s -- list of LEIM (Library of Emacs Input Method) | |
| 658 ;; | |
| 659 ;; This file contains a list of LEIM (Library of Emacs Input Method) | |
| 660 ;; in the same directory as this file. Loading this file registers | |
| 661 ;; the whole input methods in Emacs. | |
| 662 ;; | |
| 663 ;; Each entry has the form: | |
| 664 ;; (register-input-method | |
| 665 ;; INPUT-METHOD LANGUAGE-NAME ACTIVATE-FUNC | |
| 666 ;; TITLE DESCRIPTION | |
| 667 ;; ARG ...) | |
| 668 ;; See the function `register-input-method' for the meanings of arguments. | |
| 669 ;; | |
| 670 ;; If this directory is included in load-path, Emacs automatically | |
| 671 ;; loads this file at startup time. | |
| 672 | |
| 673 " | |
| 674 leim-list-file-name) | |
| 675 "Header to be inserted in LEIM list file.") | |
| 676 | |
| 677 (defvar leim-list-entry-regexp "^(register-input-method" | |
| 678 "Regexp matching head of each entry in LEIM list file. | |
| 679 See also the variable `leim-list-header'") | |
| 680 | |
| 681 (defvar update-leim-list-functions | |
| 682 '(quail-update-leim-list-file) | |
| 683 "List of functions to call to update LEIM list file. | |
| 684 Each function is called with one arg, LEIM directory name.") | |
| 685 | |
| 686 (defun update-leim-list-file (&rest dirs) | |
| 687 "Update LEIM list file in directories DIRS." | |
| 688 (let ((functions update-leim-list-functions)) | |
| 689 (while functions | |
| 690 (apply (car functions) dirs) | |
| 691 (setq functions (cdr functions))))) | |
| 692 | |
| 693 (defvar current-input-method nil | |
| 694 "The current input method for multilingual text. | |
| 695 If nil, that means no input method is activated now.") | |
| 696 (make-variable-buffer-local 'current-input-method) | |
| 697 (put 'current-input-method 'permanent-local t) | |
| 698 | |
| 699 (defvar current-input-method-title nil | |
| 700 "Title string of the current input method shown in mode line.") | |
| 701 (make-variable-buffer-local 'current-input-method-title) | |
| 702 (put 'current-input-method-title 'permanent-local t) | |
| 703 | |
| 704 (defcustom default-input-method nil | |
| 705 "*Default input method for multilingual text (a string). | |
| 706 This is the input method activated automatically by the command | |
| 707 `toggle-input-method' (\\[toggle-input-method])." | |
| 708 :group 'mule | |
| 709 :type '(choice (const nil) string)) | |
| 710 | |
| 711 (put 'input-method-function 'permanent-local t) | |
| 712 | |
| 713 (defvar input-method-history nil | |
| 714 "History list for some commands that read input methods.") | |
| 715 (make-variable-buffer-local 'input-method-history) | |
| 716 (put 'input-method-history 'permanent-local t) | |
| 717 | |
| 718 (defvar inactivate-current-input-method-function nil | |
| 719 "Function to call for inactivating the current input method. | |
| 720 Every input method should set this to an appropriate value when activated. | |
| 721 This function is called with no argument. | |
| 722 | |
| 723 This function should never change the value of `current-input-method'. | |
| 724 It is set to nil by the function `inactivate-input-method'.") | |
| 725 (make-variable-buffer-local 'inactivate-current-input-method-function) | |
| 726 (put 'inactivate-current-input-method-function 'permanent-local t) | |
| 727 | |
| 728 (defvar describe-current-input-method-function nil | |
| 729 "Function to call for describing the current input method. | |
| 730 This function is called with no argument.") | |
| 731 (make-variable-buffer-local 'describe-current-input-method-function) | |
| 732 (put 'describe-current-input-method-function 'permanent-local t) | |
| 733 | |
| 734 (defvar input-method-alist nil | |
| 735 "Alist of input method names vs how to use them. | |
| 736 Each element has the form: | |
| 737 (INPUT-METHOD LANGUAGE-ENV ACTIVATE-FUNC TITLE DESCRIPTION ARGS...) | |
| 738 See the function `register-input-method' for the meanings of the elements.") | |
| 739 | |
| 740 (defun register-input-method (input-method lang-env &rest args) | |
| 741 "Register INPUT-METHOD as an input method for language environment ENV. | |
| 742 INPUT-METHOD and LANG-ENV are symbols or strings. | |
| 743 | |
| 744 The remaining arguments are: | |
| 745 ACTIVATE-FUNC, TITLE, DESCRIPTION, and ARGS... | |
| 746 ACTIVATE-FUNC is a function to call to activate this method. | |
| 747 TITLE is a string to show in the mode line when this method is active. | |
| 748 DESCRIPTION is a string describing this method and what it is good for. | |
| 749 The ARGS, if any, are passed as arguments to ACTIVATE-FUNC. | |
| 750 All told, the arguments to ACTIVATE-FUNC are INPUT-METHOD and the ARGS. | |
| 751 | |
| 752 This function is mainly used in the file \"leim-list.el\" which is | |
| 753 created at building time of emacs, registering all quail input methods | |
| 754 contained in the emacs distribution. | |
| 755 | |
| 756 In case you want to register a new quail input method by yourself, be | |
| 757 careful to use the same input method title as given in the third | |
| 758 parameter of `quail-define-package' (if the values are different, the | |
| 759 string specified in this function takes precedence). | |
| 760 | |
| 761 The commands `describe-input-method' and `list-input-methods' need | |
| 762 this duplicated values to show some information about input methods | |
| 763 without loading the affected quail packages." | |
| 764 (if (symbolp lang-env) | |
| 765 (setq lang-env (symbol-name lang-env))) | |
| 766 (if (symbolp input-method) | |
| 767 (setq input-method (symbol-name input-method))) | |
| 768 (let ((info (cons lang-env args)) | |
| 769 (slot (assoc input-method input-method-alist))) | |
| 770 (if slot | |
| 771 (setcdr slot info) | |
| 772 (setq slot (cons input-method info)) | |
| 773 (setq input-method-alist (cons slot input-method-alist))))) | |
| 774 | |
| 775 (defun read-input-method-name (prompt &optional default inhibit-null) | |
| 776 "Read a name of input method from a minibuffer prompting with PROMPT. | |
| 777 If DEFAULT is non-nil, use that as the default, | |
| 778 and substitute it into PROMPT at the first `%s'. | |
| 779 If INHIBIT-NULL is non-nil, null input signals an error. | |
| 780 | |
| 781 The return value is a string." | |
| 782 (if default | |
| 783 (setq prompt (format prompt default))) | |
| 784 (let* ((completion-ignore-case t) | |
| 785 ;; This binding is necessary because input-method-history is | |
| 786 ;; buffer local. | |
| 787 (input-method (completing-read prompt input-method-alist | |
| 788 nil t nil 'input-method-history | |
| 789 default))) | |
| 790 (if (and input-method (symbolp input-method)) | |
| 791 (setq input-method (symbol-name input-method))) | |
| 792 (if (> (length input-method) 0) | |
| 793 input-method | |
| 794 (if inhibit-null | |
| 795 (error "No valid input method is specified"))))) | |
| 796 | |
| 797 (defun activate-input-method (input-method) | |
| 798 "Switch to input method INPUT-METHOD for the current buffer. | |
| 799 If some other input method is already active, turn it off first. | |
| 800 If INPUT-METHOD is nil, deactivate any current input method." | |
| 801 (if (and input-method (symbolp input-method)) | |
| 802 (setq input-method (symbol-name input-method))) | |
| 803 (if (and current-input-method | |
| 804 (not (string= current-input-method input-method))) | |
| 805 (inactivate-input-method)) | |
| 806 (unless (or current-input-method (null input-method)) | |
| 807 (let ((slot (assoc input-method input-method-alist))) | |
| 808 (if (null slot) | |
| 809 (error "Can't activate input method `%s'" input-method)) | |
| 810 (let ((func (nth 2 slot))) | |
| 811 (if (functionp func) | |
| 812 (apply (nth 2 slot) input-method (nthcdr 5 slot)) | |
| 813 (if (and (consp func) (symbolp (car func)) (symbolp (cdr func))) | |
| 814 (progn | |
| 815 (require (cdr func)) | |
| 816 (apply (car func) input-method (nthcdr 5 slot))) | |
| 817 (error "Can't activate input method `%s'" input-method)))) | |
| 818 (setq current-input-method input-method) | |
| 819 (setq current-input-method-title (nth 3 slot)) | |
| 820 (unwind-protect | |
| 821 (run-hooks 'input-method-activate-hook) | |
| 822 (force-mode-line-update))))) | |
| 823 | |
| 824 (defun inactivate-input-method () | |
| 825 "Turn off the current input method." | |
| 826 (when current-input-method | |
| 827 (if input-method-history | |
| 828 (unless (string= current-input-method (car input-method-history)) | |
| 829 (setq input-method-history | |
| 830 (cons current-input-method | |
| 831 (delete current-input-method input-method-history)))) | |
| 832 (setq input-method-history (list current-input-method))) | |
| 833 (unwind-protect | |
| 834 (funcall inactivate-current-input-method-function) | |
| 835 (unwind-protect | |
| 836 (run-hooks 'input-method-inactivate-hook) | |
| 837 (setq current-input-method nil | |
| 838 current-input-method-title nil) | |
| 839 (force-mode-line-update))))) | |
| 840 | |
| 841 (defun set-input-method (input-method) | |
| 842 "Select and activate input method INPUT-METHOD for the current buffer. | |
| 843 This also sets the default input method to the one you specify." | |
| 844 (interactive | |
| 845 (let* ((default (or (car input-method-history) default-input-method))) | |
| 846 (list (read-input-method-name | |
| 847 (if default "Select input method (default %s): " "Select input method: ") | |
| 848 default t)))) | |
| 849 (activate-input-method input-method) | |
| 850 (setq default-input-method input-method)) | |
| 851 | |
| 852 (defun toggle-input-method (&optional arg) | |
| 853 "Turn on or off a multilingual text input method for the current buffer. | |
| 854 | |
| 855 With no prefix argument, if an input method is currently activated, | |
| 856 turn it off. Otherwise, activate an input method -- the one most | |
| 857 recently used, or the one specified in `default-input-method', or | |
| 858 the one read from the minibuffer. | |
| 859 | |
| 860 With a prefix argument, read an input method from the minibuffer and | |
| 861 turn it on. | |
| 862 | |
| 863 The default is to use the most recent input method specified | |
| 864 \(not including the currently active input method, if any)." | |
| 865 (interactive "P") | |
| 866 (if (and current-input-method (not arg)) | |
| 867 (inactivate-input-method) | |
| 868 (let ((default (or (car input-method-history) default-input-method))) | |
| 869 (if (and arg default (equal current-input-method default) | |
| 870 (> (length input-method-history) 1)) | |
| 871 (setq default (nth 1 input-method-history))) | |
| 872 (activate-input-method | |
| 873 (if (or arg (not default)) | |
| 874 (progn | |
| 875 (read-input-method-name | |
| 876 (if default "Input method (default %s): " "Input method: " ) | |
| 877 default t)) | |
| 878 default)) | |
| 879 (or default-input-method | |
| 880 (setq default-input-method current-input-method))))) | |
| 881 | |
| 882 (defun describe-input-method (input-method) | |
| 883 "Describe input method INPUT-METHOD." | |
| 884 (interactive | |
| 885 (list (read-input-method-name | |
| 886 "Describe input method (default, current choice): "))) | |
| 887 (if (and input-method (symbolp input-method)) | |
| 888 (setq input-method (symbol-name input-method))) | |
| 889 (if (null input-method) | |
| 890 (describe-current-input-method) | |
| 891 (with-output-to-temp-buffer "*Help*" | |
| 892 (let ((elt (assoc input-method input-method-alist))) | |
| 893 (princ (format "Input method: %s (`%s' in mode line) for %s\n %s\n" | |
| 894 input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))) | |
| 895 | |
| 896 (defun describe-current-input-method () | |
| 897 "Describe the input method currently in use." | |
| 898 (if current-input-method | |
| 899 (if (and (symbolp describe-current-input-method-function) | |
| 900 (fboundp describe-current-input-method-function)) | |
| 901 (funcall describe-current-input-method-function) | |
| 902 (message "No way to describe the current input method `%s'" | |
| 903 current-input-method) | |
| 904 (ding)) | |
| 905 (error "No input method is activated now"))) | |
| 906 | |
| 907 (defun read-multilingual-string (prompt &optional initial-input input-method) | |
| 908 "Read a multilingual string from minibuffer, prompting with string PROMPT. | |
| 909 The input method selected last time is activated in minibuffer. | |
| 910 If optional second arg INITIAL-INPUT is non-nil, insert it in the minibuffer | |
| 911 initially. | |
| 912 Optional 3rd argument INPUT-METHOD specifies the input method | |
| 913 to be activated instead of the one selected last time. It is a symbol | |
| 914 or a string." | |
| 915 (setq input-method | |
| 916 (or input-method | |
| 917 current-input-method | |
| 918 default-input-method | |
| 919 (read-input-method-name "Input method: " nil t))) | |
| 920 (if (and input-method (symbolp input-method)) | |
| 921 (setq input-method (symbol-name input-method))) | |
| 922 (let ((prev-input-method current-input-method)) | |
| 923 (unwind-protect | |
| 924 (progn | |
| 925 (activate-input-method input-method) | |
| 926 ;; FSF Emacs | |
| 927 ;; (read-string prompt initial-input nil nil t) | |
| 928 (read-string prompt initial-input nil)) | |
| 929 (activate-input-method prev-input-method)))) | |
| 930 | |
| 931 ;; Variables to control behavior of input methods. All input methods | |
| 932 ;; should react to these variables. | |
| 933 | |
| 934 (defcustom input-method-verbose-flag 'default | |
| 935 "*A flag to control extra guidance given by input methods. | |
| 936 The value should be nil, t, `complex-only', or `default'. | |
| 937 | |
| 938 The extra guidance is done by showing list of available keys in echo | |
| 939 area. When you use the input method in the minibuffer, the guidance | |
| 940 is shown at the bottom short window (split from the existing window). | |
| 941 | |
| 942 If the value is t, extra guidance is always given, if the value is | |
| 943 nil, extra guidance is always suppressed. | |
| 944 | |
| 945 If the value is `complex-only', only complex input methods such as | |
| 946 `chinese-py' and `japanese' give extra guidance. | |
| 947 | |
| 948 If the value is `default', complex input methods always give extra | |
| 949 guidance, but simple input methods give it only when you are not in | |
| 950 the minibuffer. | |
| 951 | |
| 952 See also the variable `input-method-highlight-flag'." | |
| 953 :type '(choice (const t) (const nil) (const complex-only) (const default)) | |
| 954 :group 'mule) | |
| 955 | |
| 956 (defcustom input-method-highlight-flag t | |
| 957 "*If this flag is non-nil, input methods highlight partially-entered text. | |
| 958 For instance, while you are in the middle of a Quail input method sequence, | |
| 959 the text inserted so far is temporarily underlined. | |
| 960 The underlining goes away when you finish or abort the input method sequence. | |
| 961 See also the variable `input-method-verbose-flag'." | |
| 962 :type 'boolean | |
| 963 :group 'mule) | |
| 964 | |
| 965 (defvar input-method-activate-hook nil | |
| 966 "Normal hook run just after an input method is activated. | |
| 967 | |
| 968 The variable `current-input-method' keeps the input method name | |
| 969 just activated.") | |
| 970 | |
| 971 (defvar input-method-inactivate-hook nil | |
| 972 "Normal hook run just after an input method is inactivated. | |
| 973 | |
| 974 The variable `current-input-method' still keeps the input method name | |
| 975 just inactivated.") | |
| 976 | |
| 977 (defvar input-method-after-insert-chunk-hook nil | |
| 978 "Normal hook run just after an input method insert some chunk of text.") | |
| 979 | |
| 980 (defvar input-method-exit-on-first-char nil | |
| 981 "This flag controls a timing when an input method returns. | |
| 982 Usually, the input method does not return while there's a possibility | |
| 983 that it may find a different translation if a user types another key. | |
| 984 But, it this flag is non-nil, the input method returns as soon as | |
| 985 the current key sequence gets long enough to have some valid translation.") | |
| 986 | |
| 987 (defvar input-method-use-echo-area nil | |
| 988 "This flag controls how an input method shows an intermediate key sequence. | |
| 989 Usually, the input method inserts the intermediate key sequence, | |
| 990 or candidate translations corresponding to the sequence, | |
| 991 at point in the current buffer. | |
| 992 But, if this flag is non-nil, it displays them in echo area instead.") | |
| 993 | |
| 994 (defvar input-method-exit-on-invalid-key nil | |
| 995 "This flag controls the behaviour of an input method on invalid key input. | |
| 996 Usually, when a user types a key which doesn't start any character | |
| 997 handled by the input method, the key is handled by turning off the | |
| 998 input method temporarily. After that key, the input method is re-enabled. | |
| 999 But, if this flag is non-nil, the input method is never back on.") | |
| 1000 | |
| 1001 | |
| 1002 (defvar set-language-environment-hook nil | |
| 1003 "Normal hook run after some language environment is set. | |
| 1004 | |
| 1005 When you set some hook function here, that effect usually should not | |
| 1006 be inherited to another language environment. So, you had better set | |
| 1007 another function in `exit-language-environment-hook' (which see) to | |
| 1008 cancel the effect.") | |
| 1009 | |
| 1010 (defvar exit-language-environment-hook nil | |
| 1011 "Normal hook run after exiting from some language environment. | |
| 1012 When this hook is run, the variable `current-language-environment' | |
| 1013 is still bound to the language environment being exited. | |
| 1014 | |
| 1015 This hook is mainly used for canceling the effect of | |
| 1016 `set-language-environment-hook' (which-see).") | |
| 1017 | |
| 1018 (put 'setup-specified-language-environment 'apropos-inhibit t) | |
| 1019 | |
| 1020 (defun setup-specified-language-environment () | |
| 1021 "Switch to a specified language environment." | |
| 1022 (interactive) | |
| 1023 (let (language-name) | |
| 1024 (if (and (symbolp last-command-event) | |
| 1025 (or (not (eq last-command-event 'Default)) | |
| 1026 (setq last-command-event 'English)) | |
| 1027 (setq language-name (symbol-name last-command-event))) | |
| 1028 (set-language-environment language-name) | |
| 1029 (error "Bogus calling sequence")))) | |
| 1030 | |
| 1031 (defcustom current-language-environment "English" | |
| 1032 "The last language environment specified with `set-language-environment'. | |
| 1033 This variable should be set only with \\[customize], which is equivalent | |
| 1034 to using the function `set-language-environment'." | |
| 1035 :link '(custom-manual "(emacs)Language Environments") | |
| 1036 :set (lambda (symbol value) (set-language-environment value)) | |
| 1037 :get (lambda (x) | |
| 1038 (or (car-safe (assoc-ignore-case | |
| 1039 (if (symbolp current-language-environment) | |
| 1040 (symbol-name current-language-environment) | |
| 1041 current-language-environment) | |
| 1042 language-info-alist)) | |
| 1043 "English")) | |
| 1044 :type (cons 'choice (mapcar (lambda (lang) | |
| 1045 (list 'const (car lang))) | |
| 1046 language-info-alist)) | |
| 1047 :initialize 'custom-initialize-default | |
| 1048 :group 'mule | |
| 1049 :type 'string) | |
| 1050 | |
| 1051 (defun reset-language-environment () | |
| 1052 "Reset multilingual environment of Emacs to the default status. | |
| 1053 | |
| 1054 The default status is as follows: | |
| 1055 | |
| 1056 The default value of buffer-file-coding-system is nil. | |
| 1057 The default coding system for process I/O is nil. | |
| 1058 The default value for the command `set-terminal-coding-system' is nil. | |
| 1059 The default value for the command `set-keyboard-coding-system' is nil. | |
| 1060 | |
| 1061 The order of priorities of coding categories and the coding system | |
| 1062 bound to each category are as follows | |
| 1063 coding category coding system | |
| 1064 -------------------------------------------------- | |
| 1065 iso-8-2 iso-8859-1 | |
| 1066 iso-8-1 iso-8859-1 | |
| 1067 iso-7 iso-2022-7bit | |
| 1068 iso-lock-shift iso-2022-lock | |
| 1069 iso-8-designate iso-2022-8bit-ss2 | |
| 1070 no-conversion raw-text | |
| 1071 shift-jis shift_jis | |
| 1072 big5 big5 | |
| 1073 ucs-4 ---- | |
| 1074 utf-8 ---- | |
| 1075 " | |
| 1076 (interactive) | |
| 1077 ;; This function formerly set default-enable-multibyte-characters to t, | |
| 1078 ;; but that is incorrect. It should not alter the unibyte/multibyte choice. | |
| 1079 | |
| 1080 (set-coding-category-system 'iso-7 'iso-2022-7bit) | |
| 1081 (set-coding-category-system 'iso-8-1 'iso-8859-1) | |
| 1082 (set-coding-category-system 'iso-8-2 'iso-8859-1) | |
| 1083 (set-coding-category-system 'iso-lock-shift 'iso-2022-lock) | |
| 1084 (set-coding-category-system 'iso-8-designate 'iso-2022-8bit-ss2) | |
| 1085 (set-coding-category-system 'no-conversion 'raw-text) | |
| 1086 (set-coding-category-system 'shift-jis 'shift_jis) | |
| 1087 (set-coding-category-system 'big5 'big5) | |
| 1088 (cond ((eq (coding-system-type (coding-category-system 'utf-8)) 'utf-8) | |
| 1089 (set-coding-category-system 'ucs-4 'iso-10646-ucs-4) | |
| 1090 (set-coding-category-system 'utf-8 'utf-8) | |
| 1091 (set-coding-priority-list | |
| 1092 '(iso-8-1 | |
| 1093 iso-8-2 | |
| 1094 iso-7 | |
| 1095 iso-lock-shift | |
| 1096 iso-8-designate | |
| 1097 utf-8 | |
| 1098 ucs-4 | |
| 1099 no-conversion | |
| 1100 shift-jis | |
| 1101 big5)) | |
| 1102 ) | |
| 1103 (t | |
| 1104 (set-coding-priority-list | |
| 1105 '(iso-8-1 | |
| 1106 iso-8-2 | |
| 1107 iso-7 | |
| 1108 iso-lock-shift | |
| 1109 iso-8-designate | |
| 1110 no-conversion | |
| 1111 shift-jis | |
| 1112 big5)) | |
| 1113 )) | |
| 1114 | |
| 1115 ;; (update-coding-systems-internal) | |
| 1116 | |
| 1117 (set-default-coding-systems nil) | |
| 1118 ;; Don't alter the terminal and keyboard coding systems here. | |
| 1119 ;; The terminal still supports the same coding system | |
| 1120 ;; that it supported a minute ago. | |
| 1121 ;;; (set-terminal-coding-system-internal nil) | |
| 1122 ;;; (set-keyboard-coding-system-internal nil) | |
| 1123 | |
| 1124 ;; (setq nonascii-translation-table nil | |
| 1125 ;; nonascii-insert-offset 0) | |
| 1126 ) | |
| 1127 | |
| 1128 (defun set-language-environment (language-name) | |
| 1129 "Set up multi-lingual environment for using LANGUAGE-NAME. | |
| 1130 This sets the coding system priority and the default input method | |
| 1131 and sometimes other things. LANGUAGE-NAME should be a string | |
| 1132 which is the name of a language environment. For example, \"Latin-1\" | |
| 1133 specifies the character set for the major languages of Western Europe." | |
| 1134 (interactive (list (read-language-name | |
| 1135 nil | |
| 1136 "Set language environment (default, English): "))) | |
| 1137 (if language-name | |
| 1138 (if (symbolp language-name) | |
| 1139 (setq language-name (symbol-name language-name))) | |
| 1140 (setq language-name "English")) | |
| 1141 (or (assoc-ignore-case language-name language-info-alist) | |
| 1142 (error "Language environment not defined: %S" language-name)) | |
| 1143 (if current-language-environment | |
| 1144 (let ((func (get-language-info current-language-environment | |
| 1145 'exit-function))) | |
| 1146 (run-hooks 'exit-language-environment-hook) | |
| 1147 (if (fboundp func) (funcall func)))) | |
| 1148 (let ((default-eol-type (coding-system-eol-type | |
| 1149 default-buffer-file-coding-system))) | |
| 1150 (reset-language-environment) | |
| 1151 | |
| 1152 (setq current-language-environment language-name) | |
| 1153 (set-language-environment-coding-systems language-name default-eol-type)) | |
| 1154 (let ((input-method (get-language-info language-name 'input-method))) | |
| 1155 (when input-method | |
| 1156 (setq default-input-method input-method) | |
| 1157 (if input-method-history | |
| 1158 (setq input-method-history | |
| 1159 (cons input-method | |
| 1160 (delete input-method input-method-history)))))) | |
| 1161 ;; (let ((nonascii (get-language-info language-name 'nonascii-translation)) | |
| 1162 ;; (dos-table | |
| 1163 ;; (if (eq window-system 'pc) | |
| 1164 ;; (intern | |
| 1165 ;; (concat "cp" dos-codepage "-nonascii-translation-table"))))) | |
| 1166 ;; (cond | |
| 1167 ;; ((char-table-p nonascii) | |
| 1168 ;; (setq nonascii-translation-table nonascii)) | |
| 1169 ;; ((and (eq window-system 'pc) (boundp dos-table)) | |
| 1170 ;; ;; DOS terminals' default is to use a special non-ASCII translation | |
| 1171 ;; ;; table as appropriate for the installed codepage. | |
| 1172 ;; (setq nonascii-translation-table (symbol-value dos-table))) | |
| 1173 ;; ((charsetp nonascii) | |
| 1174 ;; (setq nonascii-insert-offset (- (make-char nonascii) 128))))) | |
| 1175 | |
| 1176 ;; (setq charset-origin-alist | |
| 1177 ;; (get-language-info language-name 'charset-origin-alist)) | |
| 1178 | |
| 1179 ;; Unibyte setups if necessary. | |
| 1180 ;; (unless default-enable-multibyte-characters | |
| 1181 ;; ;; Syntax and case table. | |
| 1182 ;; (let ((syntax (get-language-info language-name 'unibyte-syntax))) | |
| 1183 ;; (if syntax | |
| 1184 ;; (let ((set-case-syntax-set-multibyte nil)) | |
| 1185 ;; (load syntax nil t)) | |
| 1186 ;; ;; No information for syntax and case. Reset to the defaults. | |
| 1187 ;; (let ((syntax-table (standard-syntax-table)) | |
| 1188 ;; (case-table (standard-case-table)) | |
| 1189 ;; (ch (if (eq window-system 'pc) 128 160))) | |
| 1190 ;; (while (< ch 256) | |
| 1191 ;; (modify-syntax-entry ch " " syntax-table) | |
| 1192 ;; (aset case-table ch ch) | |
| 1193 ;; (setq ch (1+ ch))) | |
| 1194 ;; (set-char-table-extra-slot case-table 0 nil) | |
| 1195 ;; (set-char-table-extra-slot case-table 1 nil) | |
| 1196 ;; (set-char-table-extra-slot case-table 2 nil)) | |
| 1197 ;; (set-standard-case-table (standard-case-table)) | |
| 1198 ;; (let ((list (buffer-list))) | |
| 1199 ;; (while list | |
| 1200 ;; (with-current-buffer (car list) | |
| 1201 ;; (set-case-table (standard-case-table))) | |
| 1202 ;; (setq list (cdr list)))))) | |
| 1203 ;; ;; Display table and coding system for terminal. | |
| 1204 ;; (let ((coding (get-language-info language-name 'unibyte-display))) | |
| 1205 ;; (if coding | |
| 1206 ;; (standard-display-european-internal) | |
| 1207 ;; (standard-display-default (if (eq window-system 'pc) 128 160) 255) | |
| 1208 ;; (aset standard-display-table 146 nil)) | |
| 1209 ;; (or (eq window-system 'pc) | |
| 1210 ;; (set-terminal-coding-system coding)))) | |
| 1211 | |
| 1212 (let ((required-features (get-language-info language-name 'features))) | |
| 1213 (while required-features | |
| 1214 (require (car required-features)) | |
| 1215 (setq required-features (cdr required-features)))) | |
| 1216 (let ((func (get-language-info language-name 'setup-function))) | |
| 1217 (if (fboundp func) | |
| 1218 (funcall func))) | |
| 1219 (run-hooks 'set-language-environment-hook) | |
| 1220 (force-mode-line-update t)) | |
| 1221 | |
| 1222 ;; (defun standard-display-european-internal () | |
| 1223 ;; ;; Actually set up direct output of non-ASCII characters. | |
| 1224 ;; (standard-display-8bit (if (eq window-system 'pc) 128 160) 255) | |
| 1225 ;; ;; Unibyte Emacs on MS-DOS wants to display all 8-bit characters with | |
| 1226 ;; ;; the native font, and codes 160 and 146 stand for something very | |
| 1227 ;; ;; different there. | |
| 1228 ;; (or (and (eq window-system 'pc) (not default-enable-multibyte-characters)) | |
| 1229 ;; (progn | |
| 1230 ;; ;; Make non-line-break space display as a plain space. | |
| 1231 ;; ;; Most X fonts do the wrong thing for code 160. | |
| 1232 ;; (aset standard-display-table 160 [32]) | |
| 1233 ;; ;; Most Windows programs send out apostrophe's as \222. Most X fonts | |
| 1234 ;; ;; don't contain a character at that position. Map it to the ASCII | |
| 1235 ;; ;; apostrophe. | |
| 1236 ;; (aset standard-display-table 146 [39])))) | |
| 1237 | |
| 1238 (defun set-language-environment-coding-systems (language-name | |
| 1239 &optional eol-type) | |
| 1240 "Do various coding system setups for language environment LANGUAGE-NAME. | |
| 1241 | |
| 1242 The optional arg EOL-TYPE specifies the eol-type of the default value | |
| 1243 of buffer-file-coding-system set by this function." | |
| 1244 (let* ((priority (get-language-info language-name 'coding-priority)) | |
| 1245 (default-coding (car priority))) | |
| 1246 (if priority | |
| 1247 (let ((categories (mapcar 'coding-system-category priority)) | |
| 1248 category checked-categories) | |
| 1249 (set-default-coding-systems | |
| 1250 (if (memq eol-type '(lf crlf cr unix dos mac)) | |
| 1251 (coding-system-change-eol-conversion default-coding eol-type) | |
| 1252 default-coding)) | |
| 1253 ;; (setq default-sendmail-coding-system default-coding) | |
| 1254 (while priority | |
| 1255 (unless (memq (setq category (car categories)) checked-categories) | |
| 1256 (set-coding-category-system category (car priority)) | |
| 1257 (setq checked-categories (cons category checked-categories))) | |
| 1258 (setq priority (cdr priority) | |
| 1259 categories (cdr categories))) | |
| 1260 (set-coding-priority-list (nreverse checked-categories)) | |
| 1261 ;; (update-coding-systems-internal) | |
| 1262 )))) | |
| 1263 | |
| 1264 ;; Print all arguments with `princ', then print "\n". | |
| 1265 (defsubst princ-list (&rest args) | |
| 1266 (while args (princ (car args)) (setq args (cdr args))) | |
| 1267 (princ "\n")) | |
| 1268 | |
| 1269 (put 'describe-specified-language-support 'apropos-inhibit t) | |
| 1270 | |
| 1271 ;; Print a language specific information such as input methods, | |
| 1272 ;; charsets, and coding systems. This function is intended to be | |
| 1273 ;; called from the menu: | |
| 1274 ;; [menu-bar mule describe-language-environment LANGUAGE] | |
| 1275 ;; and should not run it by `M-x describe-current-input-method-function'. | |
| 1276 (defun describe-specified-language-support () | |
| 1277 "Describe how Emacs supports the specified language environment." | |
| 1278 (interactive) | |
| 1279 (let (language-name) | |
| 1280 (if (not (and (symbolp last-command-event) | |
| 1281 (setq language-name (symbol-name last-command-event)))) | |
| 1282 (error "Bogus calling sequence")) | |
| 1283 (describe-language-environment language-name))) | |
| 1284 | |
| 1285 (defun describe-language-environment (language-name) | |
| 1286 "Describe how Emacs supports language environment LANGUAGE-NAME." | |
| 1287 (interactive | |
| 1288 (list (read-language-name | |
| 1289 'documentation | |
| 1290 "Describe language environment (default, current choice): "))) | |
| 1291 (if (null language-name) | |
| 1292 (setq language-name current-language-environment)) | |
| 1293 (if (or (null language-name) | |
| 1294 (null (get-language-info language-name 'documentation))) | |
| 1295 (error "No documentation for the specified language")) | |
| 1296 (if (symbolp language-name) | |
| 1297 (setq language-name (symbol-name language-name))) | |
| 1298 (let ((doc (get-language-info language-name 'documentation))) | |
| 1299 (with-output-to-temp-buffer "*Help*" | |
| 1300 (princ-list language-name " language environment" "\n") | |
| 1301 (if (stringp doc) | |
| 1302 (progn | |
| 1303 (princ-list doc) | |
| 1304 (terpri))) | |
| 1305 (let ((str (get-language-info language-name 'sample-text))) | |
| 1306 (if (stringp str) | |
| 1307 (progn | |
| 1308 (princ "Sample text:\n") | |
| 1309 (princ-list " " str) | |
| 1310 (terpri)))) | |
| 1311 (let ((input-method (get-language-info language-name 'input-method)) | |
| 1312 (l (copy-sequence input-method-alist))) | |
| 1313 (princ "Input methods") | |
| 1314 (when input-method | |
| 1315 (princ (format " (default, %s)" input-method)) | |
| 1316 (setq input-method (assoc input-method input-method-alist)) | |
| 1317 (setq l (cons input-method (delete input-method l)))) | |
| 1318 (princ ":\n") | |
| 1319 (while l | |
| 1320 (if (string= language-name (nth 1 (car l))) | |
| 1321 (princ-list " " (car (car l)) | |
| 1322 (format " (`%s' in mode line)" (nth 3 (car l))))) | |
| 1323 (setq l (cdr l)))) | |
| 1324 (terpri) | |
| 1325 (princ "Character sets:\n") | |
| 1326 (let ((l (get-language-info language-name 'charset))) | |
| 1327 (if (null l) | |
| 1328 (princ-list " nothing specific to " language-name) | |
| 1329 (while l | |
| 1330 (princ-list " " (car l) ": " | |
| 1331 (charset-description (car l))) | |
| 1332 (setq l (cdr l))))) | |
| 1333 (terpri) | |
| 1334 (princ "Coding systems:\n") | |
| 1335 (let ((l (get-language-info language-name 'coding-system))) | |
| 1336 (if (null l) | |
| 1337 (princ-list " nothing specific to " language-name) | |
| 1338 (while l | |
| 1339 (princ ; (format " %s (`%c' in mode line):\n\t%s\n" | |
| 1340 ;; In XEmacs, `coding-system-mnemonic' returns string. | |
| 1341 (format " %s (`%s' in mode line):\n\t%s\n" | |
| 1342 (car l) | |
| 1343 (coding-system-mnemonic (car l)) | |
| 1344 (coding-system-doc-string (car l)))) | |
| 1345 ;; (let ((aliases (coding-system-get (car l) 'alias-coding-systems))) | |
| 1346 ;; (when aliases | |
| 1347 ;; (princ "\t") | |
| 1348 ;; (princ (cons 'alias: (cdr aliases))) | |
| 1349 ;; (terpri))) | |
| 1350 (setq l (cdr l)))))))) | |
| 1351 | |
| 1352 ;;; Charset property | |
| 1353 | |
| 1354 ;; (defsubst get-charset-property (charset propname) | |
| 1355 ;; "Return the value of CHARSET's PROPNAME property. | |
| 1356 ;; This is the last value stored with | |
| 1357 ;; `(put-charset-property CHARSET PROPNAME VALUE)'." | |
| 1358 ;; (plist-get (charset-plist charset) propname)) | |
| 1359 | |
| 1360 ;; (defsubst put-charset-property (charset propname value) | |
| 1361 ;; "Store CHARSETS's PROPNAME property with value VALUE. | |
| 1362 ;; It can be retrieved with `(get-charset-property CHARSET PROPNAME)'." | |
| 1363 ;; (set-charset-plist charset | |
| 1364 ;; (plist-put (charset-plist charset) propname value))) | |
| 1365 | |
| 1366 (defvar char-code-property-table | |
| 1367 (make-char-table 'generic) | |
| 1368 "Char-table containing a property list of each character code. | |
| 1369 | |
| 1370 See also the documentation of `get-char-code-property' and | |
| 1371 `put-char-code-property'") | |
| 1372 ;; (let ((plist (aref char-code-property-table char))) | |
| 1373 (defun get-char-code-property (char propname) | |
| 1374 "Return the value of CHAR's PROPNAME property in `char-code-property-table'." | |
| 1375 (let ((plist (get-char-table char char-code-property-table))) | |
| 1376 (if (listp plist) | |
| 1377 (car (cdr (memq propname plist)))))) | |
| 1378 | |
| 1379 (defun put-char-code-property (char propname value) | |
| 1380 "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. | |
| 1381 It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." | |
| 1382 (let ((plist (get-char-table char char-code-property-table))) | |
| 1383 (if plist | |
| 1384 (let ((slot (memq propname plist))) | |
| 1385 (if slot | |
| 1386 (setcar (cdr slot) value) | |
| 1387 (nconc plist (list propname value)))) | |
| 1388 (put-char-table char (list propname value) char-code-property-table) | |
| 1389 ))) | |
| 1390 | |
| 1391 | |
| 1392 ;; Pretty description of encoded string | |
| 1393 | |
| 1394 ;; Alist of ISO 2022 control code vs the corresponding mnemonic string. | |
| 1395 ;; (defvar iso-2022-control-alist | |
| 1396 ;; '((?\x1b . "ESC") | |
| 1397 ;; (?\x0e . "SO") | |
| 1398 ;; (?\x0f . "SI") | |
| 1399 ;; (?\x8e . "SS2") | |
| 1400 ;; (?\x8f . "SS3") | |
| 1401 ;; (?\x9b . "CSI"))) | |
| 1402 | |
| 1403 ;; (defun encoded-string-description (str coding-system) | |
| 1404 ;; "Return a pretty description of STR that is encoded by CODING-SYSTEM." | |
| 1405 ;; (setq str (string-as-unibyte str)) | |
| 1406 ;; (let ((char (aref str 0)) | |
| 1407 ;; desc) | |
| 1408 ;; (when (< char 128) | |
| 1409 ;; (setq desc (or (cdr (assq char iso-2022-control-alist)) | |
| 1410 ;; (char-to-string char))) | |
| 1411 ;; (let ((i 1) | |
| 1412 ;; (len (length str))) | |
| 1413 ;; (while (< i len) | |
| 1414 ;; (setq char (aref str i)) | |
| 1415 ;; (if (>= char 128) | |
| 1416 ;; (setq desc nil i len) | |
| 1417 ;; (setq desc (concat desc " " | |
| 1418 ;; (or (cdr (assq char iso-2022-control-alist)) | |
| 1419 ;; (char-to-string char))) | |
| 1420 ;; i (1+ i)))))) | |
| 1421 ;; (or desc | |
| 1422 ;; (mapconcat (function (lambda (x) (format "0x%02x" x))) str " ")))) | |
| 1423 | |
| 1424 ;; (defun encode-coding-char (char coding-system) | |
| 1425 ;; "Encode CHAR by CODING-SYSTEM and return the resulting string. | |
| 1426 ;; If CODING-SYSTEM can't safely encode CHAR, return nil." | |
| 1427 ;; (if (cmpcharp char) | |
| 1428 ;; (setq char (car (decompose-composite-char char 'list)))) | |
| 1429 ;; (let ((str1 (char-to-string char)) | |
| 1430 ;; (str2 (make-string 2 char)) | |
| 1431 ;; (safe-charsets (and coding-system | |
| 1432 ;; (coding-system-get coding-system 'safe-charsets))) | |
| 1433 ;; enc1 enc2 i1 i2) | |
| 1434 ;; (when (or (eq safe-charsets t) | |
| 1435 ;; (memq (char-charset char) safe-charsets)) | |
| 1436 ;; ;; We must find the encoded string of CHAR. But, just encoding | |
| 1437 ;; ;; CHAR will put extra control sequences (usually to designate | |
| 1438 ;; ;; ASCII charaset) at the tail if type of CODING is ISO 2022. | |
| 1439 ;; ;; To exclude such tailing bytes, we at first encode one-char | |
| 1440 ;; ;; string and two-char string, then check how many bytes at the | |
| 1441 ;; ;; tail of both encoded strings are the same. | |
| 1442 ;; | |
| 1443 ;; (setq enc1 (string-as-unibyte (encode-coding-string str1 coding-system)) | |
| 1444 ;; i1 (length enc1) | |
| 1445 ;; enc2 (string-as-unibyte (encode-coding-string str2 coding-system)) | |
| 1446 ;; i2 (length enc2)) | |
| 1447 ;; (while (and (> i1 0) (= (aref enc1 (1- i1)) (aref enc2 (1- i2)))) | |
| 1448 ;; (setq i1 (1- i1) i2 (1- i2))) | |
| 1449 ;; | |
| 1450 ;; ;; Now (substring enc1 i1) and (substring enc2 i2) are the same, | |
| 1451 ;; ;; and they are the extra control sequences at the tail to | |
| 1452 ;; ;; exclude. | |
| 1453 ;; (substring enc2 0 i2)))) | |
| 1454 | |
| 1455 | |
| 1456 ;;; mule-cmds.el ends here |