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