HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
*** empty log message ***
[bpt/emacs.git] / lisp / international / mule-diag.el
CommitLineData
3fdc9c8f 1;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
4ed46869 2
4ed46869 3;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
fa526c4a 4;; Licensed to the Free Software Foundation.
4ed46869
KH		 5
6;; Keywords: multilingual, charset, coding system, fontset, diagnosis
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
369314dc
KH		 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.
4ed46869
KH		 24
25;;; General utility function
26
27;; Print all arguments with single space separator in one line.
28(defun print-list (&rest args)
29 (while (cdr args)
4472a77b
KH		 30 (when (car args)
31 (princ (car args))
32 (princ " "))
4ed46869
KH		 33 (setq args (cdr args)))
34 (princ (car args))
35 (princ "\n"))
36
4472a77b
KH		 37;; Re-order the elements of charset-list.
38(defun sort-charset-list ()
39 (setq charset-list
40 (sort charset-list
41 (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
42
4ed46869
KH		 43;;; CHARSET
44
45;;;###autoload
4472a77b
KH		 46(defun list-character-sets (&optional arg)
47 "Display a list of all character sets.
48
4527adca
KH		 49The ID column contains a charset identification number for internal Emacs use.
50The B column contains a number of bytes occupied in a buffer
51 by any character in this character set.
52The W column contains a number of columns occupied on the screen
53 by any character in this character set.
4472a77b 54
4527adca
KH		 55With prefix arg, the output format gets more cryptic,
56but still shows the full information."
4472a77b
KH		 57 (interactive "P")
58 (sort-charset-list)
4ed46869 59 (with-output-to-temp-buffer "*Help*"
426f97dc
KH		 60 (save-excursion
61 (set-buffer standard-output)
13cef08d
KH		 62 (list-character-sets-1 arg)
63 (help-mode)
64 (setq truncate-lines t))))
65
66(defun list-character-sets-1 (arg)
67 (let ((l charset-list)
68 charset)
69 (if (null arg)
70 (progn
71 (insert "ID Name B W Description\n")
72 (insert "-- ---- - - -----------\n")
73 (while l
74 (setq charset (car l) l (cdr l))
75 (insert (format "%03d %s" (charset-id charset) charset))
76 (indent-to 28)
77 (insert (format "%d %d %s\n"
78 (charset-bytes charset)
79 (charset-width charset)
80 (charset-description charset)))))
81 (insert "\
4ed46869
KH		 82#########################
83## LIST OF CHARSETS
84## Each line corresponds to one charset.
85## The following attributes are listed in this order
86## separated by a colon `:' in one line.
4ed46869 87## CHARSET-ID,
4472a77b 88## CHARSET-SYMBOL-NAME,
4ed46869
KH		 89## DIMENSION (1 or 2)
90## CHARS (94 or 96)
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)
97")
13cef08d
KH		 98 (while l
99 (setq charset (car l) l (cdr l))
100 (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
101 (charset-id charset)
102 charset
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)))))))
4ed46869
KH		 111\f
112;;; CODING-SYSTEM
113
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)
119 charset)
120 (while (< graphic-register 4)
121 (setq charset (aref flags graphic-register))
122 (princ (format
123 " G%d -- %s\n"
124 graphic-register
125 (cond ((null charset)
126 "never used")
127 ((eq charset t)
128 "no initial designation, and used by any charsets")
129 ((symbolp charset)
130 (format "%s:%s"
131 charset (charset-description charset)))
132 ((listp charset)
133 (if (charsetp (car charset))
134 (format "%s:%s, and also used by the followings:"
135 (car charset)
136 (charset-description (car charset)))
137 "no initial designation, and used by the followings:"))
138 (t
139 "invalid designation information"))))
4472a77b
KH		 140 (when (listp charset)
141 (setq charset (cdr charset))
142 (while charset
143 (cond ((eq (car charset) t)
144 (princ "\tany other charsets\n"))
145 ((charsetp (car charset))
146 (princ (format "\t%s:%s\n"
147 (car charset)
148 (charset-description (car charset)))))
149 (t
150 "invalid designation information"))
151 (setq charset (cdr charset))))
4ed46869
KH		 152 (setq graphic-register (1+ graphic-register)))))
153
154;;;###autoload
155(defun describe-coding-system (coding-system)
4527adca 156 "Display information about CODING-SYSTEM."
426f97dc
KH		 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)))
163 (princ "Type: ")
164 (let ((type (coding-system-type coding-system))
165 (flags (coding-system-flags coding-system)))
166 (princ type)
167 (cond ((eq type nil)
168 (princ " (do no conversion)"))
169 ((eq type t)
170 (princ " (do automatic conversion)"))
171 ((eq type 0)
172 (princ " (Emacs internal multibyte form)"))
173 ((eq type 1)
174 (princ " (Shift-JIS, MS-KANJI)"))
175 ((eq type 2)
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"))
2dc98b1d
AS		 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"))
426f97dc
KH		 193 (princ "."))
194 ((eq type 3)
195 (princ " (Big5)"))
196 ((eq type 4)
197 (princ " (do conversion by CCL program)"))
ca6e03c2
RS		 198 ((eq type 5)
199 (princ " (text with random binary characters)"))
200 (t (princ ": invalid coding-system."))))
753fd9ca 201 (princ "\nEOL type: ")
426f97dc
KH		 202 (let ((eol-type (coding-system-eol-type coding-system)))
203 (cond ((vectorp eol-type)
204 (princ "Automatic selection from:\n\t")
205 (princ eol-type)
206 (princ "\n"))
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")))))
ff8909d8
KH		 211 (let ((postread (coding-system-get coding-system 'post-read-conversion)))
212 (when postread
213 (princ "After decoding a text normally,")
214 (princ " perform post-conversion by the function: ")
215 (princ "\n ")
216 (princ postread)
217 (princ "\n")))
218 (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
219 (when prewrite
220 (princ "Before encoding a text normally,")
221 (princ " perform pre-conversion by the function: ")
222 (princ "\n ")
223 (princ prewrite)
224 (princ "\n")))
753fd9ca
KH		 225 (let ((charsets (coding-system-get coding-system 'safe-charsets)))
226 (when charsets
0691ad61 227 (if (eq charsets t)
80606666 228 (princ "This coding system can encode all charsets.\n")
0691ad61 229 (princ "This coding system encode the following charsets:\n")
753fd9ca 230 (princ " ")
0691ad61
KH		 231 (while charsets
232 (princ " ")
233 (princ (car charsets))
234 (setq charsets (cdr charsets))))))
426f97dc
KH		 235 (save-excursion
236 (set-buffer standard-output)
237 (help-mode)))))
4ed46869
KH		 238
239;;;###autoload
240(defun describe-current-coding-system-briefly ()
795a5f84 241 "Display coding systems currently used in a brief format in echo area.
4ed46869 242
795a5f84 243The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
4ed46869 244where mnemonics of the following coding systems come in this order
795a5f84 245at the place of `..':
4527adca 246 `buffer-file-coding-system` (of the current buffer)
4ed46869 247 eol-type of buffer-file-coding-system (of the current buffer)
4527adca 248 Value returned by `keyboard-coding-system'
795a5f84 249 eol-type of (keyboard-coding-system)
4527adca 250 Value returned by `terminal-coding-system.
795a5f84 251 eol-type of (terminal-coding-system)
4527adca 252 `process-coding-system' for read (of the current buffer, if any)
4ed46869 253 eol-type of process-coding-system for read (of the current buffer, if any)
4527adca 254 `process-coding-system' for write (of the current buffer, if any)
4ed46869 255 eol-type of process-coding-system for write (of the current buffer, if any)
4527adca 256 `default-buffer-file-coding-system'
795a5f84 257 eol-type of default-buffer-file-coding-system
4527adca 258 `default-process-coding-system' for read
795a5f84 259 eol-type of default-process-coding-system for read
4527adca 260 `default-process-coding-system' for write
795a5f84 261 eol-type of default-process-coding-system"
4ed46869
KH		 262 (interactive)
263 (let* ((proc (get-buffer-process (current-buffer)))
264 (process-coding-systems (if proc (process-coding-system proc))))
265 (message
795a5f84 266 "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]"
4ed46869 267 (coding-system-mnemonic buffer-file-coding-system)
795a5f84 268 (coding-system-eol-type-mnemonic buffer-file-coding-system)
4ed46869 269 (coding-system-mnemonic (keyboard-coding-system))
795a5f84 270 (coding-system-eol-type-mnemonic (keyboard-coding-system))
4ed46869 271 (coding-system-mnemonic (terminal-coding-system))
795a5f84 272 (coding-system-eol-type-mnemonic (terminal-coding-system))
4ed46869 273 (coding-system-mnemonic (car process-coding-systems))
795a5f84 274 (coding-system-eol-type-mnemonic (car process-coding-systems))
4ed46869 275 (coding-system-mnemonic (cdr process-coding-systems))
795a5f84
KH		 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)
4ed46869 279 (coding-system-mnemonic (car default-process-coding-system))
795a5f84 280 (coding-system-eol-type-mnemonic (car default-process-coding-system))
4ed46869 281 (coding-system-mnemonic (cdr default-process-coding-system))
795a5f84 282 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
4ed46869
KH		 283 )))
284
4527adca 285;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
426f97dc 286(defun print-coding-system-briefly (coding-system &optional doc-string)
795a5f84
KH		 287 (if (not coding-system)
288 (princ "nil\n")
289 (princ (format "%c -- %s"
290 (coding-system-mnemonic coding-system)
291 coding-system))
ff8909d8
KH		 292 (let ((aliases (coding-system-get coding-system 'alias-coding-systems)))
293 (if (eq coding-system (car aliases))
294 (if (cdr aliases)
295 (princ (format " %S" (cons 'alias: (cdr aliases)))))
296 (if (memq coding-system aliases)
297 (princ (format " (alias of %s)" (car aliases))))))
795a5f84
KH		 298 (princ "\n")
299 (if (and doc-string
300 (setq doc-string (coding-system-doc-string coding-system)))
301 (princ (format " %s\n" doc-string)))))
4ed46869
KH		 302
303;;;###autoload
304(defun describe-current-coding-system ()
4527adca 305 "Display coding systems currently used, in detail."
4ed46869
KH		 306 (interactive)
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))))
e72e91e9 310 (princ "Coding system for saving this buffer:\n ")
795a5f84
KH		 311 (if (local-variable-p 'buffer-file-coding-system)
312 (print-coding-system-briefly buffer-file-coding-system)
e72e91e9
RS		 313 (princ "Not set locally, use the default.\n"))
314 (princ "Default coding system (for new files):\n ")
795a5f84 315 (print-coding-system-briefly default-buffer-file-coding-system)
e72e91e9 316 (princ "Coding system for keyboard input:\n ")
4ed46869 317 (print-coding-system-briefly (keyboard-coding-system))
e72e91e9 318 (princ "Coding system for terminal output:\n ")
4ed46869 319 (print-coding-system-briefly (terminal-coding-system))
e72e91e9
RS		 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)))
1b76aedd 326 (princ "Defaults for subprocess I/O:\n")
795a5f84 327 (princ " decoding: ")
4ed46869 328 (print-coding-system-briefly (car default-process-coding-system))
795a5f84
KH		 329 (princ " encoding: ")
330 (print-coding-system-briefly (cdr default-process-coding-system)))
426f97dc
KH		 331
332 (save-excursion
333 (set-buffer standard-output)
334
e72e91e9 335 (princ "\nPriority order for recognizing coding systems when reading files:\n")
426f97dc
KH		 336 (let ((l coding-category-list)
337 (i 1)
5cfcd8bc 338 (coding-list nil)
426f97dc
KH		 339 coding aliases)
340 (while l
341 (setq coding (symbol-value (car l)))
ff8909d8 342 ;; Do not list up the same coding system twice.
2149d013 343 (when (and coding (not (memq coding coding-list)))
5cfcd8bc 344 (setq coding-list (cons coding coding-list))
ff8909d8
KH		 345 (princ (format " %d. %s " i coding))
346 (setq aliases (coding-system-get coding 'alias-coding-systems))
347 (if (eq coding (car aliases))
348 (if (cdr aliases)
349 (princ (cons 'alias: (cdr aliases))))
350 (if (memq coding aliases)
351 (princ (list 'alias 'of (car aliases)))))
5cfcd8bc
KH		 352 (terpri)
353 (setq i (1+ i)))
354 (setq l (cdr l))))
ff8909d8 355
426f97dc
KH		 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")
359
b585fb6c 360 (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
426f97dc
KH		 361 coding-system codings)
362 (while categories
363 (setq coding-system (symbol-value (car categories)))
364 (mapcar
365 (function
366 (lambda (x)
367 (if (and (not (eq x coding-system))
ff8909d8 368 (coding-system-get x 'no-initial-designation)
426f97dc
KH		 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))
373 (if codings
374 (let ((max-col (frame-width))
375 pos)
376 (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system))
377 (while codings
378 (setq pos (point))
379 (insert (format " %s" (car codings)))
4472a77b
KH		 380 (when (> (current-column) max-col)
381 (goto-char pos)
382 (insert "\n ")
383 (goto-char (point-max)))
426f97dc
KH		 384 (setq codings (cdr codings)))
385 (insert "\n\n")))
386 (setq categories (cdr categories))))
387
e72e91e9 388 (princ "Particular coding systems specified for certain file names:\n")
426f97dc
KH		 389 (terpri)
390 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
391 (princ " ---------\t--------------\t\t----------------\n")
392 (let ((func (lambda (operation alist)
393 (princ " ")
394 (princ operation)
395 (if (not alist)
396 (princ "\tnothing specified\n")
397 (while alist
398 (indent-to 16)
399 (prin1 (car (car alist)))
ff8909d8
KH		 400 (if (>= (current-column) 40)
401 (newline))
426f97dc
KH		 402 (indent-to 40)
403 (princ (cdr (car alist)))
404 (princ "\n")
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))
409 (help-mode))))
4ed46869
KH		 410
411;; Print detailed information on CODING-SYSTEM.
ff8909d8 412(defun print-coding-system (coding-system)
4ed46869 413 (let ((type (coding-system-type coding-system))
795a5f84
KH		 414 (eol-type (coding-system-eol-type coding-system))
415 (flags (coding-system-flags coding-system))
ff8909d8
KH		 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)))
795a5f84 419 (princ coding-system)
ff8909d8 420 (setq aliases (cdr aliases))
795a5f84 421 (while aliases
4472a77b
KH		 422 (princ ",")
423 (princ (car aliases))
424 (setq aliases (cdr aliases)))
795a5f84
KH		 425 (princ (format ":%s:%c:%d:"
426 type
427 (coding-system-mnemonic coding-system)
428 (if (integerp eol-type) eol-type 3)))
429 (cond ((eq type 2) ; ISO-2022
430 (let ((idx 0)
431 charset)
432 (while (< idx 4)
433 (setq charset (aref flags idx))
434 (cond ((null charset)
435 (princ -1))
436 ((eq charset t)
437 (princ -2))
438 ((charsetp charset)
439 (princ charset))
440 ((listp charset)
441 (princ "(")
4ed46869 442 (princ (car charset))
795a5f84
KH		 443 (setq charset (cdr charset))
444 (while charset
445 (princ ",")
446 (princ (car charset))
447 (setq charset (cdr charset)))
448 (princ ")")))
449 (princ ",")
450 (setq idx (1+ idx)))
451 (while (< idx 12)
452 (princ (if (aref flags idx) 1 0))
453 (princ ",")
454 (setq idx (1+ idx)))
455 (princ (if (aref flags idx) 1 0))))
456 ((eq type 4) ; CCL
457 (let (i len)
0d5f1e3a
RS		 458 (if (symbolp (car flags))
459 (princ (format " %s" (car flags)))
460 (setq i 0 len (length (car flags)))
461 (while (< i len)
462 (princ (format " %x" (aref (car flags) i)))
463 (setq i (1+ i))))
4ed46869 464 (princ ",")
0d5f1e3a
RS		 465 (if (symbolp (cdr flags))
466 (princ (format "%s" (cdr flags)))
467 (setq i 0 len (length (cdr flags)))
468 (while (< i len)
469 (princ (format " %x" (aref (cdr flags) i)))
470 (setq i (1+ i))))))
795a5f84
KH		 471 (t (princ 0)))
472 (princ ":")
473 (princ (coding-system-doc-string coding-system))
474 (princ "\n"))))
4ed46869 475
795a5f84 476;;;###autoload
4472a77b
KH		 477(defun list-coding-systems (&optional arg)
478 "Display a list of all coding systems.
4527adca 479This shows the mnemonic letter, name, and description of each coding system.
4472a77b
KH		 480
481With prefix arg, the output format gets more cryptic,
4527adca 482but still contains full information about each coding system."
4472a77b 483 (interactive "P")
4ed46869 484 (with-output-to-temp-buffer "*Help*"
13cef08d
KH		 485 (list-coding-systems-1 arg)))
486
487(defun list-coding-systems-1 (arg)
488 (if (null arg)
489 (princ "\
795a5f84
KH		 490###############################################
491# List of coding systems in the following format:
492# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
493# DOC-STRING
494")
13cef08d 495 (princ "\
4ed46869
KH		 496#########################
497## LIST OF CODING SYSTEMS
498## Each line corresponds to one coding system
499## Format of a line is:
795a5f84
KH		 500## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
501## :PRE-WRITE-CONVERSION:DOC-STRING,
4ed46869 502## where
795a5f84
KH		 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)
4ed46869
KH		 507## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
508## FLAGS =
509## if TYPE = 2 then
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
515## else
516## 0
795a5f84 517## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
4ed46869 518##
795a5f84 519"))
13cef08d
KH		 520 (let ((bases (coding-system-list 'base-only))
521 coding-system)
522 (while bases
523 (setq coding-system (car bases))
524 (if (null arg)
525 (print-coding-system-briefly coding-system 'doc-string)
526 (print-coding-system coding-system))
527 (setq bases (cdr bases)))))
4472a77b
KH		 528
529;;;###automatic
530(defun list-coding-categories ()
531 "Display a list of all coding categories."
532 (with-output-to-temp-buffer "*Help*"
533 (princ "\
4ed46869
KH		 534############################
535## LIST OF CODING CATEGORIES (ordered by priority)
536## CATEGORY:CODING-SYSTEM
537##
538")
4472a77b
KH		 539 (let ((l coding-category-list))
540 (while l
541 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
542 (setq l (cdr l))))))
4ed46869
KH		 543\f
544;;; FONT
545
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))))
557
558;;;###autoload
559(defun describe-font (fontname)
560 "Display information about fonts which partially match FONTNAME."
4bb0b3ad 561 (interactive "sFontname (default, current choice for ASCII chars): ")
effd4e82
KH		 562 (or (and window-system (boundp 'global-fontset-alist))
563 (error "No fontsets being used"))
2167d18d
KH		 564 (when (or (not fontname) (= (length fontname) 0))
565 (setq fontname (cdr (assq 'font (frame-parameters))))
566 (if (query-fontset fontname)
567 (setq fontname
568 (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
4ed46869
KH		 569 (let ((font-info (font-info fontname)))
570 (if (null font-info)
571 (message "No matching font")
572 (with-output-to-temp-buffer "*Help*"
573 (describe-font-internal font-info 'verbose)))))
574
4472a77b
KH		 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))
4472a77b 584 style)
5cfcd8bc
KH		 585 (if xlfd-fields
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")))))
599 (setq style " ? "))
4472a77b
KH		 600 (beginning-of-line)
601 (insert fontset)
22bdf5d1 602 (indent-to 58)
2167d18d 603 (insert (if (> size 0) (format "%2dx%d" size height) " -"))
22bdf5d1 604 (indent-to 64)
4472a77b
KH		 605 (insert style "\n")
606 (when print-fonts
607 (insert " O Charset / Fontname\n"
2167d18d 608 " - ------------------\n")
4472a77b
KH		 609 (sort-charset-list)
610 (let ((l charset-list)
611 charset font-info opened fontname)
612 (while l
613 (setq charset (car l) l (cdr l))
614 (setq font-info (assq charset fonts))
615 (if (null font-info)
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)))))))
4ed46869
KH		 624
625;;;###autoload
626(defun describe-fontset (fontset)
4472a77b 627 "Display information of FONTSET.
4527adca 628This shows the name, size, and style of FONTSET, and the list of fonts
4472a77b
KH		 629contained in FONTSET.
630
2167d18d
KH		 631The column WDxHT contains width and height (pixels) of each fontset
632\(i.e. those of ASCII font in the fontset). The letter `-' in this
633column means that the corresponding fontset is not yet used in any
634frame.
4472a77b 635
4527adca 636The O column for each font contains one of the following letters:
22bdf5d1
KH		 637 o -- font already opened
638 - -- font not yet opened
639 x -- font can't be opened
640 ? -- no font specified
4472a77b 641
4527adca
KH		 642The Charset column for each font contains a name of character set
643displayed (for this fontset) using that font."
4ed46869 644 (interactive
effd4e82
KH		 645 (if (not (and window-system (boundp 'global-fontset-alist)))
646 (error "No fontsets being used")
4472a77b
KH		 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*"
658 (save-excursion
659 (set-buffer standard-output)
2167d18d
KH		 660 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
661 (insert "------------\t\t\t\t\t\t ----- -----\n")
4472a77b
KH		 662 (print-fontset fontset t)))))
663
664;;;###autoload
665(defun list-fontsets (arg)
666 "Display a list of all fontsets.
4527adca
KH		 667This shows the name, size, and style of each fontset.
668With prefix arg, it also list the fonts contained in each fontset;
669see the function `describe-fontset' for the format of the list."
4472a77b 670 (interactive "P")
effd4e82
KH		 671 (if (not (and window-system (boundp 'global-fontset-alist)))
672 (error "No fontsets being used")
673 (with-output-to-temp-buffer "*Help*"
674 (save-excursion
13cef08d 675 ;; This code is duplicated near the end of mule-diag.
effd4e82
KH		 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")
dc1f8c72
KH		 679 (let ((fontsets
680 (sort (fontset-list)
681 (function (lambda (x y)
682 (string< (fontset-plain-name x)
683 (fontset-plain-name y)))))))
effd4e82
KH		 684 (while fontsets
685 (print-fontset (car fontsets) arg)
686 (setq fontsets (cdr fontsets))))))))
426f97dc
KH		 687\f
688;;;###autoload
689(defun list-input-methods ()
4527adca 690 "Display information about all input methods."
426f97dc
KH		 691 (interactive)
692 (with-output-to-temp-buffer "*Help*"
13cef08d
KH		 693 (list-input-methods-1)))
694
695(defun list-input-methods-1 ()
696 (if (not input-method-alist)
697 (progn
698 (princ "
effd4e82 699No input method is available, perhaps because you have not yet
753fd9ca
KH		 700installed LEIM (Libraries of Emacs Input Method).
701
effd4e82 702LEIM is available from the same ftp directory as Emacs. For instance,
73eaef52
RS		 703if there exists an archive file `emacs-20.N.tar.gz', there should also
704be a file `leim-20.N.tar.gz'. When you extract this file, LEIM files
705are put under the subdirectory `emacs-20.N/leim'. When you install
753fd9ca 706Emacs again, you should be able to use various input methods."))
13cef08d
KH		 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)
713 language elt)
714 (while l
715 (setq elt (car l) l (cdr l))
716 (when (not (equal language (nth 1 elt)))
717 (setq language (nth 1 elt))
718 (princ language)
719 (terpri))
720 (princ (format " %s (`%s' in mode line)\n %s\n"
721 (car elt)
722 (let ((title (nth 3 elt)))
723 (if (and (consp title) (stringp (car title)))
724 (car title)
725 title))
726 (let ((description (nth 4 elt)))
727 (string-match ".*" description)
728 (match-string 0 description))))))))
4ed46869
KH		 729\f
730;;; DIAGNOSIS
731
4472a77b
KH		 732;; Insert a header of a section with SECTION-NUMBER and TITLE.
733(defun insert-section (section-number title)
4ed46869 734 (insert "########################################\n"
4472a77b 735 "# Section " (format "%d" section-number) ". " title "\n"
4ed46869
KH		 736 "########################################\n\n"))
737
738;;;###autoload
739(defun mule-diag ()
4472a77b
KH		 740 "Display diagnosis of the multilingual environment (MULE).
741
4527adca 742This shows various information related to the current multilingual
4472a77b 743environment, including lists of input methods, coding systems,
4527adca 744character sets, and fontsets (if Emacs is running under a window
effd4e82 745system which uses fontsets)."
4ed46869 746 (interactive)
4472a77b 747 (with-output-to-temp-buffer "*Mule-Diagnosis*"
4ed46869 748 (save-excursion
4472a77b 749 (set-buffer standard-output)
13cef08d
KH		 750 (insert "###############################################\n"
751 "### Current Status of Multilingual Features ###\n"
752 "###############################################\n\n"
4ed46869
KH		 753 "CONTENTS: Section 1. General Information\n"
754 " Section 2. Display\n"
755 " Section 3. Input methods\n"
756 " Section 4. Coding systems\n"
4472a77b 757 " Section 5. Character sets\n")
effd4e82 758 (if (and window-system (boundp 'global-fontset-alist))
4472a77b 759 (insert " Section 6. Fontsets\n"))
4ed46869
KH		 760 (insert "\n")
761
762 (insert-section 1 "General Information")
7bce107c 763 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
4ed46869
KH		 764
765 (insert-section 2 "Display")
766 (if window-system
767 (insert "Window-system: "
768 (symbol-name window-system)
769 (format "%s" window-system-version))
770 (insert "Terminal: " (getenv "TERM")))
771 (insert "\n\n")
772
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")
777 ":\n\t" font))
778 (insert "Coding system of the terminal: "
779 (symbol-name (terminal-coding-system))))
780 (insert "\n\n")
781
782 (insert-section 3 "Input methods")
13cef08d 783 (list-input-methods-1)
4ed46869
KH		 784 (insert "\n")
785 (if default-input-method
d871aa9b 786 (insert "Default input method: " default-input-method "\n")
1b76aedd 787 (insert "No default input method is specified\n"))
4ed46869
KH		 788
789 (insert-section 4 "Coding systems")
13cef08d
KH		 790 (list-coding-systems-1 t)
791 (princ "\
792############################
793## LIST OF CODING CATEGORIES (ordered by priority)
794## CATEGORY:CODING-SYSTEM
795##
796")
797 (let ((l coding-category-list))
798 (while l
799 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
800 (setq l (cdr l))))
4ed46869
KH		 801 (insert "\n")
802
4472a77b 803 (insert-section 5 "Character sets")
13cef08d 804 (list-character-sets-1 t)
4ed46869
KH		 805 (insert "\n")
806
effd4e82 807 (when (and window-system (boundp 'global-fontset-alist))
13cef08d 808 ;; This code duplicates most of list-fontsets.
4472a77b 809 (insert-section 6 "Fontsets")
13cef08d
KH		 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)))
813 (while fontsets
814 (print-fontset (car fontsets) t)
815 (setq fontsets (cdr fontsets)))))
eabe0ad3 816 (print-help-return-message))))
4ed46869
KH		 817
818\f
819;;; DUMP DATA FILE
820
821;;;###autoload
822(defun dump-charsets ()
4527adca 823 "Dump information about all charsets into the file `CHARSETS'.
4472a77b
KH		 824The file is saved in the directory `data-directory'."
825 (let ((file (expand-file-name "CHARSETS" data-directory))
826 buf)
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
831 (save-excursion
832 (set-buffer buf)
833 (setq buffer-read-only nil)
834 (erase-buffer)
835 (list-character-sets t)
836 (insert-buffer-substring "*Help*")
837 (let (make-backup-files
838 coding-system-for-write)
839 (save-buffer))))
840 (kill-buffer buf))
841 (if noninteractive
842 (kill-emacs)))
4ed46869
KH		 843
844;;;###autoload
845(defun dump-codings ()
4527adca 846 "Dump information about all coding systems into the file `CODINGS'.
4472a77b
KH		 847The file is saved in the directory `data-directory'."
848 (let ((file (expand-file-name "CODINGS" data-directory))
849 buf)
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
854 (save-excursion
855 (set-buffer buf)
856 (setq buffer-read-only nil)
857 (erase-buffer)
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)
864 (save-buffer))))
865 (kill-buffer buf))
866 (if noninteractive
867 (kill-emacs)))
4ed46869 868
795a5f84 869;;; mule-diag.el ends here
Unnamed repository; edit this file 'description' to name the repository.