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