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