Mercurial > hg > xemacs-beta

comparison lisp/mule/mule-diag.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
children
comparison
equal deleted inserted replaced
206:d3e9274cbc4e 207:e45d5e7c476e
1 ;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
2
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
4 ;; Licensed to the Free Software Foundation.
5 ;; Copyright (C) 1997 MORIOKA Tomohiko
6
7 ;; Keywords: multilingual, charset, coding system, fontset, diagnosis
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 ;;; General utility function
27
28 ;; Print all arguments with single space separator in one line.
29 (defun print-list (&rest args)
30 (while (cdr args)
31 (when (car args)
32 (princ (car args))
33 (princ " "))
34 (setq args (cdr args)))
35 (princ (car args))
36 (princ "\n"))
37
38 ;; Re-order the elements of charset-list.
39 (defun sort-charset-list ()
40 (setq charset-list
41 (sort charset-list
42 (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
43
44 ;;; CHARSET
45
46 ;;;###autoload
47 (defun list-character-sets (&optional arg)
48 "Display a list of all character sets.
49
50 The ID column contains a charset identification number for internal use.
51 The B column contains a number of bytes occupied in a buffer.
52 The W column contains a number of columns occupied in a screen.
53
54 With prefix arg, the output format gets more cryptic
55 but contains full information about each character sets."
56 (interactive "P")
57 (sort-charset-list)
58 (with-output-to-temp-buffer "*Help*"
59 (save-excursion
60 (set-buffer standard-output)
61 (let ((l charset-list)
62 charset)
63 (if (null arg)
64 (progn
65 (insert "ID Name B W Description\n")
66 (insert "-- ---- - - -----------\n")
67 (while l
68 (setq charset (car l) l (cdr l))
69 (insert (format "%03d %s" (charset-id charset) charset))
70 (indent-to 28)
71 (insert (format "%d %d %s\n"
72 (charset-bytes charset)
73 (charset-width charset)
74 (charset-description charset)))))
75 (insert "\
76 #########################
77 ## LIST OF CHARSETS
78 ## Each line corresponds to one charset.
79 ## The following attributes are listed in this order
80 ## separated by a colon `:' in one line.
81 ## CHARSET-ID,
82 ## CHARSET-SYMBOL-NAME,
83 ## DIMENSION (1 or 2)
84 ## CHARS (94 or 96)
85 ## BYTES (of multibyte form: 1, 2, 3, or 4),
86 ## WIDTH (occupied column numbers: 1 or 2),
87 ## DIRECTION (0:left-to-right, 1:right-to-left),
88 ## ISO-FINAL-CHAR (character code of ISO-2022's final character)
89 ## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
90 ## DESCRIPTION (describing string of the charset)
91 ")
92 (while l
93 (setq charset (car l) l (cdr l))
94 (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
95 (charset-id charset)
96 charset
97 (charset-dimension charset)
98 (charset-chars charset)
99 (charset-bytes charset)
100 (charset-width charset)
101 (charset-direction charset)
102 (charset-iso-final-char charset)
103 (charset-iso-graphic-plane charset)
104 (charset-description charset))))))
105 (help-mode)
106 (setq truncate-lines t))))
107
108 ;;; CODING-SYSTEM
109
110 (defun describe-designation (cs register)
111 (let ((charset
112 (coding-system-property
113 cs (intern (format "charset-g%d" register))))
114 (force
115 (coding-system-property
116 cs (intern (format "force-g%d-on-output" register)))))
117 (princ
118 (format
119 " G%d: %s%s\n"
120 register
121 (cond ((null charset) "never used")
122 ((eq t charset) "none")
123 (t (charset-name charset)))
124 (if force " (explicit designation required)" "")))))
125
126 ;;;###autoload
127 (defun describe-coding-system (coding-system)
128 "Display information of CODING-SYSTEM."
129 (interactive "zDescribe coding system (default, current choices): ")
130 (if (or (null coding-system)
131 (string= (symbol-name coding-system) ""))
132 (describe-current-coding-system)
133 (with-output-to-temp-buffer "*Help*"
134 (print-coding-system-briefly coding-system 'doc-string)
135 (let ((type (coding-system-type coding-system)))
136 (princ (format "Type: %s" type))
137 (when (eq type 'iso2022)
138 (princ " (variant of ISO-2022)\n")
139 (princ "Initial designations:\n")
140 ;;(print-designation flags)
141 (describe-designation coding-system 0)
142 (describe-designation coding-system 1)
143 (describe-designation coding-system 2)
144 (describe-designation coding-system 3)
145 (princ "Other Form: \n ")
146 (princ (if (coding-system-short coding-system)
147 "short-form"
148 "long-form"))
149 (if (coding-system-no-ascii-eol coding-system)
150 (princ ", ASCII@EOL"))
151 (if (coding-system-no-ascii-cntl coding-system)
152 (princ ", ASCII@CNTL"))
153 (princ (if (coding-system-seven coding-system)
154 ", 7-bit"
155 ", 8-bit"))
156 (if (coding-system-lock-shift coding-system)
157 (princ ", use-locking-shift")
158 (princ ", use-single-shift"))
159 ;;(if (aref flags 10) (princ ", use-roman"))
160 ;;(if (aref flags 10) (princ ", use-old-jis"))
161 (if (coding-system-no-iso6429 coding-system)
162 (princ ", no-ISO6429"))
163 )
164 (princ "\nEOL type:")
165 (let ((eol-type (coding-system-eol-type coding-system)))
166 (cond ((null eol-type)
167 (princ "\n Automatic selection from\n ")
168 (princ (format "%s-unix, %s-dos or %s-mac.\n"
169 coding-system coding-system coding-system))
170 )
171 ((symbolp eol-type)
172 (princ " ")
173 (princ eol-type))
174 (t (princ "invalid\n")))))
175 (save-excursion
176 (set-buffer standard-output)
177 (help-mode)))))
178
179 ;;;###autoload
180 (defun describe-current-coding-system-briefly ()
181 "Display coding systems currently used in a brief format in echo area.
182
183 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
184 where mnemonics of the following coding systems come in this order
185 at the place of `..':
186 buffer-file-coding-system (of the current buffer)
187 eol-type of buffer-file-coding-system (of the current buffer)
188 (keyboard-coding-system)
189 eol-type of (keyboard-coding-system)
190 (terminal-coding-system)
191 eol-type of (terminal-coding-system)
192 process-coding-system for read (of the current buffer, if any)
193 eol-type of process-coding-system for read (of the current buffer, if any)
194 process-coding-system for write (of the current buffer, if any)
195 eol-type of process-coding-system for write (of the current buffer, if any)
196 default-buffer-file-coding-system
197 eol-type of default-buffer-file-coding-system
198 default-process-coding-system for read
199 eol-type of default-process-coding-system for read
200 default-process-coding-system for write
201 eol-type of default-process-coding-system"
202 (interactive)
203 (let* ((proc (get-buffer-process (current-buffer)))
204 (process-coding-systems (if proc (process-coding-system proc))))
205 (message
206 "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]"
207 (coding-system-mnemonic buffer-file-coding-system)
208 (coding-system-eol-type-mnemonic buffer-file-coding-system)
209 (coding-system-mnemonic (keyboard-coding-system))
210 (coding-system-eol-type-mnemonic (keyboard-coding-system))
211 (coding-system-mnemonic (terminal-coding-system))
212 (coding-system-eol-type-mnemonic (terminal-coding-system))
213 (coding-system-mnemonic (car process-coding-systems))
214 (coding-system-eol-type-mnemonic (car process-coding-systems))
215 (coding-system-mnemonic (cdr process-coding-systems))
216 (coding-system-eol-type-mnemonic (cdr process-coding-systems))
217 (coding-system-mnemonic default-buffer-file-coding-system)
218 (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
219 (coding-system-mnemonic (car default-process-coding-system))
220 (coding-system-eol-type-mnemonic (car default-process-coding-system))
221 (coding-system-mnemonic (cdr default-process-coding-system))
222 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
223 )))
224
225 ;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'.
226 (defun print-coding-system-briefly (coding-system &optional doc-string)
227 (if (not coding-system)
228 (princ "nil\n")
229 ;; In XEmacs, coding-system has own type.
230 (if (coding-system-p coding-system)
231 (setq coding-system (coding-system-name coding-system))
232 )
233 ;; In XEmacs, coding-system-mnemonic returns string.
234 (princ (format "%s -- %s"
235 (coding-system-mnemonic coding-system)
236 coding-system))
237 ;; Current XEmacs does not have `coding-system-parent'.
238 ;; (let ((parent (coding-system-parent coding-system)))
239 ;; (if parent
240 ;; (princ (format " (alias of %s)" parent))))
241 (let ((aliases (get coding-system 'alias-coding-systems)))
242 (if aliases
243 (princ (format " %S" (cons 'alias: aliases)))))
244 (princ "\n")
245 (if (and doc-string
246 (setq doc-string (coding-system-doc-string coding-system)))
247 (princ (format " %s\n" doc-string)))))
248
249 ;;;###autoload
250 (defun describe-current-coding-system ()
251 "Display coding systems currently used in a detailed format."
252 (interactive)
253 (with-output-to-temp-buffer "*Help*"
254 (let* ((proc (get-buffer-process (current-buffer)))
255 (process-coding-systems (if proc (process-coding-system proc))))
256 (princ "Coding system for saving this buffer:\n ")
257 ;; local-variable-p of XEmacs requires 2 arguments.
258 (if (local-variable-p 'buffer-file-coding-system (current-buffer))
259 (print-coding-system-briefly buffer-file-coding-system)
260 (princ "Not set locally, use the default.\n"))
261 (princ "Default coding system (for new files):\n ")
262 (print-coding-system-briefly default-buffer-file-coding-system)
263 (princ "Coding system for keyboard input:\n ")
264 (print-coding-system-briefly (keyboard-coding-system))
265 (princ "Coding system for terminal output:\n ")
266 (print-coding-system-briefly (terminal-coding-system))
267 (when (get-buffer-process (current-buffer))
268 (princ "Coding systems for process I/O:\n")
269 (princ " encoding input to the process: ")
270 (print-coding-system-briefly (cdr process-coding-systems))
271 (princ " decoding output from the process: ")
272 (print-coding-system-briefly (car process-coding-systems)))
273 ;;(princ "Defaults for subprocess I/O:\n")
274 ;;(princ " decoding: ")
275 ;;(print-coding-system-briefly (car default-process-coding-system))
276 ;;(princ " encoding: ")
277 ;;(print-coding-system-briefly (cdr default-process-coding-system))
278 )
279 (save-excursion
280 (set-buffer standard-output)
281
282 (princ
283 "\nPriority order for recognizing coding systems when reading files:\n")
284 (let ((l (coding-category-list)) ; It is function in XEmacs.
285 (i 1)
286 (coding-list nil)
287 coding aliases)
288 (while l
289 (setq coding (coding-category-system (car l))) ; for XEmacs
290 (when (not (memq coding coding-list))
291 (setq coding-list (cons coding coding-list))
292 (princ (format " %d. %s" i coding))
293 (when (setq aliases (get coding 'alias-coding-systems))
294 (princ " ")
295 (princ (cons 'alias: aliases)))
296 (terpri)
297 (setq i (1+ i)))
298 (setq l (cdr l))))
299 (princ "\n Other coding systems cannot be distinguished automatically
300 from these, and therefore cannot be recognized automatically
301 with the present coding system priorities.\n\n")
302
303 (let ((categories '(iso-7)) ; for XEmacs
304 ;; '(coding-category-iso-7 coding-category-iso-7-else))
305 coding-system codings)
306 (while categories
307 ;; for XEmacs
308 (setq coding-system (coding-category-system (car categories)))
309 (mapcar
310 (function
311 (lambda (x)
312 (if (and (not (eq x coding-system))
313 (get x 'no-initial-designation)
314 (let ((flags (coding-system-flags x)))
315 (not (or (aref flags 10) (aref flags 11)))))
316 (setq codings (cons x codings)))))
317 (get (car categories) 'coding-systems))
318 (if codings
319 (let ((max-col (frame-width))
320 pos)
321 (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system))
322 (while codings
323 (setq pos (point))
324 (insert (format " %s" (car codings)))
325 (when (> (current-column) max-col)
326 (goto-char pos)
327 (insert "\n ")
328 (goto-char (point-max)))
329 (setq codings (cdr codings)))
330 (insert "\n\n")))
331 (setq categories (cdr categories))))
332
333 (princ "Particular coding systems specified for certain file names:\n")
334 (terpri)
335 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
336 (princ " ---------\t--------------\t\t----------------\n")
337 (let ((func (lambda (operation alist)
338 (princ " ")
339 (princ operation)
340 (if (not alist)
341 (princ "\tnothing specified\n")
342 (while alist
343 (indent-to 16)
344 (prin1 (car (car alist)))
345 (indent-to 40)
346 (princ (cdr (car alist)))
347 (princ "\n")
348 (setq alist (cdr alist)))))))
349 (funcall func "File I/O" file-coding-system-alist)
350 (funcall func "Process I/O" process-coding-system-alist)
351 (funcall func "Network I/O" network-coding-system-alist))
352 (help-mode))))
353
354 ;; Print detailed information on CODING-SYSTEM.
355 (defun print-coding-system (coding-system &optional aliases)
356 (let ((type (coding-system-type coding-system))
357 (eol-type (coding-system-eol-type coding-system))
358 (flags (coding-system-flags coding-system))
359 (base (coding-system-base coding-system)))
360 (if (not (eq base coding-system))
361 (princ (format "%s (alias of %s)\n" coding-system base))
362 (princ coding-system)
363 (while aliases
364 (princ ",")
365 (princ (car aliases))
366 (setq aliases (cdr aliases)))
367 (princ (format ":%s:%c:%d:"
368 type
369 (coding-system-mnemonic coding-system)
370 (if (integerp eol-type) eol-type 3)))
371 (cond ((eq type 2) ; ISO-2022
372 (let ((idx 0)
373 charset)
374 (while (< idx 4)
375 (setq charset (aref flags idx))
376 (cond ((null charset)
377 (princ -1))
378 ((eq charset t)
379 (princ -2))
380 ((charsetp charset)
381 (princ charset))
382 ((listp charset)
383 (princ "(")
384 (princ (car charset))
385 (setq charset (cdr charset))
386 (while charset
387 (princ ",")
388 (princ (car charset))
389 (setq charset (cdr charset)))
390 (princ ")")))
391 (princ ",")
392 (setq idx (1+ idx)))
393 (while (< idx 12)
394 (princ (if (aref flags idx) 1 0))
395 (princ ",")
396 (setq idx (1+ idx)))
397 (princ (if (aref flags idx) 1 0))))
398 ((eq type 4) ; CCL
399 (let (i len)
400 (setq i 0 len (length (car flags)))
401 (while (< i len)
402 (princ (format " %x" (aref (car flags) i)))
403 (setq i (1+ i)))
404 (princ ",")
405 (setq i 0 len (length (cdr flags)))
406 (while (< i len)
407 (princ (format " %x" (aref (cdr flags) i)))
408 (setq i (1+ i)))))
409 (t (princ 0)))
410 (princ ":")
411 (princ (coding-system-doc-string coding-system))
412 (princ "\n"))))
413
414 ;;;###autoload
415 (defun list-coding-systems (&optional arg)
416 "Display a list of all coding systems.
417 It prints mnemonic letter, name, and description of each coding systems.
418
419 With prefix arg, the output format gets more cryptic,
420 but contains full information about each coding systems."
421 (interactive "P")
422 (with-output-to-temp-buffer "*Help*"
423 (if (null arg)
424 (princ "\
425 ###############################################
426 # List of coding systems in the following format:
427 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
428 # DOC-STRING
429 ")
430 (princ "\
431 #########################
432 ## LIST OF CODING SYSTEMS
433 ## Each line corresponds to one coding system
434 ## Format of a line is:
435 ## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
436 ## :PRE-WRITE-CONVERSION:DOC-STRING,
437 ## where
438 ## NAME = coding system name
439 ## ALIAS = alias of the coding system
440 ## TYPE = nil (no conversion), t (undecided or automatic detection),
441 ## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
442 ## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
443 ## FLAGS =
444 ## if TYPE = 2 then
445 ## comma (`,') separated data of the followings:
446 ## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
447 ## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
448 ## else if TYPE = 4 then
449 ## comma (`,') separated CCL programs for read and write
450 ## else
451 ## 0
452 ## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
453 ##
454 "))
455 (let ((bases (coding-system-list))
456 ;;(coding-system-list 'base-only))
457 coding-system)
458 (while bases
459 (setq coding-system (car bases))
460 (if (null arg)
461 (print-coding-system-briefly coding-system 'doc-string)
462 (print-coding-system coding-system))
463 (setq bases (cdr bases))))))
464
465 ;;;###automatic
466 (defun list-coding-categories ()
467 "Display a list of all coding categories."
468 (with-output-to-temp-buffer "*Help*"
469 (princ "\
470 ############################
471 ## LIST OF CODING CATEGORIES (ordered by priority)
472 ## CATEGORY:CODING-SYSTEM
473 ##
474 ")
475 (let ((l coding-category-list))
476 (while l
477 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
478 (setq l (cdr l))))))
479
480 ;;; FONT
481
482 ;; Print information of a font in FONTINFO.
483 (defun describe-font-internal (font-info &optional verbose)
484 (print-list "name (opened by):" (aref font-info 0))
485 (print-list " full name:" (aref font-info 1))
486 (let ((charset (aref font-info 2)))
487 (print-list " charset:"
488 (format "%s (%s)" charset (charset-description charset))))
489 (print-list " size:" (format "%d" (aref font-info 3)))
490 (print-list " height:" (format "%d" (aref font-info 4)))
491 (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
492 (print-list "relative-compose:" (format "%d" (aref font-info 6))))
493
494 ;;;###autoload
495 (defun describe-font (fontname)
496 "Display information about fonts which partially match FONTNAME."
497 (interactive "sFontname (default, current choise for ASCII chars): ")
498 (or window-system
499 (error "No window system being used"))
500 (when (or (not fontname) (= (length fontname) 0))
501 (setq fontname (cdr (assq 'font (frame-parameters))))
502 (if (query-fontset fontname)
503 (setq fontname
504 (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
505 (let ((font-info (font-info fontname)))
506 (if (null font-info)
507 (message "No matching font")
508 (with-output-to-temp-buffer "*Help*"
509 (describe-font-internal font-info 'verbose)))))
510
511 ;; Print information of FONTSET. If optional arg PRINT-FONTS is
512 ;; non-nil, print also names of all fonts in FONTSET. This function
513 ;; actually INSERT such information in the current buffer.
514 (defun print-fontset (fontset &optional print-fonts)
515 (let* ((fontset-info (fontset-info fontset))
516 (size (aref fontset-info 0))
517 (height (aref fontset-info 1))
518 (fonts (and print-fonts (aref fontset-info 2)))
519 (xlfd-fields (x-decompose-font-name fontset))
520 style)
521 (if xlfd-fields
522 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
523 (slant (aref xlfd-fields xlfd-regexp-slant-subnum)))
524 (if (string-match "^bold$\\|^demibold$" weight)
525 (setq style (concat weight " "))
526 (setq style "medium "))
527 (cond ((string-match "^i$" slant)
528 (setq style (concat style "italic")))
529 ((string-match "^o$" slant)
530 (setq style (concat style "slant")))
531 ((string-match "^ri$" slant)
532 (setq style (concat style "reverse italic")))
533 ((string-match "^ro$" slant)
534 (setq style (concat style "reverse slant")))))
535 (setq style " ? "))
536 (beginning-of-line)
537 (insert fontset)
538 (indent-to 58)
539 (insert (if (> size 0) (format "%2dx%d" size height) " -"))
540 (indent-to 64)
541 (insert style "\n")
542 (when print-fonts
543 (insert " O Charset / Fontname\n"
544 " - ------------------\n")
545 (sort-charset-list)
546 (let ((l charset-list)
547 charset font-info opened fontname)
548 (while l
549 (setq charset (car l) l (cdr l))
550 (setq font-info (assq charset fonts))
551 (if (null font-info)
552 (setq opened ?? fontname "not specified")
553 (if (nth 2 font-info)
554 (if (stringp (nth 2 font-info))
555 (setq opened ?o fontname (nth 2 font-info))
556 (setq opened ?- fontname (nth 1 font-info)))
557 (setq opened ?x fontname (nth 1 font-info))))
558 (insert (format " %c %s\n %s\n"
559 opened charset fontname)))))))
560
561 ;;;###autoload
562 (defun describe-fontset (fontset)
563 "Display information of FONTSET.
564
565 It prints name, size, and style of FONTSET, and lists up fonts
566 contained in FONTSET.
567
568 The column WDxHT contains width and height (pixels) of each fontset
569 \(i.e. those of ASCII font in the fontset). The letter `-' in this
570 column means that the corresponding fontset is not yet used in any
571 frame.
572
573 The O column of each font contains one of the following letters.
574 o -- font already opened
575 - -- font not yet opened
576 x -- font can't be opened
577 ? -- no font specified
578
579 The Charset column of each font contains a name of character set
580 displayed by the font."
581 (interactive
582 (if (not window-system)
583 (error "No window system being used")
584 (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
585 (completion-ignore-case t))
586 (list (completing-read
587 "Fontset (default, used by the current frame): "
588 fontset-list nil t)))))
589 (if (= (length fontset) 0)
590 (setq fontset (cdr (assq 'font (frame-parameters)))))
591 (if (not (query-fontset fontset))
592 (error "Current frame is using font, not fontset"))
593 (let ((fontset-info (fontset-info fontset)))
594 (with-output-to-temp-buffer "*Help*"
595 (save-excursion
596 (set-buffer standard-output)
597 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
598 (insert "------------\t\t\t\t\t\t ----- -----\n")
599 (print-fontset fontset t)))))
600
601 ;;;###autoload
602 (defun list-fontsets (arg)
603 "Display a list of all fontsets.
604
605 It prints name, size, and style of each fontset.
606 With prefix arg, it also lists up fonts contained in each fontset.
607 See the function `describe-fontset' for the format of the list."
608 (interactive "P")
609 (with-output-to-temp-buffer "*Help*"
610 (save-excursion
611 (set-buffer standard-output)
612 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
613 (insert "------------\t\t\t\t\t\t ----- -----\n")
614 (let ((fontsets (fontset-list)))
615 (while fontsets
616 (print-fontset (car fontsets) arg)
617 (setq fontsets (cdr fontsets)))))))
618
619 ;;;###autoload
620 (defun list-input-methods ()
621 "Print information of all input methods."
622 (interactive)
623 (with-output-to-temp-buffer "*Help*"
624 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
625 (princ " SHORT-DESCRIPTION\n------------------------------\n")
626 (setq input-method-alist
627 (sort input-method-alist
628 (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
629 (let ((l input-method-alist)
630 language elt)
631 (while l
632 (setq elt (car l) l (cdr l))
633 (when (not (equal language (nth 1 elt)))
634 (setq language (nth 1 elt))
635 (princ language)
636 (terpri))
637 (princ (format " %s (`%s' in mode line)\n %s\n"
638 (car elt) (nth 3 elt)
639 (let ((title (nth 4 elt)))
640 (string-match ".*" title)
641 (match-string 0 title))))))))
642
643 ;;; DIAGNOSIS
644
645 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
646 (defun insert-section (section-number title)
647 (insert "########################################\n"
648 "# Section " (format "%d" section-number) ". " title "\n"
649 "########################################\n\n"))
650
651 ;;;###autoload
652 (defun mule-diag ()
653 "Display diagnosis of the multilingual environment (MULE).
654
655 It prints various information related to the current multilingual
656 environment, including lists of input methods, coding systems,
657 character sets, and fontsets (if Emacs running under some window
658 system)."
659 (interactive)
660 (with-output-to-temp-buffer "*Mule-Diagnosis*"
661 (save-excursion
662 (set-buffer standard-output)
663 (insert "\t###############################\n"
664 "\t### Diagnosis of your Emacs ###\n"
665 "\t###############################\n\n"
666 "CONTENTS: Section 1. General Information\n"
667 " Section 2. Display\n"
668 " Section 3. Input methods\n"
669 " Section 4. Coding systems\n"
670 " Section 5. Character sets\n")
671 (if window-system
672 (insert " Section 6. Fontsets\n"))
673 (insert "\n")
674
675 (insert-section 1 "General Information")
676 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
677
678 (insert-section 2 "Display")
679 (if window-system
680 (insert "Window-system: "
681 (symbol-name window-system)
682 (format "%s" window-system-version))
683 (insert "Terminal: " (getenv "TERM")))
684 (insert "\n\n")
685
686 (if (eq window-system 'x)
687 (let ((font (cdr (assq 'font (frame-parameters)))))
688 (insert "The selected frame is using the "
689 (if (query-fontset font) "fontset" "font")
690 ":\n\t" font))
691 (insert "Coding system of the terminal: "
692 (symbol-name (terminal-coding-system))))
693 (insert "\n\n")
694
695 (insert-section 3 "Input methods")
696 (save-excursion (list-input-methods))
697 (insert-buffer-substring "*Help*")
698 (insert "\n")
699 (if default-input-method
700 (insert "Default input method: " default-input-method "\n")
701 (insert "No default input method is specified\n"))
702
703 (insert-section 4 "Coding systems")
704 (save-excursion (list-coding-systems t))
705 (insert-buffer-substring "*Help*")
706 (save-excursion (list-coding-categories))
707 (insert-buffer-substring "*Help*")
708 (insert "\n")
709
710 (insert-section 5 "Character sets")
711 (save-excursion (list-character-sets t))
712 (insert-buffer-substring "*Help*")
713 (insert "\n")
714
715 (when window-system
716 (insert-section 6 "Fontsets")
717 (save-excursion (list-fontsets t))
718 (insert-buffer-substring "*Help*"))
719 (help-mode))))
720
721
722 ;;; DUMP DATA FILE
723
724 ;;;###autoload
725 (defun dump-charsets ()
726 "Dump information of all charsets into the file \"CHARSETS\".
727 The file is saved in the directory `data-directory'."
728 (let ((file (expand-file-name "CHARSETS" data-directory))
729 buf)
730 (or (file-writable-p file)
731 (error "Can't write to file %s" file))
732 (setq buf (find-file-noselect file))
733 (save-window-excursion
734 (save-excursion
735 (set-buffer buf)
736 (setq buffer-read-only nil)
737 (erase-buffer)
738 (list-character-sets t)
739 (insert-buffer-substring "*Help*")
740 (let (make-backup-files
741 coding-system-for-write)
742 (save-buffer))))
743 (kill-buffer buf))
744 (if noninteractive
745 (kill-emacs)))
746
747 ;;;###autoload
748 (defun dump-codings ()
749 "Dump information of all coding systems into the file \"CODINGS\".
750 The file is saved in the directory `data-directory'."
751 (let ((file (expand-file-name "CODINGS" data-directory))
752 buf)
753 (or (file-writable-p file)
754 (error "Can't write to file %s" file))
755 (setq buf (find-file-noselect file))
756 (save-window-excursion
757 (save-excursion
758 (set-buffer buf)
759 (setq buffer-read-only nil)
760 (erase-buffer)
761 (list-coding-systems t)
762 (insert-buffer-substring "*Help*")
763 (list-coding-categories)
764 (insert-buffer-substring "*Help*")
765 (let (make-backup-files
766 coding-system-for-write)
767 (save-buffer))))
768 (kill-buffer buf))
769 (if noninteractive
770 (kill-emacs)))
771
772 ;;; mule-diag.el ends here