code.delx.au - gnu-emacs/blob - lisp/international/mule-cmds.el

   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
   6 ;; Keywords: mule, multilingual
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 ;;; MULE related key bindings and menus.
  28
  29 (defvar mule-keymap (make-sparse-keymap "MULE")
  30   "Keymap for MULE (Multilingual environment) specific commands.")
  31 (fset 'mule-prefix mule-keymap)
  32
  33 ;; Keep "C-x C-m ..." for mule specific commands.
  34 (define-key ctl-x-map "\C-m" 'mule-prefix)
  35
  36 (define-key global-map [menu-bar mule] (cons "Mule" mule-keymap))
  37
  38 (setq menu-bar-final-items (cons 'mule menu-bar-final-items))
  39
  40 (defvar mule-describe-language-support-map
  41   (make-sparse-keymap "Describe Language Support"))
  42 (fset 'mule-describe-language-support-prefix
  43       mule-describe-language-support-map)
  44
  45 (defvar mule-set-language-environment-map
  46   (make-sparse-keymap "Set Language Environment"))
  47 (fset 'mule-set-language-environment-prefix
  48       mule-set-language-environment-map)
  49
  50 (define-key mule-keymap "m" 'toggle-enable-multibyte-characters)
  51 (define-key mule-keymap "f" 'set-buffer-file-coding-system)
  52 (define-key mule-keymap "t" 'set-terminal-coding-system)
  53 (define-key mule-keymap "k" 'encoded-kbd-set-coding-system)
  54 (define-key mule-keymap "p" 'set-current-process-coding-system)
  55 (define-key mule-keymap "i" 'select-input-method)
  56 (define-key mule-keymap "\C-\\" 'select-input-method)
  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 (define-key mule-keymap [view-hello-file]
  64   '("Show many languages" . view-hello-file))
  65 (define-key mule-keymap [mule-diag]
  66   '("Show diagnosis for MULE" . mule-diag))
  67 (define-key mule-keymap [separator-coding-system]
  68   '("--"))
  69 (define-key mule-keymap [set-process-coding-system]
  70   '("Set coding system of process" . set-current-process-coding-system))
  71 (define-key mule-keymap [encoded-kbd-set-coding-system]
  72   '("Set coding system for Encoded-kbd mode" . encoded-kbd-set-coding-system))
  73 (define-key mule-keymap [set-terminal-coding-system]
  74   '("Set coding system of terminal" . set-terminal-coding-system))
  75 (define-key mule-keymap [set-buffer-file-coding-system]
  76   '("Set coding system of buffer file" . set-buffer-file-coding-system))
  77 (define-key mule-keymap [describe-current-coding-system]
  78   '("Describe current coding systems" . describe-current-coding-system))
  79 (define-key mule-keymap [separator-input-method]
  80   '("--"))
  81 (define-key mule-keymap [describe-input-method]
  82   '("Describe input method" . describe-input-method))
  83 (define-key mule-keymap [select-input-method]
  84   '("Select input method" . select-input-method))
  85 (define-key mule-keymap [toggle-input-method]
  86   '("Toggle input method" . toggle-input-method))
  87 (define-key mule-keymap [separator-mule]
  88   '("--"))
  89 (define-key mule-keymap [set-language-environment]
  90   '("Set language environment" . mule-set-language-environment-prefix))
  91 (define-key mule-keymap [describe-language-support]
  92   '("Describe language support" . mule-describe-language-support-prefix))
  93 (define-key mule-keymap [toggle-mule]
  94   '("Disable/enable multibyte character" . toggle-enable-multibyte-characters))
  95
  96 ;; These are meaningless when running under X.
  97 (put 'encoded-kbd-set-coding-system 'menu-enable
  98      '(null window-system))
  99 (put 'set-terminal-coding-system 'menu-enable
 100      '(null window-system))
 101
 102 ;; This should be a single character key binding because users use it
 103 ;; very frequently while editing multilingual text.  Now we can use
 104 ;; only two such keys: "\C-\\" and "\C-^", but the latter is not
 105 ;; convenient because it requires shifting on most keyboards.  An
 106 ;; alternative is "\C-\]" which is now bound to `abort-recursive-edit'
 107 ;; but it won't be used that frequently.
 108 (define-key global-map "\C-\\" 'toggle-input-method)
 109
 110 (defun toggle-enable-multibyte-characters (&optional arg)
 111   "Change whether this buffer enables multibyte characters.
 112 With arg, make them enable iff arg is positive."
 113   (interactive "P")
 114   (setq enable-multibyte-characters
 115         (if (null arg) (null enable-multibyte-characters)
 116           (> (prefix-numeric-value arg) 0)))
 117   (force-mode-line-update))
 118
 119 (defun view-hello-file ()
 120   "Display the HELLO file which list up many languages and characters."
 121   (interactive)
 122   ;; We have to decode the file in any environment.
 123   (let ((default-enable-multibyte-characters t)
 124         (coding-system-for-read 'iso-2022-7))
 125     (find-file-read-only (expand-file-name "HELLO" data-directory))))
 126
 127 \f
 128 ;;; Language support staffs.
 129
 130 (defvar primary-language "English"
 131   "Name of a user's primary language.
 132 Emacs provide various language supports based on this variable.")
 133
 134 (defvar language-info-alist nil
 135   "Alist of language names vs the corresponding information of various kind.
 136 Each element looks like:
 137         (LANGUAGE-NAME . ((KEY . INFO) ...))
 138 where LANGUAGE-NAME is a string,
 139 KEY is a symbol denoting the kind of information,
 140 INFO is any Lisp object which contains the actual information related
 141 to KEY.")
 142
 143 (defun get-language-info (language-name key)
 144   "Return the information for LANGUAGE-NAME of the kind KEY.
 145 LANGUAGE-NAME is a string.
 146 KEY is a symbol denoting the kind of required information."
 147   (let ((lang-slot (assoc-ignore-case
 148                     (downcase language-name) language-info-alist)))
 149     (if lang-slot
 150         (cdr (assq key (cdr lang-slot))))))
 151
 152 (defun set-language-info (language-name key info)
 153   "Set for LANGUAGE-NAME the information INFO under KEY.
 154 LANGUAGE-NAME is a string
 155 KEY is a symbol denoting the kind of information.
 156 INFO is any Lisp object which contains the actual information.
 157
 158 Currently, the following KEYs are used by Emacs:
 159 charset: list of symbols whose values are charsets specific to the language.
 160 coding-system: list of coding systems specific to the langauge.
 161 tutorial: a tutorial file name written in the language.
 162 sample-text: one line short text containing characters of the language.
 163 input-method: alist of input method names for the language vs information
 164   for activating them.  Use `register-input-method' (which see)
 165   to add a new input method to the alist.
 166 documentation: a string describing how Emacs supports the langauge.
 167 describe-function: a function to call for descriebing how Emacs supports
 168  the language.  The function uses information listed abobe.
 169 setup-function: a function to call for setting up environment
 170  convenient for the language.
 171
 172 Emacs will use more KEYs in the future.  To avoid conflict, users
 173 should use prefix \"user-\" in the name of KEY if he wants to set
 174 different kind of information."
 175   (let (lang-slot key-slot)
 176     (setq lang-slot (assoc language-name language-info-alist))
 177     (if (null lang-slot)                ; If no slot for the language, add it.
 178         (setq lang-slot (list language-name)
 179               language-info-alist (cons lang-slot language-info-alist)))
 180     (setq key-slot (assq key lang-slot))
 181     (if (null key-slot)                 ; If no slot for the key, add it.
 182         (progn
 183           (setq key-slot (list key))
 184           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 185     (setcdr key-slot info)
 186     ;; Setup menu.
 187     (cond ((eq key 'describe-function)
 188            (define-key-after mule-describe-language-support-map
 189              (vector (intern language-name))
 190              (cons language-name info)
 191              t))
 192           ((eq key 'setup-function)
 193            (define-key-after mule-set-language-environment-map
 194              (vector (intern language-name))
 195              (cons language-name info)
 196              t)))
 197     ))
 198
 199 (defun set-language-info-alist (language-name alist)
 200   "Set for LANGUAGE-NAME the information in ALIST.
 201 ALIST is an alist of KEY and INFO.  See the documentation of
 202 `set-langauge-info' for the meanings of KEY and INFO."
 203   (while alist
 204     (set-language-info language-name (car (car alist)) (cdr (car alist)))
 205     (setq alist (cdr alist))))
 206
 207 (defun read-language-name (key prompt &optional initial-input)
 208   "Read language name which has information for KEY, prompting with PROMPT."
 209   (let* ((completion-ignore-case t)
 210          (name (completing-read prompt
 211                                 language-info-alist
 212                                 (function (lambda (elm) (assq key elm)))
 213                                 t
 214                                 initial-input)))
 215     (if (and (> (length name) 0)
 216              (get-language-info name key))
 217         name)))
 218 \f
 219 ;;; Multilingual input methods.
 220
 221 (defvar current-input-method nil
 222   "The current input method for multilingual text.
 223 The value is a cons of language name and input method name.
 224 If nil, it means no input method is activated now.")
 225 (make-variable-buffer-local 'current-input-method)
 226 (put 'current-input-method 'permanent-local t)
 227
 228 (defvar current-input-method-title nil
 229   "Title string of the current input method shown in mode line.
 230 Every input method should set this to an appropriate value when activated.")
 231 (make-variable-buffer-local 'current-input-method-title)
 232 (put 'current-input-method-title 'permanent-local t)
 233
 234 (defvar default-input-method nil
 235   "Default input method.
 236 The default input method is the one activated automatically by the command
 237 `toggle-input-method' (\\[toggle-input-method]).
 238 The value is a cons of language name and input method name.")
 239
 240 (defvar default-input-method-title nil
 241   "Title string of the default input method.")
 242
 243 (defvar previous-input-method nil
 244   "Input method selected previously.
 245 This is the one selected before the current input method is selected.
 246 See also the documentation of `default-input-method'.")
 247
 248 (defvar inactivate-current-input-method-function nil
 249   "Function to call for inactivating the current input method.
 250 Every input method should set this to an appropriate value when activated.
 251 This function is called with no argument.")
 252 (make-variable-buffer-local 'inactivate-current-input-method-function)
 253 (put 'inactivate-current-input-method-function 'permanent-local t)
 254
 255 (defvar describe-current-input-method-function nil
 256   "Function to call for describing the current input method.
 257 This function is called with no argument.")
 258 (make-variable-buffer-local 'describe-current-input-method-function)
 259 (put 'describe-current-input-method-function 'permanent-local t)
 260
 261 (defun register-input-method (language-name input-method)
 262   "Register INPUT-METHOD as an input method of LANGUAGE-NAME.
 263 LANGUAGE-NAME is a string.
 264 INPUT-METHOD is a list of the form:
 265         (METHOD-NAME ACTIVATE-FUNC ARG ...)
 266 where METHOD-NAME is the name of this method,
 267 ACTIVATE-FUNC is the function to call for activating this method.
 268 Arguments for the function are METHOD-NAME and ARGs."
 269   (let ((slot (get-language-info language-name 'input-method))
 270         method-slot)
 271     (if (null slot)
 272         (set-language-info language-name 'input-method (list input-method))
 273       (setq method-slot (assoc (car input-method) slot))
 274       (if method-slot
 275           (setcdr method-slot (cdr input-method))
 276         (set-language-info language-name 'input-method
 277                            (cons input-method slot))))))
 278
 279 (defun read-language-and-input-method-name ()
 280   "Read a language names and the corresponding input method from a minibuffer.
 281 Return a cons of those names."
 282   (let ((language-name (read-language-name
 283                         'input-method
 284                         "Language: "
 285                         (if previous-input-method
 286                             (cons (car previous-input-method) 0)))))
 287     (if (null language-name)
 288         (error "No input method for the specified language"))
 289     (let* ((completion-ignore-case t)
 290            (key-slot (cdr (assq 'input-method
 291                                 (assoc language-name language-info-alist))))
 292            (method-name
 293             (completing-read "Input method: " key-slot nil t
 294                              (if (and previous-input-method
 295                                       (string= language-name
 296                                                (car previous-input-method)))
 297                                  (cons (cdr previous-input-method) 0)))))
 298       (if (= (length method-name) 0)
 299           (error "No input method specified"))
 300       (list language-name
 301             (car (assoc-ignore-case (downcase method-name) key-slot))))))
 302
 303 (defun set-default-input-method (language-name method-name)
 304   "Set the default input method to METHOD-NAME for inputting LANGUAGE-NAME.
 305 The default input method is the one activated automatically by the command
 306 `toggle-input-method' (\\[toggle-input-method]).
 307 This doesn't affect the currently activated input method."
 308   (interactive (read-language-and-input-method-name))
 309   (let* ((key-slot (get-language-info language-name 'input-method))
 310          (method-slot (assoc method-name key-slot)))
 311     (if (null method-slot)
 312         (error "No input method `%s' for %s" method-name language-name))
 313     (setq default-input-method (cons language-name method-name))))
 314
 315 (defun select-input-method (language-name method-name)
 316   "Select and activate input method METHOD-NAME for inputting LANGUAGE-NAME.
 317 The information for activating METHOD-NAME is stored
 318 in `language-info-alist' under the key 'input-method.
 319 The format of the information has the form:
 320         ((METHOD-NAME ACTIVATE-FUNC ARG ...) ...)
 321 where ACTIVATE-FUNC is a function to call for activating this method.
 322 Arguments for the function are METHOD-NAME and ARGs."
 323   (interactive (read-language-and-input-method-name))
 324   (let* ((key-slot (get-language-info language-name 'input-method))
 325          (method-slot (assoc method-name key-slot)))
 326     (if (null method-slot)
 327         (error "No input method `%s' for %s" method-name language-name))
 328     (if current-input-method
 329         (progn
 330           (setq previous-input-method current-input-method)
 331           (unwind-protect
 332               (funcall inactivate-current-input-method-function)
 333             (setq current-input-method nil))))
 334     (setq method-slot (cdr method-slot))
 335     (apply (car method-slot) method-name (cdr method-slot))
 336     (setq default-input-method
 337           (setq current-input-method (cons language-name method-name)))
 338     (setq default-input-method-title current-input-method-title)
 339     (setq current-input-method default-input-method)))
 340
 341 (defun toggle-input-method (&optional arg)
 342   "Toggle whether a multilingual input method is activated in this buffer.
 343 With arg, activate an input method specified interactively.
 344 Without arg, the method being activated is the one selected most recently,
 345  but if no input method has ever been selected, select one interactively."
 346   (interactive "P")
 347   (if arg
 348       (call-interactively 'select-input-method)
 349     (if (null current-input-method)
 350         (if default-input-method
 351             (select-input-method (car default-input-method)
 352                                  (cdr default-input-method))
 353           (call-interactively 'select-input-method))
 354       (funcall inactivate-current-input-method-function)
 355       (setq current-input-method nil))))
 356
 357 (defun describe-input-method ()
 358   "Describe the current input method."
 359   (interactive)
 360   (if current-input-method
 361       (if (and (symbolp describe-current-input-method-function)
 362                (fboundp describe-current-input-method-function))
 363           (funcall describe-current-input-method-function)
 364         (message "No way to describe the current input method `%s'"
 365                  (cdr current-input-method))
 366         (ding))
 367     (message "No input method is activated now")
 368     (ding)))
 369
 370 (defun read-multilingual-string (prompt &optional initial-input
 371                                         language-name method-name)
 372   "Read a multilingual string from minibuffer, prompting with string PROMPT.
 373 The input method selected last time is activated in minibuffer.
 374 If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
 375 Optional 3rd and 4th arguments LANGUAGE-NAME and METHOD-NAME specify
 376  the input method to be activated instead of the one selected last time."
 377   (let ((minibuffer-setup-hook '(toggle-input-method))
 378         (default-input-method default-input-method))
 379     (if (and language-name method-name)
 380         (set-default-input-method language-name method-name))
 381     (read-string prompt initial-input)))
 382
 383 ;; Variables to control behavior of input methods.  All input methods
 384 ;; should react to these variables.
 385
 386 (defvar input-method-tersely-flag nil
 387   "*If this flag is non-nil, input method works rather tersely.
 388
 389 For instance, Quail input method does not show guidance buffer while
 390 inputting at minibuffer if this flag is t.")
 391
 392 (defvar input-method-activate-hook nil
 393   "Normal hook run just after an input method is activated.")
 394
 395 (defvar input-method-inactivate-hook nil
 396   "Normal hook run just after an input method is inactivated.")
 397
 398 (defvar input-method-after-insert-chunk-hook nil
 399   "Normal hook run just after an input method insert some chunk of text.")
 400
 401 \f
 402 ;;; Language specific setup functions.
 403 (defun set-language-environment (language-name)
 404   "Setup multilingual environment convenient for LANGUAGE-NAME.
 405
 406 For that, a fucntion returned by:
 407   (get-language-info LANGUAGE-NAME 'setup-function)
 408 is called."
 409   (interactive (list (read-language-name 'setup-function "Language: ")))
 410   (let (func)
 411     (if (or (null language-name)
 412             (null (setq func
 413                         (get-language-info language-name 'setup-function))))
 414         (error "No way to setup environment for the specified language"))
 415     (funcall func)))
 416
 417 ;; Print all arguments with `princ', then print "\n".
 418 (defsubst princ-list (&rest args)
 419   (while args (princ (car args)) (setq args (cdr args)))
 420   (princ "\n"))
 421
 422 (defun describe-language-support (language-name)
 423   "Describe how Emacs supports LANGUAGE-NAME.
 424
 425 For that, a function returned by:
 426   (get-language-info LANGUAGE-NAME 'describe-function)
 427 is called."
 428   (interactive (list (read-language-name 'documentation "Language: ")))
 429   (let (func)
 430     (if (or (null language-name)
 431             (null (setq func
 432                         (get-language-info language-name 'describe-function))))
 433         (error "No documentation for the specified language"))
 434     (funcall func)))
 435
 436 ;; Print LANGUAGE-NAME specific information such as input methods,
 437 ;; charsets, and coding systems.  This function is intended to be
 438 ;; called from various describe-LANGUAGE-support functions defined in
 439 ;; lisp/language/LANGUAGE.el.
 440 (defun describe-language-support-internal (language-name)
 441   (with-output-to-temp-buffer "*Help*"
 442     (let ((doc (get-language-info language-name 'documentation)))
 443       (if (stringp doc)
 444           (princ-list doc)))
 445     (princ "-----------------------------------------------------------\n")
 446     (princ-list "List of items specific to "
 447                 language-name
 448                 " support")
 449     (princ "-----------------------------------------------------------\n")
 450     (let ((str (get-language-info language-name 'sample-text)))
 451       (if (stringp str)
 452           (progn
 453             (princ "<sample text>\n")
 454             (princ-list "  " str))))
 455     (princ "<input methods>\n")
 456     (let ((l (get-language-info language-name 'input-method)))
 457       (while l
 458         (princ-list "  " (car (car l)))
 459         (setq l (cdr l))))
 460     (princ "<character sets>\n")
 461     (let ((l (get-language-info language-name 'charset)))
 462       (if (null l)
 463           (princ-list "  nothing specific to " language-name)
 464         (while l
 465           (princ-list "  " (car l) ": "
 466                       (charset-description (car l)))
 467           (setq l (cdr l)))))
 468     (princ "<coding systems>\n")
 469     (let ((l (get-language-info language-name 'coding-system)))
 470       (if (null l)
 471           (princ-list "  nothing specific to " language-name)
 472         (while l
 473           (princ-list "  " (car l) ":\n\t"
 474                       (coding-system-docstring (car l)))
 475           (setq l (cdr l)))))))
 476 \f
 477 ;;; Charset property
 478
 479 (defsubst get-charset-property (charset propname)
 480   "Return the value of CHARSET's PROPNAME property.
 481 This is the last value stored with
 482 `(put-charset-property CHARSET PROPNAME VALUE)'."
 483   (plist-get (charset-plist charset) propname))
 484
 485 (defsubst put-charset-property (charset propname value)
 486   "Store CHARSETS's PROPNAME property with value VALUE.
 487 It can be retrieved with `(get-charset-property CHARSET PROPNAME)'."
 488   (set-charset-plist charset
 489                      (plist-put (charset-plist charset) propname value)))
 490
 491 ;;; Character code property
 492 (put 'char-code-property-table 'char-table-extra-slots 0)
 493
 494 (defvar char-code-property-table
 495   (make-char-table 'char-code-property-table)
 496   "Char-table containing a property list of each character code.
 497
 498 See also the documentation of `get-char-code-property' and
 499 `put-char-code-property'")
 500
 501 (defun get-char-code-property (char propname)
 502   "Return the value of CHAR's PROPNAME property in `char-code-property-table'."
 503   (let ((plist (aref char-code-property-table char)))
 504     (if (listp plist)
 505         (car (cdr (memq propname plist))))))
 506
 507 (defun put-char-code-property (char propname value)
 508   "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'.
 509 It can be retrieved with `(get-char-code-property CHAR PROPNAME)'."
 510   (let ((plist (aref char-code-property-table char)))
 511     (if plist
 512         (let ((slot (memq propname plist)))
 513           (if slot
 514               (setcar (cdr slot) value)
 515             (nconc plist (list propname value))))
 516       (aset char-code-property-table char (list propname value)))))
 517
 518 ;;; mule-cmds.el ends here