HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix previous change.
[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
e1f973d4
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)))
75 (vietnamese-tcvn
76 (ascii vietnamese-viscii-lower vietnamese-viscii-upper)
77 viet-tcvn-nonascii-translation-table
78 ((0 255)))
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)))))
bfe77626
DL		 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
efdd2d79
KH		 353;; A variable to hold charset input history.
354(defvar charset-history nil)
355
356
357;;;###autoload
358(defun read-charset (prompt &optional default-value initial-input)
359 "Read a character set from the minibuffer, prompting with string PROMPT.
7cc8aac3 360It must be an Emacs character set listed in the variable `charset-list'
efdd2d79
KH		 361or a non-ISO character set listed in the variable
362`non-iso-charset-alist'.
363
364Optional arguments are DEFAULT-VALUE and INITIAL-INPUT.
365DEFAULT-VALUE, if non-nil, is the default value.
366INITIAL-INPUT, if non-nil, is a string inserted in the minibuffer initially.
367See the documentation of the function `completing-read' for the
368detailed meanings of these arguments."
02e91426 369 (let* ((table (append (mapcar (lambda (x) (list (symbol-name x)))
efdd2d79 370 charset-list)
02e91426 371 (mapcar (lambda (x) (list (symbol-name (car x))))
efdd2d79
KH		 372 non-iso-charset-alist)))
373 (charset (completing-read prompt table
374 nil t initial-input 'charset-history
375 default-value)))
376 (if (> (length charset) 0)
377 (intern charset))))
187bd11c 378
efdd2d79
KH		 379
380;; List characters of the range MIN and MAX of CHARSET. If dimension
381;; of CHARSET is two (i.e. 2-byte charset), ROW is the first byte
382;; (block index) of the characters, and MIN and MAX are the second
383;; bytes of the characters. If the dimension is one, ROW should be 0.
04f63b87
KH		 384;; For a non-ISO charset, CHARSET is a translation table (symbol) or a
385;; function to get Emacs' character codes that corresponds to the
386;; characters to list.
efdd2d79
KH		 387
388(defun list-block-of-chars (charset row min max)
389 (let (i ch)
390 (insert-char ?- (+ 4 (* 3 16)))
391 (insert "\n ")
392 (setq i 0)
393 (while (< i 16)
394 (insert (format "%3X" i))
395 (setq i (1+ i)))
396 (setq i (* (/ min 16) 16))
397 (while (<= i max)
398 (if (= (% i 16) 0)
399 (insert (format "\n%3Xx" (/ (+ (* row 256) i) 16))))
400 (setq ch (cond ((< i min)
401 32)
402 ((charsetp charset)
403 (if (= row 0)
404 (make-char charset i)
405 (make-char charset row i)))
04f63b87
KH		 406 ((and (symbolp charset) (get charset 'translation-table))
407 (aref (get charset 'translation-table) i))
efdd2d79 408 (t (funcall charset (+ (* row 256) i)))))
7d584ec4
KH		 409 (if (and (char-table-p charset)
410 (or (< ch 32) (and (>= ch 127) (<= ch 255))))
efdd2d79
KH		 411 ;; Don't insert a control code.
412 (setq ch 32))
7cc8aac3
PJ		 413 (unless ch (setq ch 32))
414 (if (eq ch ?\t)
415 ;; Make it visible.
416 (setq ch (propertize "\t" 'display "^I")))
417 ;; This doesn't DTRT. Maybe it's better to insert "^J" and not
418 ;; worry about the buffer contents not being correct.
419;;; (if (eq ch ?\n)
420;;; (setq ch (propertize "\n" 'display "^J")))
7d584ec4
KH		 421 (indent-to (+ (* (% i 16) 3) 6))
422 (insert ch)
efdd2d79
KH		 423 (setq i (1+ i))))
424 (insert "\n"))
425
efdd2d79
KH		 426(defun list-iso-charset-chars (charset)
427 (let ((dim (charset-dimension charset))
428 (chars (charset-chars charset))
429 (plane (charset-iso-graphic-plane charset))
430 min max)
7cc8aac3 431 (insert (format "Characters in the coded character set %s.\n" charset))
efdd2d79 432
7d584ec4
KH		 433 (cond ((eq charset 'eight-bit-control)
434 (setq min 128 max 159))
435 ((eq charset 'eight-bit-graphic)
436 (setq min 160 max 255))
437 (t
438 (if (= chars 94)
439 (setq min 33 max 126)
440 (setq min 32 max 127))
441 (or (= plane 0)
442 (setq min (+ min 128) max (+ max 128)))))
efdd2d79
KH		 443
444 (if (= dim 1)
445 (list-block-of-chars charset 0 min max)
446 (let ((i min))
b3ce4863 447 (while (<= i max)
efdd2d79
KH		 448 (list-block-of-chars charset i min max)
449 (setq i (1+ i)))))))
450
efdd2d79 451(defun list-non-iso-charset-chars (charset)
7cc8aac3 452 "List all characters in non-built-in coded character set CHARSET."
efdd2d79
KH		 453 (let* ((slot (assq charset non-iso-charset-alist))
454 (charsets (nth 1 slot))
455 (translate-method (nth 2 slot))
456 (ranges (nth 3 slot))
457 range)
458 (or slot
7cc8aac3
PJ		 459 (error "Unknown character set: %s" charset))
460 (insert (format "Characters in the coded character set %s.\n" charset))
461 (if charsets
462 (insert "They are mapped to: "
463 (mapconcat #'symbol-name charsets ", ")
464 "\n"))
efdd2d79 465 (while ranges
7cc8aac3 466 (setq range (pop ranges))
efdd2d79
KH		 467 (if (integerp (car range))
468 ;; The form of RANGES is (FROM1 TO1 FROM2 TO2 ...).
7cc8aac3
PJ		 469 (if (and (not (functionp translate-method))
470 (< (car (last range)) 256))
471 ;; Do it all in one block to avoid the listing being
472 ;; broken up at gaps in the range. Don't do that for
473 ;; function translate-method, since not all codes in
474 ;; that range may be valid.
475 (list-block-of-chars translate-method
476 0 (car range) (car (last range)))
477 (while range
478 (list-block-of-chars translate-method
479 0 (car range) (nth 1 range))
480 (setq range (nthcdr 2 range))))
efdd2d79
KH		 481 ;; The form of RANGES is ((FROM1-1 TO1-1 ...) . (FROM2-1 TO2-1 ...)).
482 (let ((row-range (car range))
483 row row-max
484 col-range col col-max)
485 (while row-range
486 (setq row (car row-range) row-max (nth 1 row-range)
487 row-range (nthcdr 2 row-range))
b3ce4863 488 (while (<= row row-max)
efdd2d79
KH		 489 (setq col-range (cdr range))
490 (while col-range
491 (setq col (car col-range) col-max (nth 1 col-range)
492 col-range (nthcdr 2 col-range))
493 (list-block-of-chars translate-method row col col-max))
494 (setq row (1+ row)))))))))
495
496
497;;;###autoload
498(defun list-charset-chars (charset)
7cc8aac3
PJ		 499 "Display a list of characters in the specified character set.
500This can list both Emacs `official' (ISO standard) charsets and the
501characters encoded by various Emacs coding systems which correspond to
502PC `codepages' and other coded character sets. See `non-iso-charset-alist'."
efdd2d79 503 (interactive (list (read-charset "Character set: ")))
3aab6d06 504 (with-output-to-temp-buffer "*Character List*"
efdd2d79 505 (with-current-buffer standard-output
3aab6d06
KH		 506 (setq mode-line-format (copy-sequence mode-line-format))
507 (let ((slot (memq 'mode-line-buffer-identification mode-line-format)))
508 (if slot
509 (setcdr slot
510 (cons (format " (%s)" charset)
511 (cdr slot)))))
7cc8aac3 512 (setq indent-tabs-mode nil)
efdd2d79
KH		 513 (set-buffer-multibyte t)
514 (cond ((charsetp charset)
515 (list-iso-charset-chars charset))
516 ((assq charset non-iso-charset-alist)
517 (list-non-iso-charset-chars charset))
518 (t
7cc8aac3 519 (error "Invalid character set %s" charset))))))
efdd2d79 520
b1e3566c 521
a399ef7b
KH		 522;;;###autoload
523(defun describe-character-set (charset)
7cc8aac3 524 "Display information about built-in character set CHARSET."
a399ef7b
KH		 525 (interactive (list (let ((non-iso-charset-alist nil))
526 (read-charset "Charset: "))))
527 (or (charsetp charset)
528 (error "Invalid charset: %S" charset))
529 (let ((info (charset-info charset)))
55140940
SM		 530 (help-setup-xref (list #'describe-character-set charset) (interactive-p))
531 (with-output-to-temp-buffer (help-buffer)
532 (with-current-buffer standard-output
a399ef7b
KH		 533 (insert "Character set: " (symbol-name charset)
534 (format " (ID:%d)\n\n" (aref info 0)))
535 (insert (aref info 13) "\n\n") ; description
7cc8aac3 536 (insert "Number of contained characters: "
a399ef7b
KH		 537 (if (= (aref info 2) 1)
538 (format "%d\n" (aref info 3))
539 (format "%dx%d\n" (aref info 3) (aref info 3))))
7cc8aac3 540 (insert "Final char of ISO2022 designation sequence: ")
c7bf5db9 541 (if (>= (aref info 8) 0)
a399ef7b
KH		 542 (insert (format "`%c'\n" (aref info 8)))
543 (insert "not assigned\n"))
7cc8aac3 544 (insert (format "Width (how many columns on screen): %d\n"
a399ef7b 545 (aref info 4)))
7cc8aac3 546 (insert (format "Internal multibyte sequence: %s\n"
a399ef7b
KH		 547 (charset-multibyte-form-string charset)))
548 (let ((coding (plist-get (aref info 14) 'preferred-coding-system)))
549 (when coding
7cc8aac3 550 (insert (format "Preferred coding system: %s\n" coding))
a399ef7b 551 (search-backward (symbol-name coding))
6c78f23d 552 (help-xref-button 0 'help-coding-system coding)))))))
4ed46869
KH		 553\f
554;;; CODING-SYSTEM
555
556;; Print information of designation of each graphic register in FLAGS
557;; in human readable format. See the documentation of
558;; `make-coding-system' for the meaning of FLAGS.
559(defun print-designation (flags)
560 (let ((graphic-register 0)
561 charset)
562 (while (< graphic-register 4)
563 (setq charset (aref flags graphic-register))
564 (princ (format
565 " G%d -- %s\n"
566 graphic-register
567 (cond ((null charset)
568 "never used")
569 ((eq charset t)
570 "no initial designation, and used by any charsets")
571 ((symbolp charset)
572 (format "%s:%s"
573 charset (charset-description charset)))
574 ((listp charset)
575 (if (charsetp (car charset))
0a1a08dd 576 (format "%s:%s, and also used by the following:"
4ed46869
KH		 577 (car charset)
578 (charset-description (car charset)))
0a1a08dd 579 "no initial designation, and used by the following:"))
4ed46869
KH		 580 (t
581 "invalid designation information"))))
4472a77b
KH		 582 (when (listp charset)
583 (setq charset (cdr charset))
584 (while charset
585 (cond ((eq (car charset) t)
586 (princ "\tany other charsets\n"))
587 ((charsetp (car charset))
588 (princ (format "\t%s:%s\n"
589 (car charset)
590 (charset-description (car charset)))))
591 (t
187bd11c 592 "invalid designation information"))
4472a77b 593 (setq charset (cdr charset))))
4ed46869
KH		 594 (setq graphic-register (1+ graphic-register)))))
595
596;;;###autoload
597(defun describe-coding-system (coding-system)
4527adca 598 "Display information about CODING-SYSTEM."
426f97dc
KH		 599 (interactive "zDescribe coding system (default, current choices): ")
600 (if (null coding-system)
601 (describe-current-coding-system)
55140940
SM		 602 (help-setup-xref (list #'describe-coding-system coding-system)
603 (interactive-p))
604 (with-output-to-temp-buffer (help-buffer)
426f97dc 605 (print-coding-system-briefly coding-system 'doc-string)
67ad2f93 606 (princ "\n")
8fdfd269
KH		 607 (let ((vars (coding-system-get coding-system 'dependency)))
608 (when vars
609 (princ "See also the documentation of these customizable variables
610which alter the behaviour of this coding system.\n")
611 (dolist (v vars)
612 (princ " `")
613 (princ v)
614 (princ "'\n"))
615 (princ "\n")))
616
02e91426
SM		 617 (princ "Type: ")
618 (let ((type (coding-system-type coding-system))
619 (flags (coding-system-flags coding-system)))
620 (princ type)
621 (cond ((eq type nil)
622 (princ " (do no conversion)"))
623 ((eq type t)
624 (princ " (do automatic conversion)"))
625 ((eq type 0)
626 (princ " (Emacs internal multibyte form)"))
627 ((eq type 1)
628 (princ " (Shift-JIS, MS-KANJI)"))
629 ((eq type 2)
630 (princ " (variant of ISO-2022)\n")
631 (princ "Initial designations:\n")
632 (print-designation flags)
633 (princ "Other Form: \n ")
634 (princ (if (aref flags 4) "short-form" "long-form"))
635 (if (aref flags 5) (princ ", ASCII@EOL"))
636 (if (aref flags 6) (princ ", ASCII@CNTL"))
637 (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
638 (if (aref flags 8) (princ ", use-locking-shift"))
639 (if (aref flags 9) (princ ", use-single-shift"))
640 (if (aref flags 10) (princ ", use-roman"))
641 (if (aref flags 11) (princ ", use-old-jis"))
642 (if (aref flags 12) (princ ", no-ISO6429"))
643 (if (aref flags 13) (princ ", init-bol"))
644 (if (aref flags 14) (princ ", designation-bol"))
645 (if (aref flags 15) (princ ", convert-unsafe"))
646 (if (aref flags 16) (princ ", accept-latin-extra-code"))
647 (princ "."))
648 ((eq type 3)
649 (princ " (Big5)"))
650 ((eq type 4)
651 (princ " (do conversion by CCL program)"))
652 ((eq type 5)
653 (princ " (text with random binary characters)"))
654 (t (princ ": invalid coding-system."))))
655 (princ "\nEOL type: ")
656 (let ((eol-type (coding-system-eol-type coding-system)))
657 (cond ((vectorp eol-type)
658 (princ "Automatic selection from:\n\t")
659 (princ eol-type)
660 (princ "\n"))
661 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
662 ((eq eol-type 1) (princ "CRLF\n"))
663 ((eq eol-type 2) (princ "CR\n"))
664 (t (princ "invalid\n"))))
ff8909d8
KH		 665 (let ((postread (coding-system-get coding-system 'post-read-conversion)))
666 (when postread
71527e5d
DL		 667 (princ "After decoding text normally,")
668 (princ " perform post-conversion using the function: ")
ff8909d8
KH		 669 (princ "\n ")
670 (princ postread)
671 (princ "\n")))
672 (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
673 (when prewrite
71527e5d
DL		 674 (princ "Before encoding text normally,")
675 (princ " perform pre-conversion using the function: ")
ff8909d8
KH		 676 (princ "\n ")
677 (princ prewrite)
678 (princ "\n")))
55140940 679 (with-current-buffer standard-output
a399ef7b 680 (let ((charsets (coding-system-get coding-system 'safe-charsets)))
97b14492
KH		 681 (when (and (not (memq (coding-system-base coding-system)
682 '(raw-text emacs-mule)))
683 charsets)
a399ef7b 684 (if (eq charsets t)
97b14492
KH		 685 (insert "This coding system can encode all charsets except for
686eight-bit-control and eight-bit-graphic.\n")
71527e5d 687 (insert "This coding system encodes the following charsets:\n ")
a399ef7b
KH		 688 (while charsets
689 (insert " " (symbol-name (car charsets)))
690 (search-backward (symbol-name (car charsets)))
e8cdeaca 691 (help-xref-button 0 'help-character-set (car charsets))
a399ef7b 692 (goto-char (point-max))
55140940 693 (setq charsets (cdr charsets))))))))))
a399ef7b 694
4ed46869
KH		 695
696;;;###autoload
697(defun describe-current-coding-system-briefly ()
795a5f84 698 "Display coding systems currently used in a brief format in echo area.
4ed46869 699
795a5f84 700The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
4ed46869 701where mnemonics of the following coding systems come in this order
7cc8aac3 702in place of `..':
187bd11c
SS		 703 `buffer-file-coding-system' (of the current buffer)
704 eol-type of `buffer-file-coding-system' (of the current buffer)
4527adca 705 Value returned by `keyboard-coding-system'
187bd11c
SS		 706 eol-type of `keyboard-coding-system'
707 Value returned by `terminal-coding-system'.
708 eol-type of `terminal-coding-system'
4527adca 709 `process-coding-system' for read (of the current buffer, if any)
187bd11c 710 eol-type of `process-coding-system' for read (of the current buffer, if any)
4527adca 711 `process-coding-system' for write (of the current buffer, if any)
187bd11c 712 eol-type of `process-coding-system' for write (of the current buffer, if any)
4527adca 713 `default-buffer-file-coding-system'
187bd11c 714 eol-type of `default-buffer-file-coding-system'
4527adca 715 `default-process-coding-system' for read
187bd11c 716 eol-type of `default-process-coding-system' for read
4527adca 717 `default-process-coding-system' for write
187bd11c 718 eol-type of `default-process-coding-system'"
4ed46869
KH		 719 (interactive)
720 (let* ((proc (get-buffer-process (current-buffer)))
721 (process-coding-systems (if proc (process-coding-system proc))))
722 (message
bb89cd2a 723 "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 724 (coding-system-mnemonic buffer-file-coding-system)
795a5f84 725 (coding-system-eol-type-mnemonic buffer-file-coding-system)
4ed46869 726 (coding-system-mnemonic (keyboard-coding-system))
795a5f84 727 (coding-system-eol-type-mnemonic (keyboard-coding-system))
4ed46869 728 (coding-system-mnemonic (terminal-coding-system))
795a5f84 729 (coding-system-eol-type-mnemonic (terminal-coding-system))
4ed46869 730 (coding-system-mnemonic (car process-coding-systems))
795a5f84 731 (coding-system-eol-type-mnemonic (car process-coding-systems))
4ed46869 732 (coding-system-mnemonic (cdr process-coding-systems))
795a5f84
KH		 733 (coding-system-eol-type-mnemonic (cdr process-coding-systems))
734 (coding-system-mnemonic default-buffer-file-coding-system)
735 (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
4ed46869 736 (coding-system-mnemonic (car default-process-coding-system))
795a5f84 737 (coding-system-eol-type-mnemonic (car default-process-coding-system))
4ed46869 738 (coding-system-mnemonic (cdr default-process-coding-system))
795a5f84 739 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
4ed46869
KH		 740 )))
741
4527adca 742;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
60b898c6
KH		 743;; If DOC-STRING is non-nil, print also the docstring of CODING-SYSTEM.
744;; If DOC-STRING is `tightly', don't print an empty line before the
745;; docstring, and print only the first line of the docstring.
746
426f97dc 747(defun print-coding-system-briefly (coding-system &optional doc-string)
795a5f84
KH		 748 (if (not coding-system)
749 (princ "nil\n")
750 (princ (format "%c -- %s"
751 (coding-system-mnemonic coding-system)
752 coding-system))
ff8909d8 753 (let ((aliases (coding-system-get coding-system 'alias-coding-systems)))
91e854f2
KH		 754 (cond ((eq coding-system (car aliases))
755 (if (cdr aliases)
756 (princ (format " %S" (cons 'alias: (cdr aliases))))))
757 ((memq coding-system aliases)
758 (princ (format " (alias of %s)" (car aliases))))
759 (t
760 (let ((eol-type (coding-system-eol-type coding-system))
761 (base-eol-type (coding-system-eol-type (car aliases))))
762 (if (and (integerp eol-type)
763 (vectorp base-eol-type)
764 (not (eq coding-system (aref base-eol-type eol-type))))
765 (princ (format " (alias of %s)"
766 (aref base-eol-type eol-type))))))))
60b898c6
KH		 767 (princ "\n")
768 (or (eq doc-string 'tightly)
769 (princ "\n"))
770 (if doc-string
771 (let ((doc (or (coding-system-doc-string coding-system) "")))
772 (when (eq doc-string 'tightly)
773 (if (string-match "\n" doc)
774 (setq doc (substring doc 0 (match-beginning 0))))
775 (setq doc (concat " " doc)))
776 (princ (format "%s\n" doc))))))
4ed46869
KH		 777
778;;;###autoload
779(defun describe-current-coding-system ()
4527adca 780 "Display coding systems currently used, in detail."
4ed46869
KH		 781 (interactive)
782 (with-output-to-temp-buffer "*Help*"
783 (let* ((proc (get-buffer-process (current-buffer)))
784 (process-coding-systems (if proc (process-coding-system proc))))
e72e91e9 785 (princ "Coding system for saving this buffer:\n ")
795a5f84
KH		 786 (if (local-variable-p 'buffer-file-coding-system)
787 (print-coding-system-briefly buffer-file-coding-system)
e72e91e9
RS		 788 (princ "Not set locally, use the default.\n"))
789 (princ "Default coding system (for new files):\n ")
795a5f84 790 (print-coding-system-briefly default-buffer-file-coding-system)
e72e91e9 791 (princ "Coding system for keyboard input:\n ")
4ed46869 792 (print-coding-system-briefly (keyboard-coding-system))
e72e91e9 793 (princ "Coding system for terminal output:\n ")
4ed46869 794 (print-coding-system-briefly (terminal-coding-system))
e72e91e9
RS		 795 (when (get-buffer-process (current-buffer))
796 (princ "Coding systems for process I/O:\n")
797 (princ " encoding input to the process: ")
798 (print-coding-system-briefly (cdr process-coding-systems))
799 (princ " decoding output from the process: ")
800 (print-coding-system-briefly (car process-coding-systems)))
1b76aedd 801 (princ "Defaults for subprocess I/O:\n")
795a5f84 802 (princ " decoding: ")
4ed46869 803 (print-coding-system-briefly (car default-process-coding-system))
795a5f84
KH		 804 (princ " encoding: ")
805 (print-coding-system-briefly (cdr default-process-coding-system)))
426f97dc 806
55140940 807 (with-current-buffer standard-output
426f97dc 808
7cc8aac3
PJ		 809 (princ "
810Priority order for recognizing coding systems when reading files:\n")
426f97dc
KH		 811 (let ((l coding-category-list)
812 (i 1)
5cfcd8bc 813 (coding-list nil)
426f97dc
KH		 814 coding aliases)
815 (while l
816 (setq coding (symbol-value (car l)))
ff8909d8 817 ;; Do not list up the same coding system twice.
2149d013 818 (when (and coding (not (memq coding coding-list)))
5cfcd8bc 819 (setq coding-list (cons coding coding-list))
ff8909d8
KH		 820 (princ (format " %d. %s " i coding))
821 (setq aliases (coding-system-get coding 'alias-coding-systems))
822 (if (eq coding (car aliases))
823 (if (cdr aliases)
824 (princ (cons 'alias: (cdr aliases))))
825 (if (memq coding aliases)
826 (princ (list 'alias 'of (car aliases)))))
5cfcd8bc
KH		 827 (terpri)
828 (setq i (1+ i)))
829 (setq l (cdr l))))
ff8909d8 830
426f97dc
KH		 831 (princ "\n Other coding systems cannot be distinguished automatically
832 from these, and therefore cannot be recognized automatically
833 with the present coding system priorities.\n\n")
834
b585fb6c 835 (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
426f97dc
KH		 836 coding-system codings)
837 (while categories
838 (setq coding-system (symbol-value (car categories)))
839 (mapcar
02e91426
SM		 840 (lambda (x)
841 (if (and (not (eq x coding-system))
842 (coding-system-get x 'no-initial-designation)
843 (let ((flags (coding-system-flags x)))
844 (not (or (aref flags 10) (aref flags 11)))))
845 (setq codings (cons x codings))))
426f97dc
KH		 846 (get (car categories) 'coding-systems))
847 (if codings
5307cb2e 848 (let ((max-col (window-width))
426f97dc 849 pos)
7cc8aac3
PJ		 850 (princ (format "\
851 The following are decoded correctly but recognized as %s:\n "
852 coding-system))
426f97dc
KH		 853 (while codings
854 (setq pos (point))
855 (insert (format " %s" (car codings)))
4472a77b
KH		 856 (when (> (current-column) max-col)
857 (goto-char pos)
858 (insert "\n ")
859 (goto-char (point-max)))
426f97dc
KH		 860 (setq codings (cdr codings)))
861 (insert "\n\n")))
862 (setq categories (cdr categories))))
863
e72e91e9 864 (princ "Particular coding systems specified for certain file names:\n")
426f97dc
KH		 865 (terpri)
866 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
867 (princ " ---------\t--------------\t\t----------------\n")
868 (let ((func (lambda (operation alist)
869 (princ " ")
870 (princ operation)
871 (if (not alist)
872 (princ "\tnothing specified\n")
873 (while alist
874 (indent-to 16)
875 (prin1 (car (car alist)))
ff8909d8
KH		 876 (if (>= (current-column) 40)
877 (newline))
426f97dc
KH		 878 (indent-to 40)
879 (princ (cdr (car alist)))
880 (princ "\n")
881 (setq alist (cdr alist)))))))
882 (funcall func "File I/O" file-coding-system-alist)
883 (funcall func "Process I/O" process-coding-system-alist)
884 (funcall func "Network I/O" network-coding-system-alist))
885 (help-mode))))
4ed46869
KH		 886
887;; Print detailed information on CODING-SYSTEM.
ff8909d8 888(defun print-coding-system (coding-system)
4ed46869 889 (let ((type (coding-system-type coding-system))
795a5f84
KH		 890 (eol-type (coding-system-eol-type coding-system))
891 (flags (coding-system-flags coding-system))
ff8909d8
KH		 892 (aliases (coding-system-get coding-system 'alias-coding-systems)))
893 (if (not (eq (car aliases) coding-system))
894 (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
795a5f84 895 (princ coding-system)
ff8909d8 896 (setq aliases (cdr aliases))
795a5f84 897 (while aliases
4472a77b
KH		 898 (princ ",")
899 (princ (car aliases))
900 (setq aliases (cdr aliases)))
795a5f84
KH		 901 (princ (format ":%s:%c:%d:"
902 type
903 (coding-system-mnemonic coding-system)
904 (if (integerp eol-type) eol-type 3)))
905 (cond ((eq type 2) ; ISO-2022
906 (let ((idx 0)
907 charset)
908 (while (< idx 4)
909 (setq charset (aref flags idx))
910 (cond ((null charset)
911 (princ -1))
912 ((eq charset t)
913 (princ -2))
914 ((charsetp charset)
915 (princ charset))
916 ((listp charset)
917 (princ "(")
4ed46869 918 (princ (car charset))
795a5f84
KH		 919 (setq charset (cdr charset))
920 (while charset
921 (princ ",")
922 (princ (car charset))
923 (setq charset (cdr charset)))
924 (princ ")")))
925 (princ ",")
926 (setq idx (1+ idx)))
927 (while (< idx 12)
928 (princ (if (aref flags idx) 1 0))
929 (princ ",")
930 (setq idx (1+ idx)))
931 (princ (if (aref flags idx) 1 0))))
932 ((eq type 4) ; CCL
933 (let (i len)
0d5f1e3a
RS		 934 (if (symbolp (car flags))
935 (princ (format " %s" (car flags)))
936 (setq i 0 len (length (car flags)))
937 (while (< i len)
938 (princ (format " %x" (aref (car flags) i)))
939 (setq i (1+ i))))
4ed46869 940 (princ ",")
0d5f1e3a
RS		 941 (if (symbolp (cdr flags))
942 (princ (format "%s" (cdr flags)))
943 (setq i 0 len (length (cdr flags)))
944 (while (< i len)
945 (princ (format " %x" (aref (cdr flags) i)))
946 (setq i (1+ i))))))
795a5f84
KH		 947 (t (princ 0)))
948 (princ ":")
949 (princ (coding-system-doc-string coding-system))
950 (princ "\n"))))
4ed46869 951
795a5f84 952;;;###autoload
4472a77b
KH		 953(defun list-coding-systems (&optional arg)
954 "Display a list of all coding systems.
4527adca 955This shows the mnemonic letter, name, and description of each coding system.
4472a77b
KH		 956
957With prefix arg, the output format gets more cryptic,
4527adca 958but still contains full information about each coding system."
4472a77b 959 (interactive "P")
4ed46869 960 (with-output-to-temp-buffer "*Help*"
13cef08d
KH		 961 (list-coding-systems-1 arg)))
962
963(defun list-coding-systems-1 (arg)
964 (if (null arg)
965 (princ "\
795a5f84
KH		 966###############################################
967# List of coding systems in the following format:
968# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
60b898c6 969# DOC-STRING
795a5f84 970")
13cef08d 971 (princ "\
4ed46869
KH		 972#########################
973## LIST OF CODING SYSTEMS
974## Each line corresponds to one coding system
975## Format of a line is:
795a5f84
KH		 976## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
977## :PRE-WRITE-CONVERSION:DOC-STRING,
4ed46869 978## where
795a5f84
KH		 979## NAME = coding system name
980## ALIAS = alias of the coding system
981## TYPE = nil (no conversion), t (undecided or automatic detection),
982## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
4ed46869
KH		 983## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
984## FLAGS =
985## if TYPE = 2 then
0a1a08dd 986## comma (`,') separated data of the following:
4ed46869
KH		 987## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
988## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
989## else if TYPE = 4 then
990## comma (`,') separated CCL programs for read and write
991## else
992## 0
795a5f84 993## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
4ed46869 994##
795a5f84 995"))
60b898c6
KH		 996 (dolist (coding-system (sort-coding-systems (coding-system-list 'base-only)))
997 (if (null arg)
998 (print-coding-system-briefly coding-system 'tightly)
a7832266
KH		 999 (print-coding-system coding-system)))
1000 (let ((first t))
1001 (dolist (elt coding-system-alist)
1002 (unless (memq (intern (car elt)) coding-system-list)
1003 (when first
1004 (princ "\
1005####################################################
1006# The following coding systems are not yet loaded. #
1007####################################################
1008")
1009 (setq first nil))
1010 (princ-list (car elt))))))
4472a77b 1011
867ef43a 1012;;;###autoload
4472a77b
KH		 1013(defun list-coding-categories ()
1014 "Display a list of all coding categories."
1015 (with-output-to-temp-buffer "*Help*"
1016 (princ "\
4ed46869
KH		 1017############################
1018## LIST OF CODING CATEGORIES (ordered by priority)
1019## CATEGORY:CODING-SYSTEM
1020##
1021")
4472a77b
KH		 1022 (let ((l coding-category-list))
1023 (while l
1024 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
1025 (setq l (cdr l))))))
4ed46869
KH		 1026\f
1027;;; FONT
1028
1029;; Print information of a font in FONTINFO.
1030(defun describe-font-internal (font-info &optional verbose)
1031 (print-list "name (opened by):" (aref font-info 0))
1032 (print-list " full name:" (aref font-info 1))
b1e3566c
KH		 1033 (print-list " size:" (format "%2d" (aref font-info 2)))
1034 (print-list " height:" (format "%2d" (aref font-info 3)))
1035 (print-list " baseline-offset:" (format "%2d" (aref font-info 4)))
1036 (print-list "relative-compose:" (format "%2d" (aref font-info 5))))
4ed46869
KH		 1037
1038;;;###autoload
1039(defun describe-font (fontname)
1040 "Display information about fonts which partially match FONTNAME."
4bb0b3ad 1041 (interactive "sFontname (default, current choice for ASCII chars): ")
ee5f768d 1042 (or (and window-system (fboundp 'fontset-list))
effd4e82 1043 (error "No fontsets being used"))
2167d18d
KH		 1044 (when (or (not fontname) (= (length fontname) 0))
1045 (setq fontname (cdr (assq 'font (frame-parameters))))
1046 (if (query-fontset fontname)
1047 (setq fontname
3e8017d2 1048 (nth 1 (assq 'ascii (aref (fontset-info fontname) 2))))))
4ed46869
KH		 1049 (let ((font-info (font-info fontname)))
1050 (if (null font-info)
1051 (message "No matching font")
1052 (with-output-to-temp-buffer "*Help*"
1053 (describe-font-internal font-info 'verbose)))))
1054
4472a77b 1055(defun print-fontset (fontset &optional print-fonts)
7cc8aac3 1056 "Print information about FONTSET.
c0e70a9f 1057If FONTSET is nil, print information about the default fontset.
7cc8aac3
PJ		 1058If optional arg PRINT-FONTS is non-nil, also print names of all opened
1059fonts for FONTSET. This function actually inserts the information in
1060the current buffer."
c0e70a9f
KH		 1061 (or fontset
1062 (setq fontset (query-fontset "fontset-default")))
3e8017d2 1063 (let ((tail (aref (fontset-info fontset) 2))
b1e3566c 1064 elt chars font-spec opened prev-charset charset from to)
4472a77b 1065 (beginning-of-line)
b1e3566c
KH		 1066 (insert "Fontset: " fontset "\n")
1067 (insert "CHARSET or CHAR RANGE")
55bab388 1068 (indent-to 24)
b1e3566c
KH		 1069 (insert "FONT NAME\n")
1070 (insert "---------------------")
55bab388 1071 (indent-to 24)
b1e3566c
KH		 1072 (insert "---------")
1073 (insert "\n")
1074 (while tail
1075 (setq elt (car tail) tail (cdr tail))
1076 (setq chars (car elt) font-spec (car (cdr elt)) opened (cdr (cdr elt)))
1077 (if (symbolp chars)
1078 (setq charset chars from nil to nil)
1079 (if (integerp chars)
1080 (setq charset (char-charset chars) from chars to chars)
1081 (setq charset (char-charset (car chars))
1082 from (car chars) to (cdr chars))))
1083 (unless (eq charset prev-charset)
1084 (insert (symbol-name charset))
1085 (if from
1086 (insert "\n")))
1087 (when from
1088 (let ((split (split-char from)))
1089 (if (and (= (charset-dimension charset) 2)
1090 (= (nth 2 split) 0))
1091 (setq from
1092 (make-char charset (nth 1 split)
1093 (if (= (charset-chars charset) 94) 33 32))))
1094 (insert " " from))
1095 (when (/= from to)
1096 (insert "-")
1097 (let ((split (split-char to)))
1098 (if (and (= (charset-dimension charset) 2)
1099 (= (nth 2 split) 0))
1100 (setq to
1101 (make-char charset (nth 1 split)
1102 (if (= (charset-chars charset) 94) 126 127))))
1103 (insert to))))
55bab388 1104 (indent-to 24)
b1e3566c
KH		 1105 (if (stringp font-spec)
1106 (insert font-spec)
1107 (if (car font-spec)
1108 (if (string-match "-" (car font-spec))
cebefb44
KH		 1109 (insert "-" (car font-spec) "-*-")
1110 (insert "-*-" (car font-spec) "-*-"))
b1e3566c
KH		 1111 (insert "-*-"))
1112 (if (cdr font-spec)
1113 (if (string-match "-" (cdr font-spec))
1114 (insert (cdr font-spec))
1115 (insert (cdr font-spec) "-*"))
1116 (insert "*")))
1117 (insert "\n")
1118 (when print-fonts
1119 (while opened
1120 (indent-to 5)
1121 (insert "[" (car opened) "]\n")
1122 (setq opened (cdr opened))))
1123 (setq prev-charset charset)
1124 )))
4ed46869
KH		 1125
1126;;;###autoload
1127(defun describe-fontset (fontset)
7cc8aac3 1128 "Display information about FONTSET.
b1e3566c 1129This shows which font is used for which character(s)."
4ed46869 1130 (interactive
ee5f768d 1131 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 1132 (error "No fontsets being used")
71527e5d 1133 (let ((fontset-list (nconc
f95b7b89
SM		 1134 (fontset-list)
1135 (mapcar 'cdr fontset-alias-alist)))
4472a77b
KH		 1136 (completion-ignore-case t))
1137 (list (completing-read
1138 "Fontset (default, used by the current frame): "
1139 fontset-list nil t)))))
1140 (if (= (length fontset) 0)
c0e70a9f
KH		 1141 (setq fontset (frame-parameter nil 'font)))
1142 (setq fontset (query-fontset fontset))
55140940
SM		 1143 (help-setup-xref (list #'describe-fontset fontset) (interactive-p))
1144 (with-output-to-temp-buffer (help-buffer)
1145 (with-current-buffer standard-output
b1e3566c 1146 (print-fontset fontset t))))
4472a77b
KH		 1147
1148;;;###autoload
1149(defun list-fontsets (arg)
1150 "Display a list of all fontsets.
4527adca 1151This shows the name, size, and style of each fontset.
7cc8aac3 1152With prefix arg, also list the fonts contained in each fontset;
4527adca 1153see the function `describe-fontset' for the format of the list."
4472a77b 1154 (interactive "P")
ee5f768d 1155 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 1156 (error "No fontsets being used")
55140940
SM		 1157 (help-setup-xref (list #'list-fontsets arg) (interactive-p))
1158 (with-output-to-temp-buffer (help-buffer)
1159 (with-current-buffer standard-output
13cef08d 1160 ;; This code is duplicated near the end of mule-diag.
dc1f8c72
KH		 1161 (let ((fontsets
1162 (sort (fontset-list)
02e91426
SM		 1163 (lambda (x y)
1164 (string< (fontset-plain-name x)
1165 (fontset-plain-name y))))))
effd4e82 1166 (while fontsets
b1e3566c
KH		 1167 (if arg
1168 (print-fontset (car fontsets) nil)
1169 (insert "Fontset: " (car fontsets) "\n"))
effd4e82 1170 (setq fontsets (cdr fontsets))))))))
426f97dc
KH		 1171\f
1172;;;###autoload
1173(defun list-input-methods ()
4527adca 1174 "Display information about all input methods."
426f97dc 1175 (interactive)
02e91426
SM		 1176 (help-setup-xref '(list-input-methods) (interactive-p))
1177 (with-output-to-temp-buffer (help-buffer)
7cc8aac3
PJ		 1178 (list-input-methods-1)
1179 (with-current-buffer standard-output
1180 (save-excursion
1181 (goto-char (point-min))
1182 (while (re-search-forward
1183 "^ \\([^ ]+\\) (`.*' in mode line)$" nil t)
ee592269 1184 (help-xref-button 1 'help-input-method (match-string 1)))))))
13cef08d
KH		 1185
1186(defun list-input-methods-1 ()
1187 (if (not input-method-alist)
1188 (progn
1189 (princ "
10de7378
PJ		 1190No input method is available, perhaps because you have not
1191installed LEIM (Libraries of Emacs Input Methods)."))
13cef08d
KH		 1192 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
1193 (princ " SHORT-DESCRIPTION\n------------------------------\n")
1194 (setq input-method-alist
1195 (sort input-method-alist
02e91426 1196 (lambda (x y) (string< (nth 1 x) (nth 1 y)))))
13cef08d
KH		 1197 (let ((l input-method-alist)
1198 language elt)
1199 (while l
1200 (setq elt (car l) l (cdr l))
1201 (when (not (equal language (nth 1 elt)))
1202 (setq language (nth 1 elt))
1203 (princ language)
1204 (terpri))
1205 (princ (format " %s (`%s' in mode line)\n %s\n"
1206 (car elt)
1207 (let ((title (nth 3 elt)))
1208 (if (and (consp title) (stringp (car title)))
1209 (car title)
1210 title))
1211 (let ((description (nth 4 elt)))
1212 (string-match ".*" description)
1213 (match-string 0 description))))))))
4ed46869
KH		 1214\f
1215;;; DIAGNOSIS
1216
4472a77b
KH		 1217;; Insert a header of a section with SECTION-NUMBER and TITLE.
1218(defun insert-section (section-number title)
4ed46869 1219 (insert "########################################\n"
4472a77b 1220 "# Section " (format "%d" section-number) ". " title "\n"
4ed46869
KH		 1221 "########################################\n\n"))
1222
1223;;;###autoload
1224(defun mule-diag ()
3fdaafa6 1225 "Display diagnosis of the multilingual environment (Mule).
4472a77b 1226
4527adca 1227This shows various information related to the current multilingual
4472a77b 1228environment, including lists of input methods, coding systems,
4527adca 1229character sets, and fontsets (if Emacs is running under a window
effd4e82 1230system which uses fontsets)."
4ed46869 1231 (interactive)
4472a77b 1232 (with-output-to-temp-buffer "*Mule-Diagnosis*"
55140940 1233 (with-current-buffer standard-output
13cef08d
KH		 1234 (insert "###############################################\n"
1235 "### Current Status of Multilingual Features ###\n"
1236 "###############################################\n\n"
4ed46869
KH		 1237 "CONTENTS: Section 1. General Information\n"
1238 " Section 2. Display\n"
1239 " Section 3. Input methods\n"
1240 " Section 4. Coding systems\n"
4472a77b 1241 " Section 5. Character sets\n")
ee5f768d 1242 (if (and window-system (fboundp 'fontset-list))
4472a77b 1243 (insert " Section 6. Fontsets\n"))
4ed46869
KH		 1244 (insert "\n")
1245
1246 (insert-section 1 "General Information")
7bce107c 1247 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
cbbe6489
KH		 1248 (insert "Configuration options:\n " system-configuration-options "\n\n")
1249 (insert "Multibyte characters awareness:\n"
1250 (format " default: %S\n" default-enable-multibyte-characters)
1251 (format " current-buffer: %S\n\n" enable-multibyte-characters))
1252 (insert "Current language environment: " current-language-environment
1253 "\n\n")
4ed46869
KH		 1254
1255 (insert-section 2 "Display")
1256 (if window-system
1257 (insert "Window-system: "
1258 (symbol-name window-system)
1259 (format "%s" window-system-version))
1260 (insert "Terminal: " (getenv "TERM")))
1261 (insert "\n\n")
1262
1263 (if (eq window-system 'x)
1264 (let ((font (cdr (assq 'font (frame-parameters)))))
1265 (insert "The selected frame is using the "
1266 (if (query-fontset font) "fontset" "font")
1267 ":\n\t" font))
1268 (insert "Coding system of the terminal: "
1269 (symbol-name (terminal-coding-system))))
1270 (insert "\n\n")
1271
1272 (insert-section 3 "Input methods")
13cef08d 1273 (list-input-methods-1)
4ed46869
KH		 1274 (insert "\n")
1275 (if default-input-method
d4b11c67 1276 (insert (format "Default input method: %s\n" default-input-method))
1b76aedd 1277 (insert "No default input method is specified\n"))
4ed46869
KH		 1278
1279 (insert-section 4 "Coding systems")
13cef08d
KH		 1280 (list-coding-systems-1 t)
1281 (princ "\
1282############################
1283## LIST OF CODING CATEGORIES (ordered by priority)
1284## CATEGORY:CODING-SYSTEM
1285##
1286")
1287 (let ((l coding-category-list))
1288 (while l
1289 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
1290 (setq l (cdr l))))
4ed46869
KH		 1291 (insert "\n")
1292
4472a77b 1293 (insert-section 5 "Character sets")
efdd2d79 1294 (list-character-sets-2)
4ed46869
KH		 1295 (insert "\n")
1296
ee5f768d 1297 (when (and window-system (fboundp 'fontset-list))
13cef08d 1298 ;; This code duplicates most of list-fontsets.
4472a77b 1299 (insert-section 6 "Fontsets")
13cef08d
KH		 1300 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
1301 (insert "------------\t\t\t\t\t\t ----- -----\n")
1302 (let ((fontsets (fontset-list)))
1303 (while fontsets
1304 (print-fontset (car fontsets) t)
1305 (setq fontsets (cdr fontsets)))))
eabe0ad3 1306 (print-help-return-message))))
4ed46869 1307
bfe77626
DL		 1308(provide 'mule-diag)
1309
ab5796a9 1310;;; arch-tag: cd3b607c-2893-45a0-a4fa-a6535754dbee
795a5f84 1311;;; mule-diag.el ends here
Unnamed repository; edit this file 'description' to name the repository.