HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fixed copyright notice.
[bpt/emacs.git] / lisp / international / mule-diag.el
CommitLineData
60370d40 1;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
4ed46869 2
d4877ac1
GM		 3;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
4;; 2005, 2006 Free Software Foundation, Inc.
5;; Copyright (C) 1995, 1997, 1999, 2000, 2001, 2002, 2003,
6;; 2004, 2005, 2006
2fd125a3
KH		 7;; National Institute of Advanced Industrial Science and Technology (AIST)
8;; Registration Number H14PRO021
4ed46869 9
3a4df6e5 10;; Keywords: multilingual, charset, coding system, fontset, diagnosis, i18n
4ed46869
KH		 11
12;; This file is part of GNU Emacs.
13
14;; GNU Emacs is free software; you can redistribute it and/or modify
15;; it under the terms of the GNU General Public License as published by
16;; the Free Software Foundation; either version 2, or (at your option)
17;; any later version.
18
19;; GNU Emacs is distributed in the hope that it will be useful,
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;; GNU General Public License for more details.
23
24;; You should have received a copy of the GNU General Public License
369314dc 25;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56
LK		 26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27;; Boston, MA 02110-1301, USA.
4ed46869 28
60370d40
PJ		 29;;; Commentary:
30
31;;; Code:
32
0abeb602 33;; Make sure the help-xref button type is defined.
abf545c4 34(require 'help-fns)
0abeb602 35
4ed46869
KH		 36;;; General utility function
37
38;; Print all arguments with single space separator in one line.
39(defun print-list (&rest args)
40 (while (cdr args)
4472a77b
KH		 41 (when (car args)
42 (princ (car args))
43 (princ " "))
4ed46869
KH		 44 (setq args (cdr args)))
45 (princ (car args))
46 (princ "\n"))
47
4472a77b
KH		 48;; Re-order the elements of charset-list.
49(defun sort-charset-list ()
50 (setq charset-list
51 (sort charset-list
02e91426 52 (lambda (x y) (< (charset-id x) (charset-id y))))))
4472a77b 53
4ed46869
KH		 54;;; CHARSET
55
e8cdeaca
MB		 56(define-button-type 'sort-listed-character-sets
57 'help-echo (purecopy "mouse-2, RET: sort on this column")
58 'face 'bold
59 'action #'(lambda (button)
60 (sort-listed-character-sets (button-get button 'sort-key))))
61
62(define-button-type 'list-charset-chars
63 :supertype 'help-xref
64 'help-function #'list-charset-chars
65 'help-echo "mouse-2, RET: show table of characters for this character set")
66
18d6bb4e 67;;;###autoload
11896c0b 68(defvar non-iso-charset-alist
e1f973d4
DL		 69 `((mac-roman
70 (ascii latin-iso8859-1 mule-unicode-2500-33ff
71 mule-unicode-0100-24ff mule-unicode-e000-ffff)
72 mac-roman-decoder
73 ((0 255)))
74 (viscii
75 (ascii vietnamese-viscii-lower vietnamese-viscii-upper)
76 viet-viscii-nonascii-translation-table
77 ((0 255)))
78 (vietnamese-tcvn
79 (ascii vietnamese-viscii-lower vietnamese-viscii-upper)
80 viet-tcvn-nonascii-translation-table
81 ((0 255)))
82 (koi8-r
83 (ascii cyrillic-iso8859-5)
84 cyrillic-koi8-r-nonascii-translation-table
85 ((32 255)))
86 (alternativnyj
87 (ascii cyrillic-iso8859-5)
88 cyrillic-alternativnyj-nonascii-translation-table
89 ((32 255)))
90 (koi8-u
91 (ascii cyrillic-iso8859-5 mule-unicode-0100-24ff)
92 cyrillic-koi8-u-nonascii-translation-table
93 ((32 255)))
94 (big5
95 (ascii chinese-big5-1 chinese-big5-2)
96 decode-big5-char
97 ((32 127)
98 ((?\xA1 ?\xFE) . (?\x40 ?\x7E ?\xA1 ?\xFE))))
99 (sjis
100 (ascii katakana-jisx0201 japanese-jisx0208)
101 decode-sjis-char
102 ((32 127 ?\xA1 ?\xDF)
103 ((?\x81 ?\x9F ?\xE0 ?\xEF) . (?\x40 ?\x7E ?\x80 ?\xFC)))))
bfe77626
DL		 104 "Alist of charset names vs the corresponding information.
105This is mis-named for historical reasons. The charsets are actually
106non-built-in ones. They correspond to Emacs coding systems, not Emacs
107charsets, i.e. what Emacs can read (or write) by mapping to (or
108from) Emacs internal charsets that typically correspond to a limited
109set of ISO charsets.
110
111Each element has the following format:
112 (CHARSET CHARSET-LIST TRANSLATION-METHOD [ CODE-RANGE ])
113
114CHARSET is the name (symbol) of the charset.
115
116CHARSET-LIST is a list of Emacs charsets into which characters of
117CHARSET are mapped.
118
119TRANSLATION-METHOD is a translation table (symbol) to translate a
120character code of CHARSET to the corresponding Emacs character
121code. It can also be a function to call with one argument, a
122character code in CHARSET.
123
124CODE-RANGE specifies the valid code ranges of CHARSET.
125It is a list of RANGEs, where each RANGE is of the form:
126 (FROM1 TO1 FROM2 TO2 ...)
127or
128 ((FROM1-1 TO1-1 FROM1-2 TO1-2 ...) . (FROM2-1 TO2-1 FROM2-2 TO2-2 ...))
129In the first form, valid codes are between FROM1 and TO1, or FROM2 and
130TO2, or...
131The second form is used for 2-byte codes. The car part is the ranges
132of the first byte, and the cdr part is the ranges of the second byte.")
e8cdeaca 133
4ed46869 134;;;###autoload
efdd2d79 135(defun list-character-sets (arg)
4472a77b
KH		 136 "Display a list of all character sets.
137
7cc8aac3
PJ		 138The ID-NUM column contains a charset identification number for
139internal Emacs use.
efdd2d79 140
7cc8aac3
PJ		 141The MULTIBYTE-FORM column contains the format of the buffer and string
142multibyte sequence of characters in the charset using one to four
143hexadecimal digits.
efdd2d79
KH		 144 `xx' stands for any byte in the range 0..127.
145 `XX' stands for any byte in the range 160..255.
146
7cc8aac3
PJ		 147The D column contains the dimension of this character set. The CH
148column contains the number of characters in a block of this character
149set. The FINAL-CHAR column contains an ISO-2022 <final-char> to use
150for designating this character set in ISO-2022-based coding systems.
4472a77b 151
4527adca
KH		 152With prefix arg, the output format gets more cryptic,
153but still shows the full information."
4472a77b 154 (interactive "P")
55140940 155 (help-setup-xref (list #'list-character-sets arg) (interactive-p))
3aab6d06 156 (with-output-to-temp-buffer "*Character Set List*"
efdd2d79
KH		 157 (with-current-buffer standard-output
158 (if arg
159 (list-character-sets-2)
160 ;; Insert header.
6440b97c 161 (insert "Indirectly supported character sets are shown below.\n")
efdd2d79
KH		 162 (insert
163 (substitute-command-keys
e5b99cff
KH		 164 (concat "Use "
165 (if (display-mouse-p) "\\[help-follow-mouse] or ")
166 "\\[help-follow]:\n")))
167 (insert " on a column title to sort by that title,")
efdd2d79
KH		 168 (indent-to 56)
169 (insert "+----DIMENSION\n")
e5b99cff 170 (insert " on a charset name to list characters.")
efdd2d79
KH		 171 (indent-to 56)
172 (insert "| +--CHARS\n")
173 (let ((columns '(("ID-NUM" . id) "\t"
174 ("CHARSET-NAME" . name) "\t\t\t"
175 ("MULTIBYTE-FORM" . id) "\t"
176 ("D CH FINAL-CHAR" . iso-spec)))
efdd2d79
KH		 177 pos)
178 (while columns
179 (if (stringp (car columns))
180 (insert (car columns))
e8cdeaca
MB		 181 (insert-text-button (car (car columns))
182 :type 'sort-listed-character-sets
183 'sort-key (cdr (car columns)))
efdd2d79
KH		 184 (goto-char (point-max)))
185 (setq columns (cdr columns)))
186 (insert "\n"))
187 (insert "------\t------------\t\t\t--------------\t- -- ----------\n")
13cef08d 188
efdd2d79 189 ;; Insert body sorted by charset IDs.
6440b97c
KH		 190 (list-character-sets-1 'id)
191
192 ;; Insert non-directly-supported charsets.
193 (insert-char ?- 72)
194 (insert "\n\nINDIRECTLY SUPPORTED CHARSETS SETS:\n\n"
195 (propertize "CHARSET NAME\tMAPPED TO" 'face 'bold)
196 "\n------------\t---------\n")
197 (dolist (elt non-iso-charset-alist)
198 (insert-text-button (symbol-name (car elt))
199 :type 'list-charset-chars
200 'help-args (list (car elt)))
201 (indent-to 16)
202 (dolist (e (nth 1 elt))
203 (when (>= (+ (current-column) 1 (string-width (symbol-name e)))
204 ;; This is an approximate value. We don't know
205 ;; the correct window width of this buffer yet.
206 78)
207 (insert "\n")
208 (indent-to 16))
209
210 (insert (format "%s " e)))
211 (insert "\n"))))))
efdd2d79 212
efdd2d79
KH		 213(defun sort-listed-character-sets (sort-key)
214 (if sort-key
215 (save-excursion
55140940 216 (help-setup-xref (list #'list-character-sets nil) t)
efdd2d79
KH		 217 (let ((buffer-read-only nil))
218 (goto-char (point-min))
219 (re-search-forward "[0-9][0-9][0-9]")
220 (beginning-of-line)
6440b97c
KH		 221 (let ((pos (point)))
222 (search-forward "----------")
223 (beginning-of-line)
224 (save-restriction
225 (narrow-to-region pos (point))
226 (delete-region (point-min) (point-max))
227 (list-character-sets-1 sort-key)))))))
efdd2d79 228
a399ef7b
KH		 229(defun charset-multibyte-form-string (charset)
230 (let ((info (charset-info charset)))
231 (cond ((eq charset 'ascii)
232 "xx")
233 ((eq charset 'eight-bit-control)
234 (format "%2X Xx" (aref info 6)))
235 ((eq charset 'eight-bit-graphic)
236 "XX")
237 (t
238 (let ((str (format "%2X" (aref info 6))))
239 (if (> (aref info 7) 0)
240 (setq str (format "%s %2X"
241 str (aref info 7))))
242 (setq str (concat str " XX"))
243 (if (> (aref info 2) 1)
244 (setq str (concat str " XX")))
245 str)))))
246
efdd2d79
KH		 247;; Insert a list of character sets sorted by SORT-KEY. SORT-KEY
248;; should be one of `id', `name', and `iso-spec'. If SORT-KEY is nil,
249;; it defaults to `id'.
250
251(defun list-character-sets-1 (sort-key)
252 (or sort-key
253 (setq sort-key 'id))
254 (let ((tail (charset-list))
255 charset-info-list elt charset info sort-func)
256 (while tail
257 (setq charset (car tail) tail (cdr tail)
258 info (charset-info charset))
259
260 ;; Generate a list that contains all information to display.
261 (setq charset-info-list
262 (cons (list (charset-id charset) ; ID-NUM
263 charset ; CHARSET-NAME
a399ef7b 264 (charset-multibyte-form-string charset); MULTIBYTE-FORM
efdd2d79
KH		 265 (aref info 2) ; DIMENSION
266 (aref info 3) ; CHARS
267 (aref info 8) ; FINAL-CHAR
268 )
269 charset-info-list)))
270
271 ;; Determine a predicate for `sort' by SORT-KEY.
272 (setq sort-func
273 (cond ((eq sort-key 'id)
02e91426 274 (lambda (x y) (< (car x) (car y))))
efdd2d79
KH		 275
276 ((eq sort-key 'name)
02e91426 277 (lambda (x y) (string< (nth 1 x) (nth 1 y))))
efdd2d79
KH		 278
279 ((eq sort-key 'iso-spec)
280 ;; Sort by DIMENSION CHARS FINAL-CHAR
02e91426
SM		 281 (lambda (x y)
282 (or (< (nth 3 x) (nth 3 y))
283 (and (= (nth 3 x) (nth 3 y))
284 (or (< (nth 4 x) (nth 4 y))
285 (and (= (nth 4 x) (nth 4 y))
286 (< (nth 5 x) (nth 5 y))))))))
efdd2d79
KH		 287 (t
288 (error "Invalid charset sort key: %s" sort-key))))
289
290 (setq charset-info-list (sort charset-info-list sort-func))
291
292 ;; Insert information of character sets.
293 (while charset-info-list
294 (setq elt (car charset-info-list)
295 charset-info-list (cdr charset-info-list))
296 (insert (format "%03d(%02X)" (car elt) (car elt))) ; ID-NUM
297 (indent-to 8)
e8cdeaca
MB		 298 (insert-text-button (symbol-name (nth 1 elt))
299 :type 'list-charset-chars
300 'help-args (list (nth 1 elt)))
efdd2d79
KH		 301 (goto-char (point-max))
302 (insert "\t")
303 (indent-to 40)
304 (insert (nth 2 elt)) ; MULTIBYTE-FORM
305 (indent-to 56)
7d584ec4
KH		 306 (insert (format "%d %2d " (nth 3 elt) (nth 4 elt)) ; DIMENSION and CHARS
307 (if (< (nth 5 elt) 0) "none" (nth 5 elt))) ; FINAL-CHAR
efdd2d79
KH		 308 (insert "\n"))))
309
310
311;; List all character sets in a form that a program can easily parse.
312
313(defun list-character-sets-2 ()
314 (insert "#########################
4ed46869
KH		 315## LIST OF CHARSETS
316## Each line corresponds to one charset.
317## The following attributes are listed in this order
318## separated by a colon `:' in one line.
4ed46869 319## CHARSET-ID,
4472a77b 320## CHARSET-SYMBOL-NAME,
4ed46869
KH		 321## DIMENSION (1 or 2)
322## CHARS (94 or 96)
323## BYTES (of multibyte form: 1, 2, 3, or 4),
324## WIDTH (occupied column numbers: 1 or 2),
325## DIRECTION (0:left-to-right, 1:right-to-left),
326## ISO-FINAL-CHAR (character code of ISO-2022's final character)
327## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
328## DESCRIPTION (describing string of the charset)
329")
efdd2d79
KH		 330 (let ((l charset-list)
331 charset)
332 (while l
333 (setq charset (car l) l (cdr l))
187bd11c 334 (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
efdd2d79
KH		 335 (charset-id charset)
336 charset
337 (charset-dimension charset)
338 (charset-chars charset)
339 (charset-bytes charset)
340 (charset-width charset)
341 (charset-direction charset)
342 (charset-iso-final-char charset)
343 (charset-iso-graphic-plane charset)
344 (charset-description charset))))))
345
efdd2d79 346(defun decode-codepage-char (codepage code)
7cc8aac3
PJ		 347 "Decode a character that has code CODE in CODEPAGE.
348Return a decoded character string. Each CODEPAGE corresponds to a
349coding system cpCODEPAGE."
efdd2d79
KH		 350 (let ((coding-system (intern (format "cp%d" codepage))))
351 (or (coding-system-p coding-system)
352 (codepage-setup codepage))
353 (string-to-char
354 (decode-coding-string (char-to-string code) coding-system))))
355
efdd2d79
KH		 356;; A variable to hold charset input history.
357(defvar charset-history nil)
358
359
360;;;###autoload
361(defun read-charset (prompt &optional default-value initial-input)
362 "Read a character set from the minibuffer, prompting with string PROMPT.
7cc8aac3 363It must be an Emacs character set listed in the variable `charset-list'
efdd2d79
KH		 364or a non-ISO character set listed in the variable
365`non-iso-charset-alist'.
366
367Optional arguments are DEFAULT-VALUE and INITIAL-INPUT.
368DEFAULT-VALUE, if non-nil, is the default value.
369INITIAL-INPUT, if non-nil, is a string inserted in the minibuffer initially.
370See the documentation of the function `completing-read' for the
371detailed meanings of these arguments."
02e91426 372 (let* ((table (append (mapcar (lambda (x) (list (symbol-name x)))
efdd2d79 373 charset-list)
02e91426 374 (mapcar (lambda (x) (list (symbol-name (car x))))
efdd2d79
KH		 375 non-iso-charset-alist)))
376 (charset (completing-read prompt table
377 nil t initial-input 'charset-history
378 default-value)))
379 (if (> (length charset) 0)
380 (intern charset))))
187bd11c 381
efdd2d79
KH		 382
383;; List characters of the range MIN and MAX of CHARSET. If dimension
384;; of CHARSET is two (i.e. 2-byte charset), ROW is the first byte
385;; (block index) of the characters, and MIN and MAX are the second
386;; bytes of the characters. If the dimension is one, ROW should be 0.
04f63b87
KH		 387;; For a non-ISO charset, CHARSET is a translation table (symbol) or a
388;; function to get Emacs' character codes that corresponds to the
389;; characters to list.
efdd2d79
KH		 390
391(defun list-block-of-chars (charset row min max)
392 (let (i ch)
393 (insert-char ?- (+ 4 (* 3 16)))
394 (insert "\n ")
395 (setq i 0)
396 (while (< i 16)
397 (insert (format "%3X" i))
398 (setq i (1+ i)))
399 (setq i (* (/ min 16) 16))
400 (while (<= i max)
401 (if (= (% i 16) 0)
402 (insert (format "\n%3Xx" (/ (+ (* row 256) i) 16))))
403 (setq ch (cond ((< i min)
404 32)
405 ((charsetp charset)
406 (if (= row 0)
407 (make-char charset i)
408 (make-char charset row i)))
04f63b87
KH		 409 ((and (symbolp charset) (get charset 'translation-table))
410 (aref (get charset 'translation-table) i))
efdd2d79 411 (t (funcall charset (+ (* row 256) i)))))
7d584ec4
KH		 412 (if (and (char-table-p charset)
413 (or (< ch 32) (and (>= ch 127) (<= ch 255))))
efdd2d79
KH		 414 ;; Don't insert a control code.
415 (setq ch 32))
7cc8aac3
PJ		 416 (unless ch (setq ch 32))
417 (if (eq ch ?\t)
418 ;; Make it visible.
419 (setq ch (propertize "\t" 'display "^I")))
420 ;; This doesn't DTRT. Maybe it's better to insert "^J" and not
421 ;; worry about the buffer contents not being correct.
422;;; (if (eq ch ?\n)
423;;; (setq ch (propertize "\n" 'display "^J")))
7d584ec4
KH		 424 (indent-to (+ (* (% i 16) 3) 6))
425 (insert ch)
efdd2d79
KH		 426 (setq i (1+ i))))
427 (insert "\n"))
428
efdd2d79
KH		 429(defun list-iso-charset-chars (charset)
430 (let ((dim (charset-dimension charset))
431 (chars (charset-chars charset))
432 (plane (charset-iso-graphic-plane charset))
433 min max)
7cc8aac3 434 (insert (format "Characters in the coded character set %s.\n" charset))
efdd2d79 435
7d584ec4
KH		 436 (cond ((eq charset 'eight-bit-control)
437 (setq min 128 max 159))
438 ((eq charset 'eight-bit-graphic)
439 (setq min 160 max 255))
440 (t
441 (if (= chars 94)
442 (setq min 33 max 126)
443 (setq min 32 max 127))
444 (or (= plane 0)
445 (setq min (+ min 128) max (+ max 128)))))
efdd2d79
KH		 446
447 (if (= dim 1)
448 (list-block-of-chars charset 0 min max)
449 (let ((i min))
b3ce4863 450 (while (<= i max)
efdd2d79
KH		 451 (list-block-of-chars charset i min max)
452 (setq i (1+ i)))))))
453
efdd2d79 454(defun list-non-iso-charset-chars (charset)
7cc8aac3 455 "List all characters in non-built-in coded character set CHARSET."
efdd2d79
KH		 456 (let* ((slot (assq charset non-iso-charset-alist))
457 (charsets (nth 1 slot))
458 (translate-method (nth 2 slot))
459 (ranges (nth 3 slot))
460 range)
461 (or slot
7cc8aac3
PJ		 462 (error "Unknown character set: %s" charset))
463 (insert (format "Characters in the coded character set %s.\n" charset))
464 (if charsets
465 (insert "They are mapped to: "
466 (mapconcat #'symbol-name charsets ", ")
467 "\n"))
efdd2d79 468 (while ranges
7cc8aac3 469 (setq range (pop ranges))
efdd2d79
KH		 470 (if (integerp (car range))
471 ;; The form of RANGES is (FROM1 TO1 FROM2 TO2 ...).
7cc8aac3
PJ		 472 (if (and (not (functionp translate-method))
473 (< (car (last range)) 256))
474 ;; Do it all in one block to avoid the listing being
475 ;; broken up at gaps in the range. Don't do that for
476 ;; function translate-method, since not all codes in
477 ;; that range may be valid.
478 (list-block-of-chars translate-method
479 0 (car range) (car (last range)))
480 (while range
481 (list-block-of-chars translate-method
482 0 (car range) (nth 1 range))
483 (setq range (nthcdr 2 range))))
efdd2d79
KH		 484 ;; The form of RANGES is ((FROM1-1 TO1-1 ...) . (FROM2-1 TO2-1 ...)).
485 (let ((row-range (car range))
486 row row-max
487 col-range col col-max)
488 (while row-range
489 (setq row (car row-range) row-max (nth 1 row-range)
490 row-range (nthcdr 2 row-range))
b3ce4863 491 (while (<= row row-max)
efdd2d79
KH		 492 (setq col-range (cdr range))
493 (while col-range
494 (setq col (car col-range) col-max (nth 1 col-range)
495 col-range (nthcdr 2 col-range))
496 (list-block-of-chars translate-method row col col-max))
497 (setq row (1+ row)))))))))
498
499
500;;;###autoload
501(defun list-charset-chars (charset)
7cc8aac3
PJ		 502 "Display a list of characters in the specified character set.
503This can list both Emacs `official' (ISO standard) charsets and the
504characters encoded by various Emacs coding systems which correspond to
505PC `codepages' and other coded character sets. See `non-iso-charset-alist'."
efdd2d79 506 (interactive (list (read-charset "Character set: ")))
3aab6d06 507 (with-output-to-temp-buffer "*Character List*"
efdd2d79 508 (with-current-buffer standard-output
3aab6d06
KH		 509 (setq mode-line-format (copy-sequence mode-line-format))
510 (let ((slot (memq 'mode-line-buffer-identification mode-line-format)))
511 (if slot
512 (setcdr slot
513 (cons (format " (%s)" charset)
514 (cdr slot)))))
7cc8aac3 515 (setq indent-tabs-mode nil)
efdd2d79
KH		 516 (set-buffer-multibyte t)
517 (cond ((charsetp charset)
518 (list-iso-charset-chars charset))
519 ((assq charset non-iso-charset-alist)
520 (list-non-iso-charset-chars charset))
521 (t
7cc8aac3 522 (error "Invalid character set %s" charset))))))
efdd2d79 523
b1e3566c 524
a399ef7b
KH		 525;;;###autoload
526(defun describe-character-set (charset)
7cc8aac3 527 "Display information about built-in character set CHARSET."
a399ef7b
KH		 528 (interactive (list (let ((non-iso-charset-alist nil))
529 (read-charset "Charset: "))))
530 (or (charsetp charset)
531 (error "Invalid charset: %S" charset))
532 (let ((info (charset-info charset)))
55140940
SM		 533 (help-setup-xref (list #'describe-character-set charset) (interactive-p))
534 (with-output-to-temp-buffer (help-buffer)
535 (with-current-buffer standard-output
a399ef7b
KH		 536 (insert "Character set: " (symbol-name charset)
537 (format " (ID:%d)\n\n" (aref info 0)))
538 (insert (aref info 13) "\n\n") ; description
7cc8aac3 539 (insert "Number of contained characters: "
a399ef7b
KH		 540 (if (= (aref info 2) 1)
541 (format "%d\n" (aref info 3))
542 (format "%dx%d\n" (aref info 3) (aref info 3))))
7cc8aac3 543 (insert "Final char of ISO2022 designation sequence: ")
c7bf5db9 544 (if (>= (aref info 8) 0)
a399ef7b
KH		 545 (insert (format "`%c'\n" (aref info 8)))
546 (insert "not assigned\n"))
7cc8aac3 547 (insert (format "Width (how many columns on screen): %d\n"
a399ef7b 548 (aref info 4)))
7cc8aac3 549 (insert (format "Internal multibyte sequence: %s\n"
a399ef7b
KH		 550 (charset-multibyte-form-string charset)))
551 (let ((coding (plist-get (aref info 14) 'preferred-coding-system)))
552 (when coding
7cc8aac3 553 (insert (format "Preferred coding system: %s\n" coding))
a399ef7b 554 (search-backward (symbol-name coding))
6c78f23d 555 (help-xref-button 0 'help-coding-system coding)))))))
4ed46869
KH		 556\f
557;;; CODING-SYSTEM
558
559;; Print information of designation of each graphic register in FLAGS
560;; in human readable format. See the documentation of
561;; `make-coding-system' for the meaning of FLAGS.
562(defun print-designation (flags)
563 (let ((graphic-register 0)
564 charset)
565 (while (< graphic-register 4)
566 (setq charset (aref flags graphic-register))
567 (princ (format
568 " G%d -- %s\n"
569 graphic-register
570 (cond ((null charset)
571 "never used")
572 ((eq charset t)
573 "no initial designation, and used by any charsets")
574 ((symbolp charset)
575 (format "%s:%s"
576 charset (charset-description charset)))
577 ((listp charset)
578 (if (charsetp (car charset))
0a1a08dd 579 (format "%s:%s, and also used by the following:"
4ed46869
KH		 580 (car charset)
581 (charset-description (car charset)))
0a1a08dd 582 "no initial designation, and used by the following:"))
4ed46869
KH		 583 (t
584 "invalid designation information"))))
4472a77b
KH		 585 (when (listp charset)
586 (setq charset (cdr charset))
587 (while charset
588 (cond ((eq (car charset) t)
589 (princ "\tany other charsets\n"))
590 ((charsetp (car charset))
591 (princ (format "\t%s:%s\n"
592 (car charset)
593 (charset-description (car charset)))))
594 (t
187bd11c 595 "invalid designation information"))
4472a77b 596 (setq charset (cdr charset))))
4ed46869
KH		 597 (setq graphic-register (1+ graphic-register)))))
598
599;;;###autoload
600(defun describe-coding-system (coding-system)
4527adca 601 "Display information about CODING-SYSTEM."
5b76833f 602 (interactive "zDescribe coding system (default current choices): ")
426f97dc
KH		 603 (if (null coding-system)
604 (describe-current-coding-system)
55140940
SM		 605 (help-setup-xref (list #'describe-coding-system coding-system)
606 (interactive-p))
607 (with-output-to-temp-buffer (help-buffer)
426f97dc 608 (print-coding-system-briefly coding-system 'doc-string)
67ad2f93 609 (princ "\n")
8fdfd269
KH		 610 (let ((vars (coding-system-get coding-system 'dependency)))
611 (when vars
612 (princ "See also the documentation of these customizable variables
11896c0b 613which alter the behavior of this coding system.\n")
8fdfd269
KH		 614 (dolist (v vars)
615 (princ " `")
616 (princ v)
617 (princ "'\n"))
618 (princ "\n")))
619
02e91426
SM		 620 (princ "Type: ")
621 (let ((type (coding-system-type coding-system))
622 (flags (coding-system-flags coding-system)))
623 (princ type)
624 (cond ((eq type nil)
625 (princ " (do no conversion)"))
626 ((eq type t)
627 (princ " (do automatic conversion)"))
628 ((eq type 0)
629 (princ " (Emacs internal multibyte form)"))
630 ((eq type 1)
631 (princ " (Shift-JIS, MS-KANJI)"))
632 ((eq type 2)
633 (princ " (variant of ISO-2022)\n")
634 (princ "Initial designations:\n")
635 (print-designation flags)
636 (princ "Other Form: \n ")
637 (princ (if (aref flags 4) "short-form" "long-form"))
638 (if (aref flags 5) (princ ", ASCII@EOL"))
639 (if (aref flags 6) (princ ", ASCII@CNTL"))
640 (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
641 (if (aref flags 8) (princ ", use-locking-shift"))
642 (if (aref flags 9) (princ ", use-single-shift"))
643 (if (aref flags 10) (princ ", use-roman"))
644 (if (aref flags 11) (princ ", use-old-jis"))
645 (if (aref flags 12) (princ ", no-ISO6429"))
646 (if (aref flags 13) (princ ", init-bol"))
647 (if (aref flags 14) (princ ", designation-bol"))
648 (if (aref flags 15) (princ ", convert-unsafe"))
649 (if (aref flags 16) (princ ", accept-latin-extra-code"))
650 (princ "."))
651 ((eq type 3)
652 (princ " (Big5)"))
653 ((eq type 4)
654 (princ " (do conversion by CCL program)"))
655 ((eq type 5)
656 (princ " (text with random binary characters)"))
657 (t (princ ": invalid coding-system."))))
658 (princ "\nEOL type: ")
659 (let ((eol-type (coding-system-eol-type coding-system)))
660 (cond ((vectorp eol-type)
661 (princ "Automatic selection from:\n\t")
662 (princ eol-type)
663 (princ "\n"))
664 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
665 ((eq eol-type 1) (princ "CRLF\n"))
666 ((eq eol-type 2) (princ "CR\n"))
667 (t (princ "invalid\n"))))
ff8909d8
KH		 668 (let ((postread (coding-system-get coding-system 'post-read-conversion)))
669 (when postread
71527e5d
DL		 670 (princ "After decoding text normally,")
671 (princ " perform post-conversion using the function: ")
ff8909d8
KH		 672 (princ "\n ")
673 (princ postread)
674 (princ "\n")))
675 (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
676 (when prewrite
71527e5d
DL		 677 (princ "Before encoding text normally,")
678 (princ " perform pre-conversion using the function: ")
ff8909d8
KH		 679 (princ "\n ")
680 (princ prewrite)
681 (princ "\n")))
55140940 682 (with-current-buffer standard-output
a399ef7b 683 (let ((charsets (coding-system-get coding-system 'safe-charsets)))
97b14492
KH		 684 (when (and (not (memq (coding-system-base coding-system)
685 '(raw-text emacs-mule)))
686 charsets)
a399ef7b 687 (if (eq charsets t)
97b14492
KH		 688 (insert "This coding system can encode all charsets except for
689eight-bit-control and eight-bit-graphic.\n")
71527e5d 690 (insert "This coding system encodes the following charsets:\n ")
a399ef7b
KH		 691 (while charsets
692 (insert " " (symbol-name (car charsets)))
693 (search-backward (symbol-name (car charsets)))
e8cdeaca 694 (help-xref-button 0 'help-character-set (car charsets))
a399ef7b 695 (goto-char (point-max))
55140940 696 (setq charsets (cdr charsets))))))))))
a399ef7b 697
4ed46869
KH		 698
699;;;###autoload
700(defun describe-current-coding-system-briefly ()
795a5f84 701 "Display coding systems currently used in a brief format in echo area.
4ed46869 702
795a5f84 703The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
4ed46869 704where mnemonics of the following coding systems come in this order
7cc8aac3 705in place of `..':
187bd11c
SS		 706 `buffer-file-coding-system' (of the current buffer)
707 eol-type of `buffer-file-coding-system' (of the current buffer)
4527adca 708 Value returned by `keyboard-coding-system'
187bd11c
SS		 709 eol-type of `keyboard-coding-system'
710 Value returned by `terminal-coding-system'.
711 eol-type of `terminal-coding-system'
4527adca 712 `process-coding-system' for read (of the current buffer, if any)
187bd11c 713 eol-type of `process-coding-system' for read (of the current buffer, if any)
4527adca 714 `process-coding-system' for write (of the current buffer, if any)
187bd11c 715 eol-type of `process-coding-system' for write (of the current buffer, if any)
4527adca 716 `default-buffer-file-coding-system'
187bd11c 717 eol-type of `default-buffer-file-coding-system'
4527adca 718 `default-process-coding-system' for read
187bd11c 719 eol-type of `default-process-coding-system' for read
4527adca 720 `default-process-coding-system' for write
187bd11c 721 eol-type of `default-process-coding-system'"
4ed46869
KH		 722 (interactive)
723 (let* ((proc (get-buffer-process (current-buffer)))
724 (process-coding-systems (if proc (process-coding-system proc))))
725 (message
bb89cd2a 726 "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]"
4ed46869 727 (coding-system-mnemonic buffer-file-coding-system)
795a5f84 728 (coding-system-eol-type-mnemonic buffer-file-coding-system)
4ed46869 729 (coding-system-mnemonic (keyboard-coding-system))
795a5f84 730 (coding-system-eol-type-mnemonic (keyboard-coding-system))
4ed46869 731 (coding-system-mnemonic (terminal-coding-system))
795a5f84 732 (coding-system-eol-type-mnemonic (terminal-coding-system))
4ed46869 733 (coding-system-mnemonic (car process-coding-systems))
795a5f84 734 (coding-system-eol-type-mnemonic (car process-coding-systems))
4ed46869 735 (coding-system-mnemonic (cdr process-coding-systems))
795a5f84
KH		 736 (coding-system-eol-type-mnemonic (cdr process-coding-systems))
737 (coding-system-mnemonic default-buffer-file-coding-system)
738 (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
4ed46869 739 (coding-system-mnemonic (car default-process-coding-system))
795a5f84 740 (coding-system-eol-type-mnemonic (car default-process-coding-system))
4ed46869 741 (coding-system-mnemonic (cdr default-process-coding-system))
795a5f84 742 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
4ed46869
KH		 743 )))
744
4527adca 745;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
60b898c6
KH		 746;; If DOC-STRING is non-nil, print also the docstring of CODING-SYSTEM.
747;; If DOC-STRING is `tightly', don't print an empty line before the
748;; docstring, and print only the first line of the docstring.
749
426f97dc 750(defun print-coding-system-briefly (coding-system &optional doc-string)
795a5f84
KH		 751 (if (not coding-system)
752 (princ "nil\n")
753 (princ (format "%c -- %s"
754 (coding-system-mnemonic coding-system)
755 coding-system))
ff8909d8 756 (let ((aliases (coding-system-get coding-system 'alias-coding-systems)))
91e854f2
KH		 757 (cond ((eq coding-system (car aliases))
758 (if (cdr aliases)
759 (princ (format " %S" (cons 'alias: (cdr aliases))))))
760 ((memq coding-system aliases)
761 (princ (format " (alias of %s)" (car aliases))))
762 (t
763 (let ((eol-type (coding-system-eol-type coding-system))
764 (base-eol-type (coding-system-eol-type (car aliases))))
765 (if (and (integerp eol-type)
766 (vectorp base-eol-type)
767 (not (eq coding-system (aref base-eol-type eol-type))))
768 (princ (format " (alias of %s)"
769 (aref base-eol-type eol-type))))))))
60b898c6
KH		 770 (princ "\n")
771 (or (eq doc-string 'tightly)
772 (princ "\n"))
773 (if doc-string
774 (let ((doc (or (coding-system-doc-string coding-system) "")))
775 (when (eq doc-string 'tightly)
776 (if (string-match "\n" doc)
777 (setq doc (substring doc 0 (match-beginning 0))))
778 (setq doc (concat " " doc)))
779 (princ (format "%s\n" doc))))))
4ed46869
KH		 780
781;;;###autoload
782(defun describe-current-coding-system ()
4527adca 783 "Display coding systems currently used, in detail."
4ed46869
KH		 784 (interactive)
785 (with-output-to-temp-buffer "*Help*"
786 (let* ((proc (get-buffer-process (current-buffer)))
787 (process-coding-systems (if proc (process-coding-system proc))))
e72e91e9 788 (princ "Coding system for saving this buffer:\n ")
795a5f84
KH		 789 (if (local-variable-p 'buffer-file-coding-system)
790 (print-coding-system-briefly buffer-file-coding-system)
e72e91e9
RS		 791 (princ "Not set locally, use the default.\n"))
792 (princ "Default coding system (for new files):\n ")
795a5f84 793 (print-coding-system-briefly default-buffer-file-coding-system)
e72e91e9 794 (princ "Coding system for keyboard input:\n ")
4ed46869 795 (print-coding-system-briefly (keyboard-coding-system))
e72e91e9 796 (princ "Coding system for terminal output:\n ")
4ed46869 797 (print-coding-system-briefly (terminal-coding-system))
e72e91e9
RS		 798 (when (get-buffer-process (current-buffer))
799 (princ "Coding systems for process I/O:\n")
800 (princ " encoding input to the process: ")
801 (print-coding-system-briefly (cdr process-coding-systems))
802 (princ " decoding output from the process: ")
803 (print-coding-system-briefly (car process-coding-systems)))
1b76aedd 804 (princ "Defaults for subprocess I/O:\n")
795a5f84 805 (princ " decoding: ")
4ed46869 806 (print-coding-system-briefly (car default-process-coding-system))
795a5f84
KH		 807 (princ " encoding: ")
808 (print-coding-system-briefly (cdr default-process-coding-system)))
426f97dc 809
55140940 810 (with-current-buffer standard-output
426f97dc 811
7cc8aac3
PJ		 812 (princ "
813Priority order for recognizing coding systems when reading files:\n")
426f97dc
KH		 814 (let ((l coding-category-list)
815 (i 1)
5cfcd8bc 816 (coding-list nil)
426f97dc
KH		 817 coding aliases)
818 (while l
819 (setq coding (symbol-value (car l)))
ff8909d8 820 ;; Do not list up the same coding system twice.
2149d013 821 (when (and coding (not (memq coding coding-list)))
5cfcd8bc 822 (setq coding-list (cons coding coding-list))
ff8909d8
KH		 823 (princ (format " %d. %s " i coding))
824 (setq aliases (coding-system-get coding 'alias-coding-systems))
825 (if (eq coding (car aliases))
826 (if (cdr aliases)
827 (princ (cons 'alias: (cdr aliases))))
828 (if (memq coding aliases)
829 (princ (list 'alias 'of (car aliases)))))
5cfcd8bc
KH		 830 (terpri)
831 (setq i (1+ i)))
832 (setq l (cdr l))))
ff8909d8 833
426f97dc
KH		 834 (princ "\n Other coding systems cannot be distinguished automatically
835 from these, and therefore cannot be recognized automatically
836 with the present coding system priorities.\n\n")
837
b585fb6c 838 (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
426f97dc
KH		 839 coding-system codings)
840 (while categories
841 (setq coding-system (symbol-value (car categories)))
842 (mapcar
02e91426
SM		 843 (lambda (x)
844 (if (and (not (eq x coding-system))
845 (coding-system-get x 'no-initial-designation)
846 (let ((flags (coding-system-flags x)))
847 (not (or (aref flags 10) (aref flags 11)))))
848 (setq codings (cons x codings))))
426f97dc
KH		 849 (get (car categories) 'coding-systems))
850 (if codings
5307cb2e 851 (let ((max-col (window-width))
426f97dc 852 pos)
7cc8aac3
PJ		 853 (princ (format "\
854 The following are decoded correctly but recognized as %s:\n "
855 coding-system))
426f97dc
KH		 856 (while codings
857 (setq pos (point))
858 (insert (format " %s" (car codings)))
4472a77b
KH		 859 (when (> (current-column) max-col)
860 (goto-char pos)
861 (insert "\n ")
862 (goto-char (point-max)))
426f97dc
KH		 863 (setq codings (cdr codings)))
864 (insert "\n\n")))
865 (setq categories (cdr categories))))
866
e72e91e9 867 (princ "Particular coding systems specified for certain file names:\n")
426f97dc
KH		 868 (terpri)
869 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
870 (princ " ---------\t--------------\t\t----------------\n")
871 (let ((func (lambda (operation alist)
872 (princ " ")
873 (princ operation)
874 (if (not alist)
875 (princ "\tnothing specified\n")
876 (while alist
877 (indent-to 16)
878 (prin1 (car (car alist)))
ff8909d8
KH		 879 (if (>= (current-column) 40)
880 (newline))
426f97dc
KH		 881 (indent-to 40)
882 (princ (cdr (car alist)))
883 (princ "\n")
884 (setq alist (cdr alist)))))))
885 (funcall func "File I/O" file-coding-system-alist)
886 (funcall func "Process I/O" process-coding-system-alist)
887 (funcall func "Network I/O" network-coding-system-alist))
888 (help-mode))))
4ed46869
KH		 889
890;; Print detailed information on CODING-SYSTEM.
ff8909d8 891(defun print-coding-system (coding-system)
4ed46869 892 (let ((type (coding-system-type coding-system))
795a5f84
KH		 893 (eol-type (coding-system-eol-type coding-system))
894 (flags (coding-system-flags coding-system))
ff8909d8
KH		 895 (aliases (coding-system-get coding-system 'alias-coding-systems)))
896 (if (not (eq (car aliases) coding-system))
897 (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
795a5f84 898 (princ coding-system)
ff8909d8 899 (setq aliases (cdr aliases))
795a5f84 900 (while aliases
4472a77b
KH		 901 (princ ",")
902 (princ (car aliases))
903 (setq aliases (cdr aliases)))
795a5f84
KH		 904 (princ (format ":%s:%c:%d:"
905 type
906 (coding-system-mnemonic coding-system)
907 (if (integerp eol-type) eol-type 3)))
908 (cond ((eq type 2) ; ISO-2022
909 (let ((idx 0)
910 charset)
911 (while (< idx 4)
912 (setq charset (aref flags idx))
913 (cond ((null charset)
914 (princ -1))
915 ((eq charset t)
916 (princ -2))
917 ((charsetp charset)
918 (princ charset))
919 ((listp charset)
920 (princ "(")
4ed46869 921 (princ (car charset))
795a5f84
KH		 922 (setq charset (cdr charset))
923 (while charset
924 (princ ",")
925 (princ (car charset))
926 (setq charset (cdr charset)))
927 (princ ")")))
928 (princ ",")
929 (setq idx (1+ idx)))
930 (while (< idx 12)
931 (princ (if (aref flags idx) 1 0))
932 (princ ",")
933 (setq idx (1+ idx)))
934 (princ (if (aref flags idx) 1 0))))
935 ((eq type 4) ; CCL
936 (let (i len)
0d5f1e3a
RS		 937 (if (symbolp (car flags))
938 (princ (format " %s" (car flags)))
939 (setq i 0 len (length (car flags)))
940 (while (< i len)
941 (princ (format " %x" (aref (car flags) i)))
942 (setq i (1+ i))))
4ed46869 943 (princ ",")
0d5f1e3a
RS		 944 (if (symbolp (cdr flags))
945 (princ (format "%s" (cdr flags)))
946 (setq i 0 len (length (cdr flags)))
947 (while (< i len)
948 (princ (format " %x" (aref (cdr flags) i)))
949 (setq i (1+ i))))))
795a5f84
KH		 950 (t (princ 0)))
951 (princ ":")
952 (princ (coding-system-doc-string coding-system))
953 (princ "\n"))))
4ed46869 954
795a5f84 955;;;###autoload
4472a77b
KH		 956(defun list-coding-systems (&optional arg)
957 "Display a list of all coding systems.
4527adca 958This shows the mnemonic letter, name, and description of each coding system.
4472a77b
KH		 959
960With prefix arg, the output format gets more cryptic,
4527adca 961but still contains full information about each coding system."
4472a77b 962 (interactive "P")
4ed46869 963 (with-output-to-temp-buffer "*Help*"
13cef08d
KH		 964 (list-coding-systems-1 arg)))
965
966(defun list-coding-systems-1 (arg)
967 (if (null arg)
968 (princ "\
795a5f84
KH		 969###############################################
970# List of coding systems in the following format:
971# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
60b898c6 972# DOC-STRING
795a5f84 973")
13cef08d 974 (princ "\
4ed46869
KH		 975#########################
976## LIST OF CODING SYSTEMS
977## Each line corresponds to one coding system
978## Format of a line is:
795a5f84
KH		 979## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
980## :PRE-WRITE-CONVERSION:DOC-STRING,
4ed46869 981## where
795a5f84
KH		 982## NAME = coding system name
983## ALIAS = alias of the coding system
984## TYPE = nil (no conversion), t (undecided or automatic detection),
985## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
4ed46869
KH		 986## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
987## FLAGS =
988## if TYPE = 2 then
0a1a08dd 989## comma (`,') separated data of the following:
4ed46869
KH		 990## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
991## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
992## else if TYPE = 4 then
993## comma (`,') separated CCL programs for read and write
994## else
995## 0
795a5f84 996## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
4ed46869 997##
795a5f84 998"))
60b898c6
KH		 999 (dolist (coding-system (sort-coding-systems (coding-system-list 'base-only)))
1000 (if (null arg)
1001 (print-coding-system-briefly coding-system 'tightly)
a7832266
KH		 1002 (print-coding-system coding-system)))
1003 (let ((first t))
1004 (dolist (elt coding-system-alist)
1005 (unless (memq (intern (car elt)) coding-system-list)
1006 (when first
1007 (princ "\
1008####################################################
1009# The following coding systems are not yet loaded. #
1010####################################################
1011")
1012 (setq first nil))
1013 (princ-list (car elt))))))
4472a77b 1014
867ef43a 1015;;;###autoload
4472a77b
KH		 1016(defun list-coding-categories ()
1017 "Display a list of all coding categories."
1018 (with-output-to-temp-buffer "*Help*"
1019 (princ "\
4ed46869
KH		 1020############################
1021## LIST OF CODING CATEGORIES (ordered by priority)
1022## CATEGORY:CODING-SYSTEM
1023##
1024")
4472a77b
KH		 1025 (let ((l coding-category-list))
1026 (while l
1027 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
1028 (setq l (cdr l))))))
4ed46869
KH		 1029\f
1030;;; FONT
1031
1032;; Print information of a font in FONTINFO.
1033(defun describe-font-internal (font-info &optional verbose)
1034 (print-list "name (opened by):" (aref font-info 0))
1035 (print-list " full name:" (aref font-info 1))
b1e3566c
KH		 1036 (print-list " size:" (format "%2d" (aref font-info 2)))
1037 (print-list " height:" (format "%2d" (aref font-info 3)))
1038 (print-list " baseline-offset:" (format "%2d" (aref font-info 4)))
1039 (print-list "relative-compose:" (format "%2d" (aref font-info 5))))
4ed46869
KH		 1040
1041;;;###autoload
1042(defun describe-font (fontname)
fca31fbb
KH		 1043 "Display information about a font whose name is FONTNAME.
1044The font must be already used by Emacs."
1045 (interactive "sFont name (default current choice for ASCII chars): ")
ee5f768d 1046 (or (and window-system (fboundp 'fontset-list))
fca31fbb
KH		 1047 (error "No fonts being used"))
1048 (let (fontset font-info)
1049 (when (or (not fontname) (= (length fontname) 0))
1050 (setq fontname (frame-parameter nil 'font))
1051 ;; Check if FONTNAME is a fontset.
1052 (if (query-fontset fontname)
1053 (setq fontset fontname
1054 fontname (nth 1 (assq 'ascii
1055 (aref (fontset-info fontname) 2))))))
1056 (setq font-info (font-info fontname))
4ed46869 1057 (if (null font-info)
fca31fbb
KH		 1058 (if fontset
1059 ;; The font should be surely used. So, there's some
1060 ;; problem about getting information about it. It is
1061 ;; better to print the fontname to show which font has
1062 ;; this problem.
1063 (message "No information about \"%s\"" fontname)
1064 (message "No matching font being used"))
4ed46869
KH		 1065 (with-output-to-temp-buffer "*Help*"
1066 (describe-font-internal font-info 'verbose)))))
1067
4472a77b 1068(defun print-fontset (fontset &optional print-fonts)
7cc8aac3 1069 "Print information about FONTSET.
c0e70a9f 1070If FONTSET is nil, print information about the default fontset.
7cc8aac3
PJ		 1071If optional arg PRINT-FONTS is non-nil, also print names of all opened
1072fonts for FONTSET. This function actually inserts the information in
1073the current buffer."
c0e70a9f
KH		 1074 (or fontset
1075 (setq fontset (query-fontset "fontset-default")))
3e8017d2 1076 (let ((tail (aref (fontset-info fontset) 2))
b1e3566c 1077 elt chars font-spec opened prev-charset charset from to)
4472a77b 1078 (beginning-of-line)
b1e3566c
KH		 1079 (insert "Fontset: " fontset "\n")
1080 (insert "CHARSET or CHAR RANGE")
55bab388 1081 (indent-to 24)
b1e3566c
KH		 1082 (insert "FONT NAME\n")
1083 (insert "---------------------")
55bab388 1084 (indent-to 24)
b1e3566c
KH		 1085 (insert "---------")
1086 (insert "\n")
1087 (while tail
1088 (setq elt (car tail) tail (cdr tail))
1089 (setq chars (car elt) font-spec (car (cdr elt)) opened (cdr (cdr elt)))
1090 (if (symbolp chars)
1091 (setq charset chars from nil to nil)
1092 (if (integerp chars)
1093 (setq charset (char-charset chars) from chars to chars)
1094 (setq charset (char-charset (car chars))
1095 from (car chars) to (cdr chars))))
1096 (unless (eq charset prev-charset)
1097 (insert (symbol-name charset))
1098 (if from
1099 (insert "\n")))
1100 (when from
1101 (let ((split (split-char from)))
1102 (if (and (= (charset-dimension charset) 2)
1103 (= (nth 2 split) 0))
1104 (setq from
1105 (make-char charset (nth 1 split)
1106 (if (= (charset-chars charset) 94) 33 32))))
1107 (insert " " from))
1108 (when (/= from to)
1109 (insert "-")
1110 (let ((split (split-char to)))
1111 (if (and (= (charset-dimension charset) 2)
1112 (= (nth 2 split) 0))
1113 (setq to
1114 (make-char charset (nth 1 split)
1115 (if (= (charset-chars charset) 94) 126 127))))
1116 (insert to))))
55bab388 1117 (indent-to 24)
b1e3566c
KH		 1118 (if (stringp font-spec)
1119 (insert font-spec)
1120 (if (car font-spec)
1121 (if (string-match "-" (car font-spec))
cebefb44
KH		 1122 (insert "-" (car font-spec) "-*-")
1123 (insert "-*-" (car font-spec) "-*-"))
b1e3566c
KH		 1124 (insert "-*-"))
1125 (if (cdr font-spec)
1126 (if (string-match "-" (cdr font-spec))
1127 (insert (cdr font-spec))
1128 (insert (cdr font-spec) "-*"))
1129 (insert "*")))
1130 (insert "\n")
1131 (when print-fonts
1132 (while opened
1133 (indent-to 5)
1134 (insert "[" (car opened) "]\n")
1135 (setq opened (cdr opened))))
1136 (setq prev-charset charset)
1137 )))
4ed46869
KH		 1138
1139;;;###autoload
1140(defun describe-fontset (fontset)
7cc8aac3 1141 "Display information about FONTSET.
b1e3566c 1142This shows which font is used for which character(s)."
4ed46869 1143 (interactive
ee5f768d 1144 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 1145 (error "No fontsets being used")
71527e5d 1146 (let ((fontset-list (nconc
f95b7b89
SM		 1147 (fontset-list)
1148 (mapcar 'cdr fontset-alias-alist)))
4472a77b
KH		 1149 (completion-ignore-case t))
1150 (list (completing-read
5b76833f 1151 "Fontset (default used by the current frame): "
4472a77b
KH		 1152 fontset-list nil t)))))
1153 (if (= (length fontset) 0)
c0e70a9f
KH		 1154 (setq fontset (frame-parameter nil 'font)))
1155 (setq fontset (query-fontset fontset))
55140940
SM		 1156 (help-setup-xref (list #'describe-fontset fontset) (interactive-p))
1157 (with-output-to-temp-buffer (help-buffer)
1158 (with-current-buffer standard-output
b1e3566c 1159 (print-fontset fontset t))))
4472a77b
KH		 1160
1161;;;###autoload
1162(defun list-fontsets (arg)
1163 "Display a list of all fontsets.
4527adca 1164This shows the name, size, and style of each fontset.
7cc8aac3 1165With prefix arg, also list the fonts contained in each fontset;
4527adca 1166see the function `describe-fontset' for the format of the list."
4472a77b 1167 (interactive "P")
ee5f768d 1168 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 1169 (error "No fontsets being used")
55140940
SM		 1170 (help-setup-xref (list #'list-fontsets arg) (interactive-p))
1171 (with-output-to-temp-buffer (help-buffer)
1172 (with-current-buffer standard-output
13cef08d 1173 ;; This code is duplicated near the end of mule-diag.
dc1f8c72
KH		 1174 (let ((fontsets
1175 (sort (fontset-list)
02e91426
SM		 1176 (lambda (x y)
1177 (string< (fontset-plain-name x)
1178 (fontset-plain-name y))))))
effd4e82 1179 (while fontsets
b1e3566c
KH		 1180 (if arg
1181 (print-fontset (car fontsets) nil)
1182 (insert "Fontset: " (car fontsets) "\n"))
effd4e82 1183 (setq fontsets (cdr fontsets))))))))
426f97dc
KH		 1184\f
1185;;;###autoload
1186(defun list-input-methods ()
4527adca 1187 "Display information about all input methods."
426f97dc 1188 (interactive)
02e91426
SM		 1189 (help-setup-xref '(list-input-methods) (interactive-p))
1190 (with-output-to-temp-buffer (help-buffer)
7cc8aac3
PJ		 1191 (list-input-methods-1)
1192 (with-current-buffer standard-output
1193 (save-excursion
1194 (goto-char (point-min))
1195 (while (re-search-forward
1196 "^ \\([^ ]+\\) (`.*' in mode line)$" nil t)
ee592269 1197 (help-xref-button 1 'help-input-method (match-string 1)))))))
13cef08d
KH		 1198
1199(defun list-input-methods-1 ()
1200 (if (not input-method-alist)
1201 (progn
1202 (princ "
10de7378
PJ		 1203No input method is available, perhaps because you have not
1204installed LEIM (Libraries of Emacs Input Methods)."))
13cef08d
KH		 1205 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
1206 (princ " SHORT-DESCRIPTION\n------------------------------\n")
1207 (setq input-method-alist
1208 (sort input-method-alist
02e91426 1209 (lambda (x y) (string< (nth 1 x) (nth 1 y)))))
13cef08d
KH		 1210 (let ((l input-method-alist)
1211 language elt)
1212 (while l
1213 (setq elt (car l) l (cdr l))
1214 (when (not (equal language (nth 1 elt)))
1215 (setq language (nth 1 elt))
1216 (princ language)
1217 (terpri))
1218 (princ (format " %s (`%s' in mode line)\n %s\n"
1219 (car elt)
1220 (let ((title (nth 3 elt)))
1221 (if (and (consp title) (stringp (car title)))
1222 (car title)
1223 title))
1224 (let ((description (nth 4 elt)))
1225 (string-match ".*" description)
1226 (match-string 0 description))))))))
4ed46869
KH		 1227\f
1228;;; DIAGNOSIS
1229
4472a77b
KH		 1230;; Insert a header of a section with SECTION-NUMBER and TITLE.
1231(defun insert-section (section-number title)
4ed46869 1232 (insert "########################################\n"
4472a77b 1233 "# Section " (format "%d" section-number) ". " title "\n"
4ed46869
KH		 1234 "########################################\n\n"))
1235
1236;;;###autoload
1237(defun mule-diag ()
3fdaafa6 1238 "Display diagnosis of the multilingual environment (Mule).
4472a77b 1239
4527adca 1240This shows various information related to the current multilingual
4472a77b 1241environment, including lists of input methods, coding systems,
4527adca 1242character sets, and fontsets (if Emacs is running under a window
effd4e82 1243system which uses fontsets)."
4ed46869 1244 (interactive)
4472a77b 1245 (with-output-to-temp-buffer "*Mule-Diagnosis*"
55140940 1246 (with-current-buffer standard-output
13cef08d
KH		 1247 (insert "###############################################\n"
1248 "### Current Status of Multilingual Features ###\n"
1249 "###############################################\n\n"
4ed46869
KH		 1250 "CONTENTS: Section 1. General Information\n"
1251 " Section 2. Display\n"
1252 " Section 3. Input methods\n"
1253 " Section 4. Coding systems\n"
4472a77b 1254 " Section 5. Character sets\n")
ee5f768d 1255 (if (and window-system (fboundp 'fontset-list))
4472a77b 1256 (insert " Section 6. Fontsets\n"))
4ed46869
KH		 1257 (insert "\n")
1258
1259 (insert-section 1 "General Information")
7bce107c 1260 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
cbbe6489
KH		 1261 (insert "Configuration options:\n " system-configuration-options "\n\n")
1262 (insert "Multibyte characters awareness:\n"
1263 (format " default: %S\n" default-enable-multibyte-characters)
1264 (format " current-buffer: %S\n\n" enable-multibyte-characters))
1265 (insert "Current language environment: " current-language-environment
1266 "\n\n")
4ed46869
KH		 1267
1268 (insert-section 2 "Display")
1269 (if window-system
1270 (insert "Window-system: "
1271 (symbol-name window-system)
1272 (format "%s" window-system-version))
1273 (insert "Terminal: " (getenv "TERM")))
1274 (insert "\n\n")
1275
1276 (if (eq window-system 'x)
1277 (let ((font (cdr (assq 'font (frame-parameters)))))
1278 (insert "The selected frame is using the "
1279 (if (query-fontset font) "fontset" "font")
1280 ":\n\t" font))
1281 (insert "Coding system of the terminal: "
1282 (symbol-name (terminal-coding-system))))
1283 (insert "\n\n")
1284
1285 (insert-section 3 "Input methods")
13cef08d 1286 (list-input-methods-1)
4ed46869
KH		 1287 (insert "\n")
1288 (if default-input-method
d4b11c67 1289 (insert (format "Default input method: %s\n" default-input-method))
1b76aedd 1290 (insert "No default input method is specified\n"))
4ed46869
KH		 1291
1292 (insert-section 4 "Coding systems")
13cef08d
KH		 1293 (list-coding-systems-1 t)
1294 (princ "\
1295############################
1296## LIST OF CODING CATEGORIES (ordered by priority)
1297## CATEGORY:CODING-SYSTEM
1298##
1299")
1300 (let ((l coding-category-list))
1301 (while l
1302 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
1303 (setq l (cdr l))))
4ed46869
KH		 1304 (insert "\n")
1305
4472a77b 1306 (insert-section 5 "Character sets")
efdd2d79 1307 (list-character-sets-2)
4ed46869
KH		 1308 (insert "\n")
1309
ee5f768d 1310 (when (and window-system (fboundp 'fontset-list))
13cef08d 1311 ;; This code duplicates most of list-fontsets.
4472a77b 1312 (insert-section 6 "Fontsets")
13cef08d
KH		 1313 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
1314 (insert "------------\t\t\t\t\t\t ----- -----\n")
1315 (let ((fontsets (fontset-list)))
1316 (while fontsets
1317 (print-fontset (car fontsets) t)
1318 (setq fontsets (cdr fontsets)))))
eabe0ad3 1319 (print-help-return-message))))
4ed46869 1320
bfe77626
DL		 1321(provide 'mule-diag)
1322
ab5796a9 1323;;; arch-tag: cd3b607c-2893-45a0-a4fa-a6535754dbee
795a5f84 1324;;; mule-diag.el ends here
Unnamed repository; edit this file 'description' to name the repository.