Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-cmds.el @ 155:43dd3413c7c7 r20-3b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b4
author cvs
date Mon, 13 Aug 2007 09:39:39 +0200
parents
children 5a88923fcbfe
comparison
equal deleted inserted replaced
154:94141801dd7e 155:43dd3413c7c7
1 ;;; mule-cmds.el --- Commands for mulitilingual environment
2
3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
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 (fset 'mule-prefix mule-keymap)
33
34 ;; Keep "C-x C-k ..." for mule specific commands.
35 (define-key ctl-x-map "\C-k" 'mule-prefix)
36
37 (defvar mule-describe-language-support-map
38 (make-sparse-keymap "Describe Language Support"))
39 (fset 'mule-describe-language-support-prefix
40 mule-describe-language-support-map)
41
42 (defvar mule-set-language-environment-map
43 (make-sparse-keymap "Set Language Environment"))
44 (fset 'mule-set-language-environment-prefix
45 mule-set-language-environment-map)
46
47 (define-key mule-keymap "f" 'set-buffer-file-coding-system)
48 (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs
49 (define-key mule-keymap "t" 'set-terminal-coding-system)
50 (define-key mule-keymap "k" 'set-keyboard-coding-system)
51 (define-key mule-keymap "p" 'set-current-process-coding-system)
52 (define-key mule-keymap "P" 'set-default-process-coding-system) ; XEmacs
53 (define-key mule-keymap "i" 'select-input-method)
54 (define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs
55 (define-key mule-keymap "C" 'list-coding-system) ; XEmacs
56 (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs
57
58 (define-key help-map "\C-L" 'describe-language-support)
59 (define-key help-map "\C-\\" 'describe-input-method)
60 (define-key help-map "C" 'describe-current-coding-system)
61 (define-key help-map "h" 'view-hello-file)
62
63 ;; Menu for XEmacs were moved to x11/x-menubar.el.
64
65
66 ;; This should be a single character key binding because users use it
67 ;; very frequently while editing multilingual text. Now we can use
68 ;; only two such keys: "\C-\\" and "\C-^", but the latter is not
69 ;; convenient because it requires shifting on most keyboards. An
70 ;; alternative is "\C-\]" which is now bound to `abort-recursive-edit'
71 ;; but it won't be used that frequently.
72 (define-key global-map "\C-\\" 'toggle-input-method)
73
74 (defun view-hello-file ()
75 "Display the HELLO file which list up many languages and characters."
76 (interactive)
77 (find-file-read-only (expand-file-name "HELLO" data-directory)))
78
79
80 ;;; Language support staffs.
81
82 (defvar primary-language "English"
83 "Name of a user's primary language.
84 Emacs provide various language supports based on this variable.")
85
86 (defvar language-info-alist nil
87 "Alist of language names vs the corresponding information of various kind.
88 Each element looks like:
89 (LANGUAGE-NAME . ((KEY . INFO) ...))
90 where LANGUAGE-NAME is a string,
91 KEY is a symbol denoting the kind of information,
92 INFO is any Lisp object which contains the actual information related
93 to KEY.")
94
95 (defun get-language-info (language-name key)
96 "Return the information for LANGUAGE-NAME of the kind KEY.
97 LANGUAGE-NAME is a string.
98 KEY is a symbol denoting the kind of required information."
99 (let ((lang-slot (assoc language-name language-info-alist)))
100 (if lang-slot
101 (cdr (assq key (cdr lang-slot))))))
102
103 ;; Return a lambda form which calls `describe-language-support' with
104 ;; argument LANG.
105 (defun build-describe-language-support-function (lang)
106 `(lambda ()
107 (interactive)
108 (describe-language-support ,lang)))
109
110 ;; Return a lambda form which calls `set-language-environment' with
111 ;; argument LANG.
112 (defun build-set-language-environment-function (lang)
113 `(lambda ()
114 (interactive)
115 (set-language-environment ,lang)))
116
117 (defun set-language-info (language-name key info)
118 "Set for LANGUAGE-NAME the information INFO under KEY.
119 LANGUAGE-NAME is a string
120 KEY is a symbol denoting the kind of information.
121 INFO is any Lisp object which contains the actual information.
122
123 Currently, the following KEYs are used by Emacs:
124 charset: list of symbols whose values are charsets specific to the language.
125 coding-system: list of coding systems specific to the langauge.
126 setup-function: see the documentation of `set-language-environment'.
127 tutorial: a tutorial file name written in the language.
128 sample-text: one line short text containing characters of the language.
129 documentation: a docstring describing how the language is supported,
130 or a fuction to call to describe it,
131 or t which means call `describe-language-support' to describe it.
132 input-method: alist of input method names for the language vs information
133 for activating them. Use `register-input-method' (which see)
134 to add a new input method to the alist.
135
136 Emacs will use more KEYs in the future. To avoid the conflition, users
137 should use prefix \"user-\" in the name of KEY."
138 (let (lang-slot key-slot)
139 (setq lang-slot (assoc language-name language-info-alist))
140 (if (null lang-slot) ; If no slot for the language, add it.
141 (setq lang-slot (list language-name)
142 language-info-alist (cons lang-slot language-info-alist)))
143 (setq key-slot (assq key lang-slot))
144 (if (null key-slot) ; If no slot for the key, add it.
145 (progn
146 (setq key-slot (list key))
147 (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
148 (setcdr key-slot info)
149 ;; Setup menu.
150 (cond ((eq key 'documentation)
151 (define-key mule-describe-language-support-map
152 (vector (intern language-name))
153 (cons language-name
154 (build-describe-language-support-function language-name))))
155 ((eq key 'setup-function)
156 (define-key mule-set-language-environment-map
157 (vector (intern language-name))
158 (cons language-name
159 (build-set-language-environment-function language-name)))))
160 ))
161
162 (defun set-language-info-alist (language-name alist)
163 "Set for LANGUAGE-NAME the information in ALIST.
164 ALIST is an alist of KEY and INFO. See the documentation of
165 `set-langauge-info' for the meanings of KEY and INFO."
166 (while alist
167 (set-language-info language-name (car (car alist)) (cdr (car alist)))
168 (setq alist (cdr alist))))
169
170 (defun read-language-name (key prompt &optional initial-input)
171 "Read language name which has information for KEY, prompting with PROMPT."
172 (let* ((completion-ignore-case t)
173 (name (completing-read prompt
174 language-info-alist
175 (function (lambda (elm) (assq key elm)))
176 t
177 initial-input)))
178 (and (> (length name) 0)
179 (car (assoc-ignore-case (downcase name) language-info-alist)))))
180
181 ;;; Multilingual input methods.
182
183 (defvar current-input-method nil
184 "The current input method for multilingual text.
185 The value is a cons of language name and input method name.
186 If nil, it means no input method is activated now.")
187 (make-variable-buffer-local 'current-input-method)
188 (put 'current-input-method 'permanent-local t)
189
190 (defvar current-input-method-title nil
191 "Title string of the current input method shown in mode line.
192 Every input method should set this an appropriate value when activated.")
193 (make-variable-buffer-local 'current-input-method-title)
194 (put 'current-input-method-title 'permanent-local t)
195
196 (defvar default-input-method nil
197 "Default input method.
198 The default input method is the one activated automatically by the command
199 `toggle-input-method' (\\[toggle-input-method]).
200 The value is a cons of language name and input method name.")
201
202 (defvar default-input-method-title nil
203 "Title string of the default input method.")
204
205 (defvar previous-input-method nil
206 "Input method selected previously.
207 This is the one selected before the current input method is selected.
208 See also the documentation of `default-input-method'.")
209
210 (defvar inactivate-current-input-method-function nil
211 "Function to call for inactivating the current input method.
212 Every input method should set this to an appropriate value when activated.
213 This function is called with no argument.")
214 (make-variable-buffer-local 'inactivate-current-input-method-function)
215 (put 'inactivate-current-input-method-function 'permanent-local t)
216
217 (defvar describe-current-input-method-function nil
218 "Function to call for describing the current input method.
219 This function is called with no argument.")
220 (make-variable-buffer-local 'describe-current-input-method-function)
221 (put 'describe-current-input-method-function 'permanent-local t)
222
223 (defun register-input-method (language-name input-method)
224 "Register INPUT-METHOD as an input method of LANGUAGE-NAME.
225 LANGUAGE-NAME is a string.
226 INPUT-METHOD is a list of the form:
227 (METHOD-NAME ACTIVATE-FUNC ARG ...)
228 where METHOD-NAME is the name of this method,
229 ACTIVATE-FUNC is the function to call for activating this method.
230 Arguments for the function are METHOD-NAME and ARGs."
231 (let ((slot (get-language-info language-name 'input-method))
232 method-slot)
233 (if (null slot)
234 (set-language-info language-name 'input-method (list input-method))
235 (setq method-slot (assoc (car input-method) slot))
236 (if method-slot
237 (setcdr method-slot (cdr input-method))
238 (set-language-info language-name 'input-method
239 (cons input-method slot))))))
240
241 (defun read-language-and-input-method-name ()
242 "Read a language names and the corresponding input method from a minibuffer.
243 Return a cons of those names."
244 (let ((language-name (read-language-name
245 'input-method
246 "Language: "
247 (if previous-input-method
248 (cons (car previous-input-method) 0)))))
249 (if (null language-name)
250 (error "No input method for the specified language"))
251 (let* ((completion-ignore-case t)
252 (key-slot (cdr (assq 'input-method
253 (assoc language-name language-info-alist))))
254 (method-name
255 (completing-read "Input method: " key-slot nil t
256 (if (and previous-input-method
257 (string= language-name
258 (car previous-input-method)))
259 (cons (cdr previous-input-method) 0)))))
260 (if (= (length method-name) 0)
261 (error "No input method specified"))
262 (list language-name
263 (car (assoc-ignore-case (downcase method-name) key-slot))))))
264
265 (defun set-default-input-method (language-name method-name)
266 "Set the default input method to METHOD-NAME for inputting LANGUAGE-NAME.
267 The default input method is the one activated automatically by the command
268 `toggle-input-method' (\\[toggle-input-method]).
269 This doesn't affect the currently activated input method."
270 (interactive (read-language-and-input-method-name))
271 (let* ((key-slot (get-language-info language-name 'input-method))
272 (method-slot (assoc method-name key-slot)))
273 (if (null method-slot)
274 (error "No input method `%s' for %s" method-name language-name))
275 (setq default-input-method (cons language-name method-name))))
276
277 (defun select-input-method (language-name method-name)
278 "Select and activate input method METHOD-NAME for inputting LANGUAGE-NAME.
279 The information for activating METHOD-NAME is stored
280 in `language-info-alist' under the key 'input-method.
281 The format of the information has the form:
282 ((METHOD-NAME ACTIVATE-FUNC ARG ...) ...)
283 where ACTIVATE-FUNC is a function to call for activating this method.
284 Arguments for the function are METHOD-NAME and ARGs."
285 (interactive (read-language-and-input-method-name))
286 (let* ((key-slot (get-language-info language-name 'input-method))
287 (method-slot (assoc method-name key-slot)))
288 (if (null method-slot)
289 (error "No input method `%s' for %s" method-name language-name))
290 (if current-input-method
291 (progn
292 (if (not (equal previous-input-method current-input-method))
293 (setq previous-input-method current-input-method))
294 (funcall inactivate-current-input-method-function)))
295 (setq method-slot (cdr method-slot))
296 (apply (car method-slot) method-name (cdr method-slot))
297 (setq default-input-method
298 (setq current-input-method (cons language-name method-name)))
299 (setq default-input-method-title current-input-method-title)
300 (setq current-input-method default-input-method)))
301
302 (defun toggle-input-method (&optional arg)
303 "Toggle whether a multilingual input method is activated in this buffer.
304 With arg, activate an input method specified interactively.
305 Without arg, the method being activated is the one selected most recently,
306 but if no input method has ever been selected, select one interactively."
307 (interactive "P")
308 (if arg
309 (call-interactively 'select-input-method)
310 (if (null current-input-method)
311 (if default-input-method
312 (select-input-method (car default-input-method)
313 (cdr default-input-method))
314 (call-interactively 'select-input-method))
315 (funcall inactivate-current-input-method-function)
316 (setq current-input-method nil))))
317
318 (defun describe-input-method ()
319 "Describe the current input method."
320 (interactive)
321 (if current-input-method
322 (if (and (symbolp describe-current-input-method-function)
323 (fboundp describe-current-input-method-function))
324 (funcall describe-current-input-method-function)
325 (message "No way to describe the current input method `%s'"
326 (cdr current-input-method))
327 (ding))
328 (message "No input method is activated now")
329 (ding)))
330
331 ;; (defun read-multilingual-string (prompt &optional initial-input
332 ;; language-name method-name)
333 ;; "Read a multilingual string from minibuffer, prompting with string PROMPT.
334 ;; The input method selected last time is activated in minibuffer.
335 ;; If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
336 ;; Optional 3rd and 4th arguments LANGUAGE-NAME and METHOD-NAME specify
337 ;; the input method to be activated instead of the one selected last time."
338 ;; (let ((minibuffer-setup-hook '(toggle-input-method))
339 ;; (default-input-method default-input-method))
340 ;; (if (and language-name method-name)
341 ;; (set-default-input-method language-name method-name))
342 ;; (read-string prompt initial-input)))
343
344 ;; Variables to control behavior of input methods. All input methods
345 ;; should react to these variables.
346
347 (defvar input-method-tersely-flag nil
348 "*If this flag is non-nil, input method works rather tersely.
349
350 For instance, Quail input method does not show guidance buffer while
351 inputting at minibuffer if this flag is t.")
352
353 ;; (defvar input-method-activate-hook nil
354 ;; "Normal hook run just after an input method is activated.")
355
356 ;; (defvar input-method-inactivate-hook nil
357 ;; "Normal hook run just after an input method is inactivated.")
358
359 ;; (defvar input-method-after-insert-chunk-hook nil
360 ;; "Normal hook run just after an input method insert some chunk of text.")
361
362
363 ;;; Language specific setup functions.
364 ;; (defun set-language-environment (language-name)
365 ;; "Setup a user's environment for LANGUAGE-NAME.
366 ;;
367 ;; To setup, a fucntion returned by:
368 ;; (get-language-info LANGUAGE-NAME 'setup-function)
369 ;; is called."
370 ;; (interactive (list (read-language-name 'setup-function "Language: ")))
371 ;; (let (func)
372 ;; (if (or (null language-name)
373 ;; (null (setq func
374 ;; (get-language-info language-name 'setup-function))))
375 ;; (error "No way to setup environment for the specified language"))
376 ;; (funcall func)))
377
378 ;; Print all arguments with `princ', then print "\n".
379 (defsubst princ-list (&rest args)
380 (while args (princ (car args)) (setq args (cdr args)))
381 (princ "\n"))
382
383 (defun describe-language-support (language-name)
384 "Show documentation about how Emacs supports LANGUAGE-NAME."
385 (interactive (list (read-language-name 'documentation "Language: ")))
386 (let (doc)
387 (if (or (null language-name)
388 (null (setq doc
389 (get-language-info language-name 'documentation))))
390 (error "No documentation for the specified language"))
391 (with-output-to-temp-buffer "*Help*"
392 (if (not (eq doc t))
393 (cond ((stringp doc)
394 (princ doc))
395 ((and (symbolp doc) (fboundp doc))
396 (funcall doc))
397 (t
398 (error "Invalid documentation data for %s" language-name)))
399 (princ-list "List of items specific to "
400 language-name
401 " environment")
402 (princ "-----------------------------------------------------------\n")
403 (let ((str (get-language-info language-name 'sample-text)))
404 (if (stringp str)
405 (progn
406 (princ "<sample text>\n")
407 (princ-list " " str))))
408 (princ "<input methods>\n")
409 (let ((l (get-language-info language-name 'input-method)))
410 (while l
411 (princ-list " " (car (car l)))
412 (setq l (cdr l))))
413 (princ "<character sets>\n")
414 (let ((l (get-language-info language-name 'charset)))
415 (if (null l)
416 (princ-list " nothing specific to " language-name)
417 (while l
418 (princ-list " " (car l)
419 (format ":%3d:\n\t" (charset-id (car l)))
420 (charset-description (car l)))
421 (setq l (cdr l)))))
422 (princ "<coding systems>\n")
423 (let ((l (get-language-info language-name 'coding-system)))
424 (if (null l)
425 (princ-list " nothing specific to " language-name)
426 (while l
427 (princ-list " " (car l) ":\n\t"
428 (coding-system-docstring (car l)))
429 (setq l (cdr l)))))))))
430
431 ;;; Charset property
432
433 ;; (defsubst get-charset-property (charset propname)
434 ;; "Return the value of CHARSET's PROPNAME property.
435 ;; This is the last value stored with
436 ;; `(put-charset-property CHARSET PROPNAME VALUE)'."
437 ;; (plist-get (charset-plist charset) propname))
438
439 ;; (defsubst put-charset-property (charset propname value)
440 ;; "Store CHARSETS's PROPNAME property with value VALUE.
441 ;; It can be retrieved with `(get-charset-property CHARSET PROPNAME)'."
442 ;; (set-charset-plist charset
443 ;; (plist-put (charset-plist charset) propname value)))
444
445 ;;; Character code property
446 ;; (put 'char-code-property-table 'char-table-extra-slots 0)
447
448 ;; (defvar char-code-property-table
449 ;; (make-char-table 'char-code-property-table)
450 ;; "Char-table containing a property list of each character code.
451 ;;
452 ;; See also the documentation of `get-char-code-property' and
453 ;; `put-char-code-property'")
454
455 ;; (defun get-char-code-property (char propname)
456 ;; "Return the value of CHAR's PROPNAME property in `char-code-property-table'."
457 ;; (let ((plist (aref char-code-property-table char)))
458 ;; (if (listp plist)
459 ;; (car (cdr (memq propname plist))))))
460
461 ;; (defun put-char-code-property (char propname value)
462 ;; "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'.
463 ;; It can be retrieved with `(get-char-code-property CHAR PROPNAME)'."
464 ;; (let ((plist (aref char-code-property-table char)))
465 ;; (if plist
466 ;; (let ((slot (memq propname plist)))
467 ;; (if slot
468 ;; (setcar (cdr slot) value)
469 ;; (nconc plist (list propname value))))
470 ;; (aset char-code-property-table char (list propname value)))))
471
472 (provide 'mule-cmds)
473
474 ;;; mule-cmds.el ends here