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