Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-cmds.el @ 207:e45d5e7c476e r20-4b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b2
author cvs
date Mon, 13 Aug 2007 10:03:52 +0200
parents 850242ba4a81
children 41ff10fd062f
comparison
equal deleted inserted replaced
206:d3e9274cbc4e 207:e45d5e7c476e
27 27
28 ;;; MULE related key bindings and menus. 28 ;;; MULE related key bindings and menus.
29 29
30 (defvar mule-keymap (make-sparse-keymap "MULE") 30 (defvar mule-keymap (make-sparse-keymap "MULE")
31 "Keymap for MULE (Multilingual environment) specific commands.") 31 "Keymap for MULE (Multilingual environment) specific commands.")
32 (fset 'mule-prefix mule-keymap)
33 32
34 ;; Keep "C-x C-m ..." for mule specific commands. 33 ;; Keep "C-x C-m ..." for mule specific commands.
35 (define-key ctl-x-map "\C-m" 'mule-prefix) 34 (define-key ctl-x-map "\C-m" mule-keymap)
36 35
37 (define-key mule-keymap "f" 'set-buffer-file-coding-system) 36 (define-key mule-keymap "f" 'set-buffer-file-coding-system)
38 (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs 37 (define-key mule-keymap "F" 'set-default-buffer-file-coding-system) ; XEmacs
39 (define-key mule-keymap "t" 'set-terminal-coding-system) 38 (define-key mule-keymap "t" 'set-terminal-coding-system)
40 (define-key mule-keymap "k" 'set-keyboard-coding-system) 39 (define-key mule-keymap "k" 'set-keyboard-coding-system)
41 (define-key mule-keymap "p" 'set-current-process-coding-system) 40 (define-key mule-keymap "p" 'set-buffer-process-coding-system)
42 (define-key mule-keymap "P" 'set-default-process-coding-system) ; XEmacs
43 (define-key mule-keymap "\C-\\" 'select-input-method) 41 (define-key mule-keymap "\C-\\" 'select-input-method)
44 (define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs 42 (define-key mule-keymap "c" 'universal-coding-system-argument)
43 ;;(define-key mule-keymap "c" 'list-coding-system-briefly) ; XEmacs
45 (define-key mule-keymap "C" 'list-coding-system) ; XEmacs 44 (define-key mule-keymap "C" 'list-coding-system) ; XEmacs
46 (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs 45 (define-key mule-keymap "r" 'toggle-display-direction) ; XEmacs
47 (define-key mule-keymap "l" 'set-language-environment) 46 (define-key mule-keymap "l" 'set-language-environment)
48 47
49 (define-key help-map "\C-L" 'describe-language-support) 48 (define-key help-map "\C-L" 'describe-language-support)
50 (define-key help-map "L" 'describe-language-environment) 49 (define-key help-map "L" 'describe-language-environment)
51 (define-key help-map "\C-\\" 'describe-input-method) 50 (define-key help-map "\C-\\" 'describe-input-method)
52 (define-key help-map "I" 'describe-input-method) 51 (define-key help-map "I" 'describe-input-method)
53 (define-key help-map "C" 'describe-current-coding-system) 52 (define-key help-map "C" 'describe-coding-system)
54 (define-key help-map "h" 'view-hello-file) 53 (define-key help-map "h" 'view-hello-file)
55 54
56 ;; Menu for XEmacs were moved to x11/x-menubar.el. 55 ;; Menu for XEmacs were moved to x11/x-menubar.el.
57 56
58 57
69 (interactive) 68 (interactive)
70 ;; We have to decode the file in any environment. 69 ;; We have to decode the file in any environment.
71 (let ((coding-system-for-read 'iso-2022-7)) 70 (let ((coding-system-for-read 'iso-2022-7))
72 (find-file-read-only (expand-file-name "HELLO" data-directory)))) 71 (find-file-read-only (expand-file-name "HELLO" data-directory))))
73 72
73 (defun universal-coding-system-argument ()
74 "Execute an I/O command using the specified coding system."
75 (interactive)
76 (let* ((coding-system
77 (read-coding-system "Coding system for following command: "))
78 (keyseq (read-key-sequence
79 (format "Command to execute with %s:" coding-system)))
80 (cmd (key-binding keyseq)))
81 (let ((coding-system-for-read coding-system)
82 (coding-system-for-write coding-system))
83 (message "")
84 (call-interactively cmd))))
85
86 (defun set-default-coding-systems (coding-system)
87 "Set default value of various coding systems to CODING-SYSTEM.
88 The follwing coding systems are set:
89 o coding system of a newly created buffer
90 o default coding system for terminal output
91 o default coding system for keyboard input
92 o default coding system for subprocess I/O"
93 (check-coding-system coding-system)
94 ;;(setq-default buffer-file-coding-system coding-system)
95 (set-default-buffer-file-coding-system coding-system)
96 ;;(setq default-terminal-coding-system coding-system)
97 (setq terminal-coding-system coding-system)
98 ;;(setq default-keyboard-coding-system coding-system)
99 (setq keyboard-coding-system coding-system)
100 ;;(setq default-process-coding-system (cons coding-system coding-system))
101 (add-hook 'comint-exec-hook
102 (lambda ()
103 (let ((proc (get-buffer-process (current-buffer))))
104 (set-process-input-coding-system proc coding-system)
105 (set-process-output-coding-system proc coding-system)
106 )))
107 (setq file-name-coding-system coding-system)
108 )
109
110 (defun prefer-coding-system (coding-system)
111 "Add CODING-SYSTEM at the front of the priority list for automatic detection.
112 This also sets the following coding systems to CODING-SYSTEM:
113 o coding system of a newly created buffer
114 o default coding system for terminal output
115 o default coding system for keyboard input
116 o default coding system for subprocess I/O"
117 (interactive "zPrefer coding system: ")
118 (if (not (and coding-system (coding-system-p coding-system)))
119 (error "Invalid coding system `%s'" coding-system))
120 (let ((coding-category (coding-system-category coding-system))
121 (parent (coding-system-parent coding-system)))
122 (if (not coding-category)
123 ;; CODING-SYSTEM is no-conversion or undecided.
124 (error "Can't prefer the coding system `%s'" coding-system))
125 (set coding-category (or parent coding-system))
126 (if (not (eq coding-category (car coding-category-list)))
127 ;; We must change the order.
128 (setq coding-category-list
129 (cons coding-category
130 (delq coding-category coding-category-list))))
131 (if (and parent (interactive-p))
132 (message "Highest priority is set to %s (parent of %s)"
133 parent coding-system))
134 (set-default-coding-systems (or parent coding-system))))
135
74 136
75 ;;; Language support staffs. 137 ;;; Language support staffs.
76
77 (defvar primary-language "English"
78 "Name of a user's primary language.
79 Emacs provide various language supports based on this variable.")
80 138
81 (defvar language-info-alist nil 139 (defvar language-info-alist nil
82 "Alist of language names vs the corresponding information of various kind. 140 "Alist of language names vs the corresponding information of various kind.
83 Each element looks like: 141 Each element looks like:
84 (LANGUAGE-NAME . ((KEY . INFO) ...)) 142 (LANGUAGE-NAME . ((KEY . INFO) ...))
139 (progn 197 (progn
140 (setq key-slot (list key)) 198 (setq key-slot (list key))
141 (setcdr lang-slot (cons key-slot (cdr lang-slot))))) 199 (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
142 ;; Setup menu. 200 ;; Setup menu.
143 (cond ((eq key 'documentation) 201 (cond ((eq key 'documentation)
144 ;; (define-key-after mule-describe-language-support-map 202 ;; (define-key-after
203 ;; (if (consp info)
204 ;; (prog1 (symbol-value (cdr info))
205 ;; (setq info (car info)))
206 ;; describe-language-environment-map)
145 ;; (vector (intern language-name)) 207 ;; (vector (intern language-name))
146 ;; (cons language-name info) 208 ;; (cons language-name 'describe-specified-language-support)
147 ;; t) 209 ;; t)
210 (if (consp info)
211 (setq info (car info)))
148 (eval-after-load "x-menubar" 212 (eval-after-load "x-menubar"
149 `(add-menu-button '("Mule" "Describe Language Support") 213 `(add-menu-button
150 (vector ,language-name ',info t))) 214 '("Mule" "Describe Language Support")
215 (vector ,language-name
216 '(describe-language-environment ,language-name)
217 t)))
151 ) 218 )
152 ((eq key 'setup-function) 219 ((eq key 'setup-function)
153 ;; (define-key-after mule-set-language-environment-map 220 ;; (define-key-after
221 ;; (if (consp info)
222 ;; (prog1 (symbol-value (cdr info))
223 ;; (setq info (car info)))
224 ;; setup-language-environment-map)
154 ;; (vector (intern language-name)) 225 ;; (vector (intern language-name))
155 ;; (cons language-name info) 226 ;; (cons language-name 'setup-specified-language-environment)
156 ;; t) 227 ;; t)
228 (if (consp info)
229 (setq info (car info)))
157 (eval-after-load "x-menubar" 230 (eval-after-load "x-menubar"
158 `(add-menu-button '("Mule" "Set Language Environment") 231 `(add-menu-button
159 (vector ,language-name ',info t))) 232 '("Mule" "Set Language Environment")
233 (vector ,language-name
234 '(set-language-environment ,language-name)
235 t)))
160 )) 236 ))
237
238 (setcdr key-slot info)
161 )) 239 ))
162 240
163 (defun set-language-info-alist (language-name alist) 241 (defun set-language-info-alist (language-name alist)
164 "Set for LANGUAGE-NAME the information in ALIST. 242 "Set for LANGUAGE-NAME the information in ALIST.
165 ALIST is an alist of KEY and INFO. See the documentation of 243 ALIST is an alist of KEY and INFO. See the documentation of
176 This returns a language name as a string." 254 This returns a language name as a string."
177 (let* ((completion-ignore-case t) 255 (let* ((completion-ignore-case t)
178 (name (completing-read prompt 256 (name (completing-read prompt
179 language-info-alist 257 language-info-alist
180 (function (lambda (elm) (assq key elm))) 258 (function (lambda (elm) (assq key elm)))
181 t nil nil default))) 259 t nil default)))
182 (if (and (> (length name) 0) 260 (if (and (> (length name) 0)
183 (get-language-info name key)) 261 (get-language-info name key))
184 name))) 262 name)))
185 263
186 ;;; Multilingual input methods. 264 ;;; Multilingual input methods.
309 nil t nil 'input-method-history) 387 nil t nil 'input-method-history)
310 ;;default) 388 ;;default)
311 )) 389 ))
312 (if (> (length input-method) 0) 390 (if (> (length input-method) 0)
313 input-method 391 input-method
314 ;; If we have a default, use it, otherwise check inhibit-null 392 (if inhibit-null
315 (if default 393 (error "No valid input method is specified")))))
316 default
317 (if inhibit-null
318 (error "No valid input method is specified"))))))
319 394
320 (defun activate-input-method (input-method) 395 (defun activate-input-method (input-method)
321 "Turn INPUT-METHOD on. 396 "Turn INPUT-METHOD on.
322 If some input method is already on, turn it off at first." 397 If some input method is already on, turn it off at first."
323 (if (symbolp input-method) 398 (if (symbolp input-method)
371 else turn on an input method selected last time 446 else turn on an input method selected last time
372 or the default input method (see `default-input-method'). 447 or the default input method (see `default-input-method').
373 448
374 When there's no input method to turn on, turn on what read from minibuffer." 449 When there's no input method to turn on, turn on what read from minibuffer."
375 (interactive "P") 450 (interactive "P")
376 (if (eq arg 1)
377 (setq arg nil))
378 (let* ((default (or (car input-method-history) default-input-method))) 451 (let* ((default (or (car input-method-history) default-input-method)))
379 (if (and current-input-method (not arg)) 452 (if (and current-input-method (not arg))
380 (inactivate-input-method) 453 (inactivate-input-method)
381 (activate-input-method 454 (activate-input-method
382 (if (or arg (not default)) 455 (if (or arg (not default))
426 default-input-method 499 default-input-method
427 (read-input-method-name "Input method: " nil t))) 500 (read-input-method-name "Input method: " nil t)))
428 (if (and input-method (symbolp input-method)) 501 (if (and input-method (symbolp input-method))
429 (setq input-method (symbol-name input-method))) 502 (setq input-method (symbol-name input-method)))
430 (let ((current-input-method input-method)) 503 (let ((current-input-method input-method))
431 (read-string prompt initial-input nil nil t))) 504 ;; FSFmacs
505 ;; (read-string prompt initial-input nil nil t)))
506 (read-string prompt initial-input nil)))
432 507
433 ;; Variables to control behavior of input methods. All input methods 508 ;; Variables to control behavior of input methods. All input methods
434 ;; should react to these variables. 509 ;; should react to these variables.
435 510
436 (defcustom input-method-verbose-flag t 511 (defcustom input-method-verbose-flag t
477 input method temporalily. After the key is handled, the input method is 552 input method temporalily. After the key is handled, the input method is
478 back on. 553 back on.
479 But, if this flag is non-nil, the input method is never back on.") 554 But, if this flag is non-nil, the input method is never back on.")
480 555
481 556
482 ;;; Language specific setup functions. 557 (defun setup-specified-language-environment ()
483 ;; (defun set-language-environment (language-name) 558 "Set up multi-lingual environment convenient for the specified language."
484 ;; "Setup a user's environment for LANGUAGE-NAME. 559 (interactive)
485 ;; 560 (let (language-name)
486 ;; To setup, a fucntion returned by: 561 (if (and (symbolp last-command-event)
487 ;; (get-language-info LANGUAGE-NAME 'setup-function) 562 (or (not (eq last-command-event 'Default))
488 ;; is called." 563 (setq last-command-event 'English))
489 ;; (interactive (list (read-language-name 'setup-function "Language: "))) 564 (setq language-name (symbol-name last-command-event)))
490 ;; (let (func) 565 (set-language-environment language-name)
491 ;; (if (or (null language-name) 566 (error "Bogus calling sequence"))))
492 ;; (null (setq func 567
493 ;; (get-language-info language-name 'setup-function)))) 568 (defvar current-language-environment "English"
494 ;; (error "No way to setup environment for the specified language")) 569 "The last language environment specified with `set-language-environment'.")
495 ;; (funcall func))) 570
571 (defun set-language-environment (language-name)
572 "Set up multi-lingual environment for using LANGUAGE-NAME.
573 This sets the coding system priority and the default input method
574 and sometimes other things."
575 (interactive (list (read-language-name 'setup-function
576 "Set language environment: ")))
577 (if language-name
578 (if (symbolp language-name)
579 (setq language-name (symbol-name language-name)))
580 (setq language-name "English"))
581 (if (null (get-language-info language-name 'setup-function))
582 (error "Language environment not defined: %S" language-name))
583 (funcall (get-language-info language-name 'setup-function))
584 (setq current-language-environment language-name)
585 (force-mode-line-update t))
496 586
497 ;; Print all arguments with `princ', then print "\n". 587 ;; Print all arguments with `princ', then print "\n".
498 (defsubst princ-list (&rest args) 588 (defsubst princ-list (&rest args)
499 (while args (princ (car args)) (setq args (cdr args))) 589 (while args (princ (car args)) (setq args (cdr args)))
500 (princ "\n")) 590 (princ "\n"))
501 591
502 (defun describe-language-support (language-name) 592 ;; Print a language specific information such as input methods,
503 "Describe how Emacs supports LANGUAGE-NAME.
504
505 For that, a function returned by:
506 (get-language-info LANGUAGE-NAME 'describe-function)
507 is called."
508 (interactive (list (read-language-name 'documentation "Language: ")))
509 (let (func)
510 (if (or (null language-name)
511 (null (setq func
512 (get-language-info language-name 'describe-function))))
513 (error "No documentation for the specified language"))
514 (funcall func)))
515
516 ;; Print LANGUAGE-NAME specific information such as input methods,
517 ;; charsets, and coding systems. This function is intended to be 593 ;; charsets, and coding systems. This function is intended to be
518 ;; called from various describe-LANGUAGE-support functions defined in 594 ;; called from the menu:
519 ;; lisp/language/LANGUAGE.el. 595 ;; [menu-bar mule describe-language-environment LANGUAGE]
520 (defun describe-language-support-internal (language-name) 596 ;; and should not run it by `M-x describe-current-input-method-function'.
521 (with-output-to-temp-buffer "*Help*" 597 (defun describe-specified-language-support ()
522 (let ((doc (get-language-info language-name 'documentation))) 598 "Describe how Emacs supports the specified language environment."
599 (interactive)
600 (let (language-name)
601 (if (not (and (symbolp last-command-event)
602 (setq language-name (symbol-name last-command-event))))
603 (error "Bogus calling sequence"))
604 (describe-language-environment language-name)))
605
606 (defun describe-language-environment (language-name)
607 "Describe how Emacs supports language environment LANGUAGE-NAME."
608 (interactive
609 (list (read-language-name
610 'documentation
611 "Describe language environment (default, current choise): ")))
612 (if (null language-name)
613 (setq language-name current-language-environment))
614 (if (or (null language-name)
615 (null (get-language-info language-name 'documentation)))
616 (error "No documentation for the specified language"))
617 (if (symbolp language-name)
618 (setq language-name (symbol-name language-name)))
619 (let ((doc (get-language-info language-name 'documentation)))
620 (with-output-to-temp-buffer "*Help*"
523 (if (stringp doc) 621 (if (stringp doc)
524 (princ-list doc))) 622 (progn
525 (princ "-----------------------------------------------------------\n") 623 (princ-list doc)
526 (princ-list "List of items specific to " 624 (terpri)))
527 language-name 625 (let ((str (get-language-info language-name 'sample-text)))
528 " support") 626 (if (stringp str)
529 (princ "-----------------------------------------------------------\n") 627 (progn
530 (let ((str (get-language-info language-name 'sample-text))) 628 (princ "Sample text:\n")
531 (if (stringp str) 629 (princ-list " " str)
532 (progn 630 (terpri))))
533 (princ "<sample text>\n") 631 (princ "Input methods:\n")
534 (princ-list " " str)))) 632 (let ((l input-method-alist))
535 (princ "<input methods>\n") 633 (while l
536 (let ((l (get-language-info language-name 'input-method))) 634 (if (string= language-name (nth 1 (car l)))
537 (while l 635 (princ-list " " (car (car l))
538 (princ-list " " (car (car l))) 636 (format " (`%s' in mode line)" (nth 3 (car l)))))
539 (setq l (cdr l)))) 637 (setq l (cdr l))))
540 (princ "<character sets>\n") 638 (terpri)
541 (let ((l (get-language-info language-name 'charset))) 639 (princ "Character sets:\n")
542 (if (null l) 640 (let ((l (get-language-info language-name 'charset)))
543 (princ-list " nothing specific to " language-name) 641 (if (null l)
544 (while l 642 (princ-list " nothing specific to " language-name)
545 (princ-list " " (car l) ": " 643 (while l
546 (charset-description (car l))) 644 (princ-list " " (car l) ": "
547 (setq l (cdr l))))) 645 (charset-description (car l)))
548 (princ "<coding systems>\n") 646 (setq l (cdr l)))))
549 (let ((l (get-language-info language-name 'coding-system))) 647 (terpri)
550 (if (null l) 648 (princ "Coding systems:\n")
551 (princ-list " nothing specific to " language-name) 649 (let ((l (get-language-info language-name 'coding-system)))
552 (while l 650 (if (null l)
553 (princ-list " " (car l) ":\n\t" 651 (princ-list " nothing specific to " language-name)
554 (coding-system-docstring (car l))) 652 (while l
555 (setq l (cdr l))))))) 653 (princ ; (format " %s (`%c' in mode line):\n\t%s\n"
654 ;; In XEmacs, `coding-system-mnemonic' returns string.
655 (format " %s (`%s' in mode line):\n\t%s\n"
656 (car l)
657 (coding-system-mnemonic (car l))
658 (coding-system-doc-string (car l))))
659 (setq l (cdr l))))))))
556 660
557 ;;; Charset property 661 ;;; Charset property
558 662
559 ;; (defsubst get-charset-property (charset propname) 663 ;; (defsubst get-charset-property (charset propname)
560 ;; "Return the value of CHARSET's PROPNAME property. 664 ;; "Return the value of CHARSET's PROPNAME property.
566 ;; "Store CHARSETS's PROPNAME property with value VALUE. 670 ;; "Store CHARSETS's PROPNAME property with value VALUE.
567 ;; It can be retrieved with `(get-charset-property CHARSET PROPNAME)'." 671 ;; It can be retrieved with `(get-charset-property CHARSET PROPNAME)'."
568 ;; (set-charset-plist charset 672 ;; (set-charset-plist charset
569 ;; (plist-put (charset-plist charset) propname value))) 673 ;; (plist-put (charset-plist charset) propname value)))
570 674
571 ;;; Character code property 675 (defvar char-code-property-table
572 ;; (put 'char-code-property-table 'char-table-extra-slots 0) 676 (make-char-table 'generic)
573 677 "Char-table containing a property list of each character code.
574 ;; (defvar char-code-property-table
575 ;; (make-char-table 'char-code-property-table)
576 ;; "Char-table containing a property list of each character code.
577 ;; 678 ;;
578 ;; See also the documentation of `get-char-code-property' and 679 See also the documentation of `get-char-code-property' and
579 ;; `put-char-code-property'") 680 `put-char-code-property'")
580
581 ;; (defun get-char-code-property (char propname)
582 ;; "Return the value of CHAR's PROPNAME property in `char-code-property-table'."
583 ;; (let ((plist (aref char-code-property-table char))) 681 ;; (let ((plist (aref char-code-property-table char)))
584 ;; (if (listp plist) 682 (defun get-char-code-property (char propname)
585 ;; (car (cdr (memq propname plist)))))) 683 "Return the value of CHAR's PROPNAME property in `char-code-property-table'."
586 684 (let ((plist (get-char-table char char-code-property-table)))
587 ;; (defun put-char-code-property (char propname value) 685 (if (listp plist)
588 ;; "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'. 686 (car (cdr (memq propname plist))))))
589 ;; It can be retrieved with `(get-char-code-property CHAR PROPNAME)'." 687
590 ;; (let ((plist (aref char-code-property-table char))) 688 (defun put-char-code-property (char propname value)
591 ;; (if plist 689 "Store CHAR's PROPNAME property with VALUE in `char-code-property-table'.
592 ;; (let ((slot (memq propname plist))) 690 It can be retrieved with `(get-char-code-property CHAR PROPNAME)'."
593 ;; (if slot 691 (let ((plist (get-char-table char char-code-property-table)))
692 (if plist
693 (let ((slot (memq propname plist)))
694 (if slot
695 (setcar (cdr slot) value)
696 (nconc plist (list propname value))))
697 (put-char-table char (list propname value) char-code-property-table)
698 )))
594 ;; (setcar (cdr slot) value) 699 ;; (setcar (cdr slot) value)
595 ;; (nconc plist (list propname value)))) 700 ;; (nconc plist (list propname value))))
596 ;; (aset char-code-property-table char (list propname value))))) 701 ;; (aset char-code-property-table char (list propname value)))))
597 702
598 ;;; mule-cmds.el ends here 703 ;;; mule-cmds.el ends here