1 ;;; mule-diag.el --- Show diagnosis of multilingual environment (Mule)
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation.
6 ;; Keywords: multilingual, charset, coding system, fontset, diagnosis
8 ;; This file is part of GNU Emacs.
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)
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.
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.
25 ;;; General utility function
27 ;; Print all arguments with single space separator in one line.
28 (defun print-list (&rest args
)
33 (setq args
(cdr args
)))
37 ;; Re-order the elements of charset-list.
38 (defun sort-charset-list ()
41 (function (lambda (x y
) (< (charset-id x
) (charset-id y
)))))))
46 (defun list-character-sets (&optional arg
)
47 "Display a list of all character sets.
49 The ID column contains a charset identification number for internal Emacs use.
50 The B column contains a number of bytes occupied in a buffer
51 by any character in this character set.
52 The W column contains a number of columns occupied on the screen
53 by any character in this character set.
55 With prefix arg, the output format gets more cryptic,
56 but still shows the full information."
59 (with-output-to-temp-buffer "*Help*"
61 (set-buffer standard-output
)
62 (list-character-sets-1 arg
)
64 (setq truncate-lines t
))))
66 (defun list-character-sets-1 (arg)
67 (let ((l charset-list
)
71 (insert "ID Name B W Description\n")
72 (insert "-- ---- - - -----------\n")
74 (setq charset
(car l
) l
(cdr l
))
75 (insert (format "%03d %s" (charset-id charset
) charset
))
77 (insert (format "%d %d %s\n"
78 (charset-bytes charset
)
79 (charset-width charset
)
80 (charset-description charset
)))))
82 #########################
84 ## Each line corresponds to one charset.
85 ## The following attributes are listed in this order
86 ## separated by a colon `:' in one line.
88 ## CHARSET-SYMBOL-NAME,
91 ## BYTES (of multibyte form: 1, 2, 3, or 4),
92 ## WIDTH (occupied column numbers: 1 or 2),
93 ## DIRECTION (0:left-to-right, 1:right-to-left),
94 ## ISO-FINAL-CHAR (character code of ISO-2022's final character)
95 ## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
96 ## DESCRIPTION (describing string of the charset)
99 (setq charset
(car l
) l
(cdr l
))
100 (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
103 (charset-dimension charset
)
104 (charset-chars charset
)
105 (charset-bytes charset
)
106 (charset-width charset
)
107 (charset-direction charset
)
108 (charset-iso-final-char charset
)
109 (charset-iso-graphic-plane charset
)
110 (charset-description charset
)))))))
114 ;; Print information of designation of each graphic register in FLAGS
115 ;; in human readable format. See the documentation of
116 ;; `make-coding-system' for the meaning of FLAGS.
117 (defun print-designation (flags)
118 (let ((graphic-register 0)
120 (while (< graphic-register
4)
121 (setq charset
(aref flags graphic-register
))
125 (cond ((null charset
)
128 "no initial designation, and used by any charsets")
131 charset
(charset-description charset
)))
133 (if (charsetp (car charset
))
134 (format "%s:%s, and also used by the followings:"
136 (charset-description (car charset
)))
137 "no initial designation, and used by the followings:"))
139 "invalid designation information"))))
140 (when (listp charset
)
141 (setq charset
(cdr charset
))
143 (cond ((eq (car charset
) t
)
144 (princ "\tany other charsets\n"))
145 ((charsetp (car charset
))
146 (princ (format "\t%s:%s\n"
148 (charset-description (car charset
)))))
150 "invalid designation information"))
151 (setq charset
(cdr charset
))))
152 (setq graphic-register
(1+ graphic-register
)))))
155 (defun describe-coding-system (coding-system)
156 "Display information about CODING-SYSTEM."
157 (interactive "zDescribe coding system (default, current choices): ")
158 (if (null coding-system
)
159 (describe-current-coding-system)
160 (with-output-to-temp-buffer "*Help*"
161 (print-coding-system-briefly coding-system
'doc-string
)
162 (let ((coding-spec (coding-system-spec coding-system
)))
164 (let ((type (coding-system-type coding-system
))
165 (flags (coding-system-flags coding-system
)))
168 (princ " (do no conversion)"))
170 (princ " (do automatic conversion)"))
172 (princ " (Emacs internal multibyte form)"))
174 (princ " (Shift-JIS, MS-KANJI)"))
176 (princ " (variant of ISO-2022)\n")
177 (princ "Initial designations:\n")
178 (print-designation flags
)
179 (princ "Other Form: \n ")
180 (princ (if (aref flags
4) "short-form" "long-form"))
181 (if (aref flags
5) (princ ", ASCII@EOL"))
182 (if (aref flags
6) (princ ", ASCII@CNTL"))
183 (princ (if (aref flags
7) ", 7-bit" ", 8-bit"))
184 (if (aref flags
8) (princ ", use-locking-shift"))
185 (if (aref flags
9) (princ ", use-single-shift"))
186 (if (aref flags
10) (princ ", use-roman"))
187 (if (aref flags
11) (princ ", use-old-jis"))
188 (if (aref flags
12) (princ ", no-ISO6429"))
189 (if (aref flags
13) (princ ", init-bol"))
190 (if (aref flags
14) (princ ", designation-bol"))
191 (if (aref flags
15) (princ ", convert-unsafe"))
192 (if (aref flags
16) (princ ", accept-latin-extra-code"))
197 (princ " (do conversion by CCL program)"))
199 (princ " (text with random binary characters)"))
200 (t (princ ": invalid coding-system."))))
201 (princ "\nEOL type: ")
202 (let ((eol-type (coding-system-eol-type coding-system
)))
203 (cond ((vectorp eol-type
)
204 (princ "Automatic selection from:\n\t")
207 ((or (null eol-type
) (eq eol-type
0)) (princ "LF\n"))
208 ((eq eol-type
1) (princ "CRLF\n"))
209 ((eq eol-type
2) (princ "CR\n"))
210 (t (princ "invalid\n")))))
211 (let ((postread (coding-system-get coding-system
'post-read-conversion
)))
213 (princ "After decoding a text normally,")
214 (princ " perform post-conversion by the function: ")
218 (let ((prewrite (coding-system-get coding-system
'pre-write-conversion
)))
220 (princ "Before encoding a text normally,")
221 (princ " perform pre-conversion by the function: ")
225 (let ((charsets (coding-system-get coding-system
'safe-charsets
)))
228 (princ "This coding system can encode all charsets.\n")
229 (princ "This coding system encode the following charsets:\n")
233 (princ (car charsets
))
234 (setq charsets
(cdr charsets
))))))
236 (set-buffer standard-output
)
240 (defun describe-current-coding-system-briefly ()
241 "Display coding systems currently used in a brief format in echo area.
243 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
244 where mnemonics of the following coding systems come in this order
245 at the place of `..':
246 `buffer-file-coding-system` (of the current buffer)
247 eol-type of buffer-file-coding-system (of the current buffer)
248 Value returned by `keyboard-coding-system'
249 eol-type of (keyboard-coding-system)
250 Value returned by `terminal-coding-system.
251 eol-type of (terminal-coding-system)
252 `process-coding-system' for read (of the current buffer, if any)
253 eol-type of process-coding-system for read (of the current buffer, if any)
254 `process-coding-system' for write (of the current buffer, if any)
255 eol-type of process-coding-system for write (of the current buffer, if any)
256 `default-buffer-file-coding-system'
257 eol-type of default-buffer-file-coding-system
258 `default-process-coding-system' for read
259 eol-type of default-process-coding-system for read
260 `default-process-coding-system' for write
261 eol-type of default-process-coding-system"
263 (let* ((proc (get-buffer-process (current-buffer)))
264 (process-coding-systems (if proc
(process-coding-system proc
))))
266 "F[%c%s],K[%c%s],T[%c%s],P>[%c%s],P<[%c%s], default F[%c%s],P>[%c%s],P<[%c%s]"
267 (coding-system-mnemonic buffer-file-coding-system
)
268 (coding-system-eol-type-mnemonic buffer-file-coding-system
)
269 (coding-system-mnemonic (keyboard-coding-system))
270 (coding-system-eol-type-mnemonic (keyboard-coding-system))
271 (coding-system-mnemonic (terminal-coding-system))
272 (coding-system-eol-type-mnemonic (terminal-coding-system))
273 (coding-system-mnemonic (car process-coding-systems
))
274 (coding-system-eol-type-mnemonic (car process-coding-systems
))
275 (coding-system-mnemonic (cdr process-coding-systems
))
276 (coding-system-eol-type-mnemonic (cdr process-coding-systems
))
277 (coding-system-mnemonic default-buffer-file-coding-system
)
278 (coding-system-eol-type-mnemonic default-buffer-file-coding-system
)
279 (coding-system-mnemonic (car default-process-coding-system
))
280 (coding-system-eol-type-mnemonic (car default-process-coding-system
))
281 (coding-system-mnemonic (cdr default-process-coding-system
))
282 (coding-system-eol-type-mnemonic (cdr default-process-coding-system
))
285 ;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
286 (defun print-coding-system-briefly (coding-system &optional doc-string
)
287 (if (not coding-system
)
289 (princ (format "%c -- %s"
290 (coding-system-mnemonic coding-system
)
292 (let ((aliases (coding-system-get coding-system
'alias-coding-systems
)))
293 (if (eq coding-system
(car aliases
))
295 (princ (format " %S" (cons 'alias
: (cdr aliases
)))))
296 (if (memq coding-system aliases
)
297 (princ (format " (alias of %s)" (car aliases
))))))
300 (setq doc-string
(coding-system-doc-string coding-system
)))
301 (princ (format " %s\n" doc-string
)))))
304 (defun describe-current-coding-system ()
305 "Display coding systems currently used, in detail."
307 (with-output-to-temp-buffer "*Help*"
308 (let* ((proc (get-buffer-process (current-buffer)))
309 (process-coding-systems (if proc
(process-coding-system proc
))))
310 (princ "Coding system for saving this buffer:\n ")
311 (if (local-variable-p 'buffer-file-coding-system
)
312 (print-coding-system-briefly buffer-file-coding-system
)
313 (princ "Not set locally, use the default.\n"))
314 (princ "Default coding system (for new files):\n ")
315 (print-coding-system-briefly default-buffer-file-coding-system
)
316 (princ "Coding system for keyboard input:\n ")
317 (print-coding-system-briefly (keyboard-coding-system))
318 (princ "Coding system for terminal output:\n ")
319 (print-coding-system-briefly (terminal-coding-system))
320 (when (get-buffer-process (current-buffer))
321 (princ "Coding systems for process I/O:\n")
322 (princ " encoding input to the process: ")
323 (print-coding-system-briefly (cdr process-coding-systems
))
324 (princ " decoding output from the process: ")
325 (print-coding-system-briefly (car process-coding-systems
)))
326 (princ "Defaults for subprocess I/O:\n")
327 (princ " decoding: ")
328 (print-coding-system-briefly (car default-process-coding-system
))
329 (princ " encoding: ")
330 (print-coding-system-briefly (cdr default-process-coding-system
)))
333 (set-buffer standard-output
)
335 (princ "\nPriority order for recognizing coding systems when reading files:\n")
336 (let ((l coding-category-list
)
341 (setq coding
(symbol-value (car l
)))
342 ;; Do not list up the same coding system twice.
343 (when (and coding
(not (memq coding coding-list
)))
344 (setq coding-list
(cons coding coding-list
))
345 (princ (format " %d. %s " i coding
))
346 (setq aliases
(coding-system-get coding
'alias-coding-systems
))
347 (if (eq coding
(car aliases
))
349 (princ (cons 'alias
: (cdr aliases
))))
350 (if (memq coding aliases
)
351 (princ (list 'alias
'of
(car aliases
)))))
356 (princ "\n Other coding systems cannot be distinguished automatically
357 from these, and therefore cannot be recognized automatically
358 with the present coding system priorities.\n\n")
360 (let ((categories '(coding-category-iso-7 coding-category-iso-7-else
))
361 coding-system codings
)
363 (setq coding-system
(symbol-value (car categories
)))
367 (if (and (not (eq x coding-system
))
368 (coding-system-get x
'no-initial-designation
)
369 (let ((flags (coding-system-flags x
)))
370 (not (or (aref flags
10) (aref flags
11)))))
371 (setq codings
(cons x codings
)))))
372 (get (car categories
) 'coding-systems
))
374 (let ((max-col (frame-width))
376 (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system
))
379 (insert (format " %s" (car codings
)))
380 (when (> (current-column) max-col
)
383 (goto-char (point-max)))
384 (setq codings
(cdr codings
)))
386 (setq categories
(cdr categories
))))
388 (princ "Particular coding systems specified for certain file names:\n")
390 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
391 (princ " ---------\t--------------\t\t----------------\n")
392 (let ((func (lambda (operation alist
)
396 (princ "\tnothing specified\n")
399 (prin1 (car (car alist
)))
400 (if (>= (current-column) 40)
403 (princ (cdr (car alist
)))
405 (setq alist
(cdr alist
)))))))
406 (funcall func
"File I/O" file-coding-system-alist
)
407 (funcall func
"Process I/O" process-coding-system-alist
)
408 (funcall func
"Network I/O" network-coding-system-alist
))
411 ;; Print detailed information on CODING-SYSTEM.
412 (defun print-coding-system (coding-system)
413 (let ((type (coding-system-type coding-system
))
414 (eol-type (coding-system-eol-type coding-system
))
415 (flags (coding-system-flags coding-system
))
416 (aliases (coding-system-get coding-system
'alias-coding-systems
)))
417 (if (not (eq (car aliases
) coding-system
))
418 (princ (format "%s (alias of %s)\n" coding-system
(car aliases
)))
419 (princ coding-system
)
420 (setq aliases
(cdr aliases
))
423 (princ (car aliases
))
424 (setq aliases
(cdr aliases
)))
425 (princ (format ":%s:%c:%d:"
427 (coding-system-mnemonic coding-system
)
428 (if (integerp eol-type
) eol-type
3)))
429 (cond ((eq type
2) ; ISO-2022
433 (setq charset
(aref flags idx
))
434 (cond ((null charset
)
442 (princ (car charset
))
443 (setq charset
(cdr charset
))
446 (princ (car charset
))
447 (setq charset
(cdr charset
)))
452 (princ (if (aref flags idx
) 1 0))
455 (princ (if (aref flags idx
) 1 0))))
458 (if (symbolp (car flags
))
459 (princ (format " %s" (car flags
)))
460 (setq i
0 len
(length (car flags
)))
462 (princ (format " %x" (aref (car flags
) i
)))
465 (if (symbolp (cdr flags
))
466 (princ (format "%s" (cdr flags
)))
467 (setq i
0 len
(length (cdr flags
)))
469 (princ (format " %x" (aref (cdr flags
) i
)))
473 (princ (coding-system-doc-string coding-system
))
477 (defun list-coding-systems (&optional arg
)
478 "Display a list of all coding systems.
479 This shows the mnemonic letter, name, and description of each coding system.
481 With prefix arg, the output format gets more cryptic,
482 but still contains full information about each coding system."
484 (with-output-to-temp-buffer "*Help*"
485 (list-coding-systems-1 arg
)))
487 (defun list-coding-systems-1 (arg)
490 ###############################################
491 # List of coding systems in the following format:
492 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
496 #########################
497 ## LIST OF CODING SYSTEMS
498 ## Each line corresponds to one coding system
499 ## Format of a line is:
500 ## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
501 ## :PRE-WRITE-CONVERSION:DOC-STRING,
503 ## NAME = coding system name
504 ## ALIAS = alias of the coding system
505 ## TYPE = nil (no conversion), t (undecided or automatic detection),
506 ## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
507 ## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
510 ## comma (`,') separated data of the followings:
511 ## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
512 ## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
513 ## else if TYPE = 4 then
514 ## comma (`,') separated CCL programs for read and write
517 ## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
520 (let ((bases (coding-system-list 'base-only
))
523 (setq coding-system
(car bases
))
525 (print-coding-system-briefly coding-system
'doc-string
)
526 (print-coding-system coding-system
))
527 (setq bases
(cdr bases
)))))
530 (defun list-coding-categories ()
531 "Display a list of all coding categories."
532 (with-output-to-temp-buffer "*Help*"
534 ############################
535 ## LIST OF CODING CATEGORIES (ordered by priority)
536 ## CATEGORY:CODING-SYSTEM
539 (let ((l coding-category-list
))
541 (princ (format "%s:%s\n" (car l
) (symbol-value (car l
))))
546 ;; Print information of a font in FONTINFO.
547 (defun describe-font-internal (font-info &optional verbose
)
548 (print-list "name (opened by):" (aref font-info
0))
549 (print-list " full name:" (aref font-info
1))
550 (let ((charset (aref font-info
2)))
551 (print-list " charset:"
552 (format "%s (%s)" charset
(charset-description charset
))))
553 (print-list " size:" (format "%d" (aref font-info
3)))
554 (print-list " height:" (format "%d" (aref font-info
4)))
555 (print-list " baseline-offset:" (format "%d" (aref font-info
5)))
556 (print-list "relative-compose:" (format "%d" (aref font-info
6))))
559 (defun describe-font (fontname)
560 "Display information about fonts which partially match FONTNAME."
561 (interactive "sFontname (default, current choice for ASCII chars): ")
562 (or (and window-system
(boundp 'global-fontset-alist
))
563 (error "No fontsets being used"))
564 (when (or (not fontname
) (= (length fontname
) 0))
565 (setq fontname
(cdr (assq 'font
(frame-parameters))))
566 (if (query-fontset fontname
)
568 (nth 2 (assq 'ascii
(aref (fontset-info fontname
) 2))))))
569 (let ((font-info (font-info fontname
)))
571 (message "No matching font")
572 (with-output-to-temp-buffer "*Help*"
573 (describe-font-internal font-info
'verbose
)))))
575 ;; Print information of FONTSET. If optional arg PRINT-FONTS is
576 ;; non-nil, print also names of all fonts in FONTSET. This function
577 ;; actually INSERT such information in the current buffer.
578 (defun print-fontset (fontset &optional print-fonts
)
579 (let* ((fontset-info (fontset-info fontset
))
580 (size (aref fontset-info
0))
581 (height (aref fontset-info
1))
582 (fonts (and print-fonts
(aref fontset-info
2)))
583 (xlfd-fields (x-decompose-font-name fontset
))
586 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum
))
587 (slant (aref xlfd-fields xlfd-regexp-slant-subnum
)))
588 (if (string-match "^bold$\\|^demibold$" weight
)
589 (setq style
(concat weight
" "))
590 (setq style
"medium "))
591 (cond ((string-match "^i$" slant
)
592 (setq style
(concat style
"italic")))
593 ((string-match "^o$" slant
)
594 (setq style
(concat style
"slant")))
595 ((string-match "^ri$" slant
)
596 (setq style
(concat style
"reverse italic")))
597 ((string-match "^ro$" slant
)
598 (setq style
(concat style
"reverse slant")))))
603 (insert (if (> size
0) (format "%2dx%d" size height
) " -"))
607 (insert " O Charset / Fontname\n"
608 " - ------------------\n")
610 (let ((l charset-list
)
611 charset font-info opened fontname
)
613 (setq charset
(car l
) l
(cdr l
))
614 (setq font-info
(assq charset fonts
))
616 (setq opened ?? fontname
"not specified")
617 (if (nth 2 font-info
)
618 (if (stringp (nth 2 font-info
))
619 (setq opened ?o fontname
(nth 2 font-info
))
620 (setq opened ?- fontname
(nth 1 font-info
)))
621 (setq opened ?x fontname
(nth 1 font-info
))))
622 (insert (format " %c %s\n %s\n"
623 opened charset fontname
)))))))
626 (defun describe-fontset (fontset)
627 "Display information of FONTSET.
628 This shows the name, size, and style of FONTSET, and the list of fonts
629 contained in FONTSET.
631 The column WDxHT contains width and height (pixels) of each fontset
632 \(i.e. those of ASCII font in the fontset). The letter `-' in this
633 column means that the corresponding fontset is not yet used in any
636 The O column for each font contains one of the following letters:
637 o -- font already opened
638 - -- font not yet opened
639 x -- font can't be opened
640 ? -- no font specified
642 The Charset column for each font contains a name of character set
643 displayed (for this fontset) using that font."
645 (if (not (and window-system
(boundp 'global-fontset-alist
)))
646 (error "No fontsets being used")
647 (let ((fontset-list (mapcar '(lambda (x) (list x
)) (fontset-list)))
648 (completion-ignore-case t
))
649 (list (completing-read
650 "Fontset (default, used by the current frame): "
651 fontset-list nil t
)))))
652 (if (= (length fontset
) 0)
653 (setq fontset
(cdr (assq 'font
(frame-parameters)))))
654 (if (not (query-fontset fontset
))
655 (error "Current frame is using font, not fontset"))
656 (let ((fontset-info (fontset-info fontset
)))
657 (with-output-to-temp-buffer "*Help*"
659 (set-buffer standard-output
)
660 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
661 (insert "------------\t\t\t\t\t\t ----- -----\n")
662 (print-fontset fontset t
)))))
665 (defun list-fontsets (arg)
666 "Display a list of all fontsets.
667 This shows the name, size, and style of each fontset.
668 With prefix arg, it also list the fonts contained in each fontset;
669 see the function `describe-fontset' for the format of the list."
671 (if (not (and window-system
(boundp 'global-fontset-alist
)))
672 (error "No fontsets being used")
673 (with-output-to-temp-buffer "*Help*"
675 ;; This code is duplicated near the end of mule-diag.
676 (set-buffer standard-output
)
677 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
678 (insert "------------\t\t\t\t\t\t ----- -----\n")
681 (function (lambda (x y
)
682 (string< (fontset-plain-name x
)
683 (fontset-plain-name y
)))))))
685 (print-fontset (car fontsets
) arg
)
686 (setq fontsets
(cdr fontsets
))))))))
689 (defun list-input-methods ()
690 "Display information about all input methods."
692 (with-output-to-temp-buffer "*Help*"
693 (list-input-methods-1)))
695 (defun list-input-methods-1 ()
696 (if (not input-method-alist
)
699 No input method is available, perhaps because you have not yet
700 installed LEIM (Libraries of Emacs Input Method).
702 LEIM is available from the same ftp directory as Emacs. For instance,
703 if there exists an archive file `emacs-20.N.tar.gz', there should also
704 be a file `leim-20.N.tar.gz'. When you extract this file, LEIM files
705 are put under the subdirectory `emacs-20.N/leim'. When you install
706 Emacs again, you should be able to use various input methods."))
707 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
708 (princ " SHORT-DESCRIPTION\n------------------------------\n")
709 (setq input-method-alist
710 (sort input-method-alist
711 (function (lambda (x y
) (string< (nth 1 x
) (nth 1 y
))))))
712 (let ((l input-method-alist
)
715 (setq elt
(car l
) l
(cdr l
))
716 (when (not (equal language
(nth 1 elt
)))
717 (setq language
(nth 1 elt
))
720 (princ (format " %s (`%s' in mode line)\n %s\n"
722 (let ((title (nth 3 elt
)))
723 (if (and (consp title
) (stringp (car title
)))
726 (let ((description (nth 4 elt
)))
727 (string-match ".*" description
)
728 (match-string 0 description
))))))))
732 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
733 (defun insert-section (section-number title
)
734 (insert "########################################\n"
735 "# Section " (format "%d" section-number
) ". " title
"\n"
736 "########################################\n\n"))
740 "Display diagnosis of the multilingual environment (Mule).
742 This shows various information related to the current multilingual
743 environment, including lists of input methods, coding systems,
744 character sets, and fontsets (if Emacs is running under a window
745 system which uses fontsets)."
747 (with-output-to-temp-buffer "*Mule-Diagnosis*"
749 (set-buffer standard-output
)
750 (insert "###############################################\n"
751 "### Current Status of Multilingual Features ###\n"
752 "###############################################\n\n"
753 "CONTENTS: Section 1. General Information\n"
754 " Section 2. Display\n"
755 " Section 3. Input methods\n"
756 " Section 4. Coding systems\n"
757 " Section 5. Character sets\n")
758 (if (and window-system
(boundp 'global-fontset-alist
))
759 (insert " Section 6. Fontsets\n"))
762 (insert-section 1 "General Information")
763 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
765 (insert-section 2 "Display")
767 (insert "Window-system: "
768 (symbol-name window-system
)
769 (format "%s" window-system-version
))
770 (insert "Terminal: " (getenv "TERM")))
773 (if (eq window-system
'x
)
774 (let ((font (cdr (assq 'font
(frame-parameters)))))
775 (insert "The selected frame is using the "
776 (if (query-fontset font
) "fontset" "font")
778 (insert "Coding system of the terminal: "
779 (symbol-name (terminal-coding-system))))
782 (insert-section 3 "Input methods")
783 (list-input-methods-1)
785 (if default-input-method
786 (insert (format "Default input method: %s\n" default-input-method
))
787 (insert "No default input method is specified\n"))
789 (insert-section 4 "Coding systems")
790 (list-coding-systems-1 t
)
792 ############################
793 ## LIST OF CODING CATEGORIES (ordered by priority)
794 ## CATEGORY:CODING-SYSTEM
797 (let ((l coding-category-list
))
799 (princ (format "%s:%s\n" (car l
) (symbol-value (car l
))))
803 (insert-section 5 "Character sets")
804 (list-character-sets-1 t
)
807 (when (and window-system
(boundp 'global-fontset-alist
))
808 ;; This code duplicates most of list-fontsets.
809 (insert-section 6 "Fontsets")
810 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
811 (insert "------------\t\t\t\t\t\t ----- -----\n")
812 (let ((fontsets (fontset-list)))
814 (print-fontset (car fontsets
) t
)
815 (setq fontsets
(cdr fontsets
)))))
816 (print-help-return-message))))
822 (defun dump-charsets ()
823 "Dump information about all charsets into the file `CHARSETS'.
824 The file is saved in the directory `data-directory'."
825 (let ((file (expand-file-name "CHARSETS" data-directory
))
827 (or (file-writable-p file
)
828 (error "Can't write to file %s" file
))
829 (setq buf
(find-file-noselect file
))
830 (save-window-excursion
833 (setq buffer-read-only nil
)
835 (list-character-sets t
)
836 (insert-buffer-substring "*Help*")
837 (let (make-backup-files
838 coding-system-for-write
)
845 (defun dump-codings ()
846 "Dump information about all coding systems into the file `CODINGS'.
847 The file is saved in the directory `data-directory'."
848 (let ((file (expand-file-name "CODINGS" data-directory
))
850 (or (file-writable-p file
)
851 (error "Can't write to file %s" file
))
852 (setq buf
(find-file-noselect file
))
853 (save-window-excursion
856 (setq buffer-read-only nil
)
858 (list-coding-systems t
)
859 (insert-buffer-substring "*Help*")
860 (list-coding-categories)
861 (insert-buffer-substring "*Help*")
862 (let (make-backup-files
863 coding-system-for-write
)
869 ;;; mule-diag.el ends here