|
207
|
1 ;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
|
|
|
2
|
|
|
3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
|
|
|
4 ;; Licensed to the Free Software Foundation.
|
|
|
5 ;; Copyright (C) 1997 MORIOKA Tomohiko
|
|
|
6
|
|
|
7 ;; Keywords: multilingual, charset, coding system, fontset, diagnosis
|
|
|
8
|
|
|
9 ;; This file is part of XEmacs.
|
|
|
10
|
|
|
11 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
12 ;; 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 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
19 ;; General Public License for more details.
|
|
|
20
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
|
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
24 ;; 02111-1307, USA.
|
|
|
25
|
|
|
26 ;;; General utility function
|
|
|
27
|
|
|
28 ;; Print all arguments with single space separator in one line.
|
|
|
29 (defun print-list (&rest args)
|
|
|
30 (while (cdr args)
|
|
|
31 (when (car args)
|
|
|
32 (princ (car args))
|
|
|
33 (princ " "))
|
|
|
34 (setq args (cdr args)))
|
|
|
35 (princ (car args))
|
|
|
36 (princ "\n"))
|
|
|
37
|
|
|
38 ;; Re-order the elements of charset-list.
|
|
|
39 (defun sort-charset-list ()
|
|
|
40 (setq charset-list
|
|
|
41 (sort charset-list
|
|
|
42 (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
|
|
|
43
|
|
|
44 ;;; CHARSET
|
|
|
45
|
|
|
46 ;;;###autoload
|
|
|
47 (defun list-character-sets (&optional arg)
|
|
|
48 "Display a list of all character sets.
|
|
|
49
|
|
|
50 The ID column contains a charset identification number for internal use.
|
|
|
51 The B column contains a number of bytes occupied in a buffer.
|
|
|
52 The W column contains a number of columns occupied in a screen.
|
|
|
53
|
|
|
54 With prefix arg, the output format gets more cryptic
|
|
|
55 but contains full information about each character sets."
|
|
|
56 (interactive "P")
|
|
|
57 (sort-charset-list)
|
|
|
58 (with-output-to-temp-buffer "*Help*"
|
|
|
59 (save-excursion
|
|
|
60 (set-buffer standard-output)
|
|
|
61 (let ((l charset-list)
|
|
|
62 charset)
|
|
|
63 (if (null arg)
|
|
|
64 (progn
|
|
|
65 (insert "ID Name B W Description\n")
|
|
|
66 (insert "-- ---- - - -----------\n")
|
|
|
67 (while l
|
|
|
68 (setq charset (car l) l (cdr l))
|
|
|
69 (insert (format "%03d %s" (charset-id charset) charset))
|
|
|
70 (indent-to 28)
|
|
|
71 (insert (format "%d %d %s\n"
|
|
|
72 (charset-bytes charset)
|
|
|
73 (charset-width charset)
|
|
|
74 (charset-description charset)))))
|
|
|
75 (insert "\
|
|
|
76 #########################
|
|
|
77 ## LIST OF CHARSETS
|
|
|
78 ## Each line corresponds to one charset.
|
|
|
79 ## The following attributes are listed in this order
|
|
|
80 ## separated by a colon `:' in one line.
|
|
|
81 ## CHARSET-ID,
|
|
|
82 ## CHARSET-SYMBOL-NAME,
|
|
|
83 ## DIMENSION (1 or 2)
|
|
|
84 ## CHARS (94 or 96)
|
|
|
85 ## BYTES (of multibyte form: 1, 2, 3, or 4),
|
|
|
86 ## WIDTH (occupied column numbers: 1 or 2),
|
|
|
87 ## DIRECTION (0:left-to-right, 1:right-to-left),
|
|
|
88 ## ISO-FINAL-CHAR (character code of ISO-2022's final character)
|
|
|
89 ## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
|
|
|
90 ## DESCRIPTION (describing string of the charset)
|
|
|
91 ")
|
|
|
92 (while l
|
|
|
93 (setq charset (car l) l (cdr l))
|
|
|
94 (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
|
|
|
95 (charset-id charset)
|
|
|
96 charset
|
|
|
97 (charset-dimension charset)
|
|
|
98 (charset-chars charset)
|
|
|
99 (charset-bytes charset)
|
|
|
100 (charset-width charset)
|
|
|
101 (charset-direction charset)
|
|
|
102 (charset-iso-final-char charset)
|
|
|
103 (charset-iso-graphic-plane charset)
|
|
|
104 (charset-description charset))))))
|
|
|
105 (help-mode)
|
|
|
106 (setq truncate-lines t))))
|
|
|
107
|
|
|
108 ;;; CODING-SYSTEM
|
|
|
109
|
|
|
110 (defun describe-designation (cs register)
|
|
|
111 (let ((charset
|
|
|
112 (coding-system-property
|
|
|
113 cs (intern (format "charset-g%d" register))))
|
|
|
114 (force
|
|
|
115 (coding-system-property
|
|
|
116 cs (intern (format "force-g%d-on-output" register)))))
|
|
|
117 (princ
|
|
|
118 (format
|
|
|
119 " G%d: %s%s\n"
|
|
|
120 register
|
|
|
121 (cond ((null charset) "never used")
|
|
|
122 ((eq t charset) "none")
|
|
|
123 (t (charset-name charset)))
|
|
|
124 (if force " (explicit designation required)" "")))))
|
|
|
125
|
|
|
126 ;;;###autoload
|
|
|
127 (defun describe-coding-system (coding-system)
|
|
|
128 "Display information of CODING-SYSTEM."
|
|
|
129 (interactive "zDescribe coding system (default, current choices): ")
|
|
|
130 (if (or (null coding-system)
|
|
|
131 (string= (symbol-name coding-system) ""))
|
|
|
132 (describe-current-coding-system)
|
|
|
133 (with-output-to-temp-buffer "*Help*"
|
|
|
134 (print-coding-system-briefly coding-system 'doc-string)
|
|
|
135 (let ((type (coding-system-type coding-system)))
|
|
|
136 (princ (format "Type: %s" type))
|
|
|
137 (when (eq type 'iso2022)
|
|
|
138 (princ " (variant of ISO-2022)\n")
|
|
|
139 (princ "Initial designations:\n")
|
|
|
140 ;;(print-designation flags)
|
|
|
141 (describe-designation coding-system 0)
|
|
|
142 (describe-designation coding-system 1)
|
|
|
143 (describe-designation coding-system 2)
|
|
|
144 (describe-designation coding-system 3)
|
|
|
145 (princ "Other Form: \n ")
|
|
|
146 (princ (if (coding-system-short coding-system)
|
|
|
147 "short-form"
|
|
|
148 "long-form"))
|
|
|
149 (if (coding-system-no-ascii-eol coding-system)
|
|
|
150 (princ ", ASCII@EOL"))
|
|
|
151 (if (coding-system-no-ascii-cntl coding-system)
|
|
|
152 (princ ", ASCII@CNTL"))
|
|
|
153 (princ (if (coding-system-seven coding-system)
|
|
|
154 ", 7-bit"
|
|
|
155 ", 8-bit"))
|
|
|
156 (if (coding-system-lock-shift coding-system)
|
|
|
157 (princ ", use-locking-shift")
|
|
|
158 (princ ", use-single-shift"))
|
|
|
159 ;;(if (aref flags 10) (princ ", use-roman"))
|
|
|
160 ;;(if (aref flags 10) (princ ", use-old-jis"))
|
|
|
161 (if (coding-system-no-iso6429 coding-system)
|
|
|
162 (princ ", no-ISO6429"))
|
|
|
163 )
|
|
|
164 (princ "\nEOL type:")
|
|
|
165 (let ((eol-type (coding-system-eol-type coding-system)))
|
|
|
166 (cond ((null eol-type)
|
|
|
167 (princ "\n Automatic selection from\n ")
|
|
|
168 (princ (format "%s-unix, %s-dos or %s-mac.\n"
|
|
|
169 coding-system coding-system coding-system))
|
|
|
170 )
|
|
|
171 ((symbolp eol-type)
|
|
|
172 (princ " ")
|
|
|
173 (princ eol-type))
|
|
|
174 (t (princ "invalid\n")))))
|
|
|
175 (save-excursion
|
|
|
176 (set-buffer standard-output)
|
|
|
177 (help-mode)))))
|
|
|
178
|
|
|
179 ;;;###autoload
|
|
|
180 (defun describe-current-coding-system-briefly ()
|
|
|
181 "Display coding systems currently used in a brief format in echo area.
|
|
|
182
|
|
|
183 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
|
|
|
184 where mnemonics of the following coding systems come in this order
|
|
|
185 at the place of `..':
|
|
|
186 buffer-file-coding-system (of the current buffer)
|
|
|
187 eol-type of buffer-file-coding-system (of the current buffer)
|
|
|
188 (keyboard-coding-system)
|
|
|
189 eol-type of (keyboard-coding-system)
|
|
|
190 (terminal-coding-system)
|
|
|
191 eol-type of (terminal-coding-system)
|
|
|
192 process-coding-system for read (of the current buffer, if any)
|
|
|
193 eol-type of process-coding-system for read (of the current buffer, if any)
|
|
|
194 process-coding-system for write (of the current buffer, if any)
|
|
|
195 eol-type of process-coding-system for write (of the current buffer, if any)
|
|
|
196 default-buffer-file-coding-system
|
|
|
197 eol-type of default-buffer-file-coding-system
|
|
|
198 default-process-coding-system for read
|
|
|
199 eol-type of default-process-coding-system for read
|
|
|
200 default-process-coding-system for write
|
|
|
201 eol-type of default-process-coding-system"
|
|
|
202 (interactive)
|
|
|
203 (let* ((proc (get-buffer-process (current-buffer)))
|
|
|
204 (process-coding-systems (if proc (process-coding-system proc))))
|
|
|
205 (message
|
|
|
206 "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]"
|
|
|
207 (coding-system-mnemonic buffer-file-coding-system)
|
|
|
208 (coding-system-eol-type-mnemonic buffer-file-coding-system)
|
|
|
209 (coding-system-mnemonic (keyboard-coding-system))
|
|
|
210 (coding-system-eol-type-mnemonic (keyboard-coding-system))
|
|
|
211 (coding-system-mnemonic (terminal-coding-system))
|
|
|
212 (coding-system-eol-type-mnemonic (terminal-coding-system))
|
|
|
213 (coding-system-mnemonic (car process-coding-systems))
|
|
|
214 (coding-system-eol-type-mnemonic (car process-coding-systems))
|
|
|
215 (coding-system-mnemonic (cdr process-coding-systems))
|
|
|
216 (coding-system-eol-type-mnemonic (cdr process-coding-systems))
|
|
|
217 (coding-system-mnemonic default-buffer-file-coding-system)
|
|
|
218 (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
|
|
|
219 (coding-system-mnemonic (car default-process-coding-system))
|
|
|
220 (coding-system-eol-type-mnemonic (car default-process-coding-system))
|
|
|
221 (coding-system-mnemonic (cdr default-process-coding-system))
|
|
|
222 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
|
|
|
223 )))
|
|
|
224
|
|
|
225 ;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'.
|
|
|
226 (defun print-coding-system-briefly (coding-system &optional doc-string)
|
|
|
227 (if (not coding-system)
|
|
|
228 (princ "nil\n")
|
|
|
229 ;; In XEmacs, coding-system has own type.
|
|
|
230 (if (coding-system-p coding-system)
|
|
|
231 (setq coding-system (coding-system-name coding-system))
|
|
|
232 )
|
|
|
233 ;; In XEmacs, coding-system-mnemonic returns string.
|
|
|
234 (princ (format "%s -- %s"
|
|
|
235 (coding-system-mnemonic coding-system)
|
|
|
236 coding-system))
|
|
|
237 ;; Current XEmacs does not have `coding-system-parent'.
|
|
|
238 ;; (let ((parent (coding-system-parent coding-system)))
|
|
|
239 ;; (if parent
|
|
|
240 ;; (princ (format " (alias of %s)" parent))))
|
|
|
241 (let ((aliases (get coding-system 'alias-coding-systems)))
|
|
|
242 (if aliases
|
|
|
243 (princ (format " %S" (cons 'alias: aliases)))))
|
|
|
244 (princ "\n")
|
|
|
245 (if (and doc-string
|
|
|
246 (setq doc-string (coding-system-doc-string coding-system)))
|
|
|
247 (princ (format " %s\n" doc-string)))))
|
|
|
248
|
|
|
249 ;;;###autoload
|
|
|
250 (defun describe-current-coding-system ()
|
|
|
251 "Display coding systems currently used in a detailed format."
|
|
|
252 (interactive)
|
|
|
253 (with-output-to-temp-buffer "*Help*"
|
|
|
254 (let* ((proc (get-buffer-process (current-buffer)))
|
|
|
255 (process-coding-systems (if proc (process-coding-system proc))))
|
|
|
256 (princ "Coding system for saving this buffer:\n ")
|
|
|
257 ;; local-variable-p of XEmacs requires 2 arguments.
|
|
|
258 (if (local-variable-p 'buffer-file-coding-system (current-buffer))
|
|
|
259 (print-coding-system-briefly buffer-file-coding-system)
|
|
|
260 (princ "Not set locally, use the default.\n"))
|
|
|
261 (princ "Default coding system (for new files):\n ")
|
|
|
262 (print-coding-system-briefly default-buffer-file-coding-system)
|
|
|
263 (princ "Coding system for keyboard input:\n ")
|
|
|
264 (print-coding-system-briefly (keyboard-coding-system))
|
|
|
265 (princ "Coding system for terminal output:\n ")
|
|
|
266 (print-coding-system-briefly (terminal-coding-system))
|
|
|
267 (when (get-buffer-process (current-buffer))
|
|
|
268 (princ "Coding systems for process I/O:\n")
|
|
|
269 (princ " encoding input to the process: ")
|
|
|
270 (print-coding-system-briefly (cdr process-coding-systems))
|
|
|
271 (princ " decoding output from the process: ")
|
|
|
272 (print-coding-system-briefly (car process-coding-systems)))
|
|
|
273 ;;(princ "Defaults for subprocess I/O:\n")
|
|
|
274 ;;(princ " decoding: ")
|
|
|
275 ;;(print-coding-system-briefly (car default-process-coding-system))
|
|
|
276 ;;(princ " encoding: ")
|
|
|
277 ;;(print-coding-system-briefly (cdr default-process-coding-system))
|
|
|
278 )
|
|
|
279 (save-excursion
|
|
|
280 (set-buffer standard-output)
|
|
|
281
|
|
|
282 (princ
|
|
|
283 "\nPriority order for recognizing coding systems when reading files:\n")
|
|
|
284 (let ((l (coding-category-list)) ; It is function in XEmacs.
|
|
|
285 (i 1)
|
|
|
286 (coding-list nil)
|
|
|
287 coding aliases)
|
|
|
288 (while l
|
|
|
289 (setq coding (coding-category-system (car l))) ; for XEmacs
|
|
|
290 (when (not (memq coding coding-list))
|
|
|
291 (setq coding-list (cons coding coding-list))
|
|
|
292 (princ (format " %d. %s" i coding))
|
|
|
293 (when (setq aliases (get coding 'alias-coding-systems))
|
|
|
294 (princ " ")
|
|
|
295 (princ (cons 'alias: aliases)))
|
|
|
296 (terpri)
|
|
|
297 (setq i (1+ i)))
|
|
|
298 (setq l (cdr l))))
|
|
|
299 (princ "\n Other coding systems cannot be distinguished automatically
|
|
|
300 from these, and therefore cannot be recognized automatically
|
|
|
301 with the present coding system priorities.\n\n")
|
|
|
302
|
|
|
303 (let ((categories '(iso-7)) ; for XEmacs
|
|
|
304 ;; '(coding-category-iso-7 coding-category-iso-7-else))
|
|
|
305 coding-system codings)
|
|
|
306 (while categories
|
|
|
307 ;; for XEmacs
|
|
|
308 (setq coding-system (coding-category-system (car categories)))
|
|
|
309 (mapcar
|
|
|
310 (function
|
|
|
311 (lambda (x)
|
|
|
312 (if (and (not (eq x coding-system))
|
|
|
313 (get x 'no-initial-designation)
|
|
|
314 (let ((flags (coding-system-flags x)))
|
|
|
315 (not (or (aref flags 10) (aref flags 11)))))
|
|
|
316 (setq codings (cons x codings)))))
|
|
|
317 (get (car categories) 'coding-systems))
|
|
|
318 (if codings
|
|
|
319 (let ((max-col (frame-width))
|
|
|
320 pos)
|
|
|
321 (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system))
|
|
|
322 (while codings
|
|
|
323 (setq pos (point))
|
|
|
324 (insert (format " %s" (car codings)))
|
|
|
325 (when (> (current-column) max-col)
|
|
|
326 (goto-char pos)
|
|
|
327 (insert "\n ")
|
|
|
328 (goto-char (point-max)))
|
|
|
329 (setq codings (cdr codings)))
|
|
|
330 (insert "\n\n")))
|
|
|
331 (setq categories (cdr categories))))
|
|
|
332
|
|
|
333 (princ "Particular coding systems specified for certain file names:\n")
|
|
|
334 (terpri)
|
|
|
335 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
|
|
|
336 (princ " ---------\t--------------\t\t----------------\n")
|
|
|
337 (let ((func (lambda (operation alist)
|
|
|
338 (princ " ")
|
|
|
339 (princ operation)
|
|
|
340 (if (not alist)
|
|
|
341 (princ "\tnothing specified\n")
|
|
|
342 (while alist
|
|
|
343 (indent-to 16)
|
|
|
344 (prin1 (car (car alist)))
|
|
|
345 (indent-to 40)
|
|
|
346 (princ (cdr (car alist)))
|
|
|
347 (princ "\n")
|
|
|
348 (setq alist (cdr alist)))))))
|
|
|
349 (funcall func "File I/O" file-coding-system-alist)
|
|
|
350 (funcall func "Process I/O" process-coding-system-alist)
|
|
|
351 (funcall func "Network I/O" network-coding-system-alist))
|
|
|
352 (help-mode))))
|
|
|
353
|
|
|
354 ;; Print detailed information on CODING-SYSTEM.
|
|
|
355 (defun print-coding-system (coding-system &optional aliases)
|
|
|
356 (let ((type (coding-system-type coding-system))
|
|
|
357 (eol-type (coding-system-eol-type coding-system))
|
|
|
358 (flags (coding-system-flags coding-system))
|
|
|
359 (base (coding-system-base coding-system)))
|
|
|
360 (if (not (eq base coding-system))
|
|
|
361 (princ (format "%s (alias of %s)\n" coding-system base))
|
|
|
362 (princ coding-system)
|
|
|
363 (while aliases
|
|
|
364 (princ ",")
|
|
|
365 (princ (car aliases))
|
|
|
366 (setq aliases (cdr aliases)))
|
|
|
367 (princ (format ":%s:%c:%d:"
|
|
|
368 type
|
|
|
369 (coding-system-mnemonic coding-system)
|
|
|
370 (if (integerp eol-type) eol-type 3)))
|
|
|
371 (cond ((eq type 2) ; ISO-2022
|
|
|
372 (let ((idx 0)
|
|
|
373 charset)
|
|
|
374 (while (< idx 4)
|
|
|
375 (setq charset (aref flags idx))
|
|
|
376 (cond ((null charset)
|
|
|
377 (princ -1))
|
|
|
378 ((eq charset t)
|
|
|
379 (princ -2))
|
|
|
380 ((charsetp charset)
|
|
|
381 (princ charset))
|
|
|
382 ((listp charset)
|
|
|
383 (princ "(")
|
|
|
384 (princ (car charset))
|
|
|
385 (setq charset (cdr charset))
|
|
|
386 (while charset
|
|
|
387 (princ ",")
|
|
|
388 (princ (car charset))
|
|
|
389 (setq charset (cdr charset)))
|
|
|
390 (princ ")")))
|
|
|
391 (princ ",")
|
|
|
392 (setq idx (1+ idx)))
|
|
|
393 (while (< idx 12)
|
|
|
394 (princ (if (aref flags idx) 1 0))
|
|
|
395 (princ ",")
|
|
|
396 (setq idx (1+ idx)))
|
|
|
397 (princ (if (aref flags idx) 1 0))))
|
|
|
398 ((eq type 4) ; CCL
|
|
|
399 (let (i len)
|
|
|
400 (setq i 0 len (length (car flags)))
|
|
|
401 (while (< i len)
|
|
|
402 (princ (format " %x" (aref (car flags) i)))
|
|
|
403 (setq i (1+ i)))
|
|
|
404 (princ ",")
|
|
|
405 (setq i 0 len (length (cdr flags)))
|
|
|
406 (while (< i len)
|
|
|
407 (princ (format " %x" (aref (cdr flags) i)))
|
|
|
408 (setq i (1+ i)))))
|
|
|
409 (t (princ 0)))
|
|
|
410 (princ ":")
|
|
|
411 (princ (coding-system-doc-string coding-system))
|
|
|
412 (princ "\n"))))
|
|
|
413
|
|
|
414 ;;;###autoload
|
|
|
415 (defun list-coding-systems (&optional arg)
|
|
|
416 "Display a list of all coding systems.
|
|
|
417 It prints mnemonic letter, name, and description of each coding systems.
|
|
|
418
|
|
|
419 With prefix arg, the output format gets more cryptic,
|
|
|
420 but contains full information about each coding systems."
|
|
|
421 (interactive "P")
|
|
|
422 (with-output-to-temp-buffer "*Help*"
|
|
|
423 (if (null arg)
|
|
|
424 (princ "\
|
|
|
425 ###############################################
|
|
|
426 # List of coding systems in the following format:
|
|
|
427 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
|
|
|
428 # DOC-STRING
|
|
|
429 ")
|
|
|
430 (princ "\
|
|
|
431 #########################
|
|
|
432 ## LIST OF CODING SYSTEMS
|
|
|
433 ## Each line corresponds to one coding system
|
|
|
434 ## Format of a line is:
|
|
|
435 ## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
|
|
|
436 ## :PRE-WRITE-CONVERSION:DOC-STRING,
|
|
|
437 ## where
|
|
|
438 ## NAME = coding system name
|
|
|
439 ## ALIAS = alias of the coding system
|
|
|
440 ## TYPE = nil (no conversion), t (undecided or automatic detection),
|
|
|
441 ## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
|
|
|
442 ## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
|
|
|
443 ## FLAGS =
|
|
|
444 ## if TYPE = 2 then
|
|
|
445 ## comma (`,') separated data of the followings:
|
|
|
446 ## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
|
|
|
447 ## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
|
|
|
448 ## else if TYPE = 4 then
|
|
|
449 ## comma (`,') separated CCL programs for read and write
|
|
|
450 ## else
|
|
|
451 ## 0
|
|
|
452 ## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
|
|
|
453 ##
|
|
|
454 "))
|
|
|
455 (let ((bases (coding-system-list))
|
|
|
456 ;;(coding-system-list 'base-only))
|
|
|
457 coding-system)
|
|
|
458 (while bases
|
|
|
459 (setq coding-system (car bases))
|
|
|
460 (if (null arg)
|
|
|
461 (print-coding-system-briefly coding-system 'doc-string)
|
|
|
462 (print-coding-system coding-system))
|
|
|
463 (setq bases (cdr bases))))))
|
|
|
464
|
|
|
465 ;;;###automatic
|
|
|
466 (defun list-coding-categories ()
|
|
|
467 "Display a list of all coding categories."
|
|
|
468 (with-output-to-temp-buffer "*Help*"
|
|
|
469 (princ "\
|
|
|
470 ############################
|
|
|
471 ## LIST OF CODING CATEGORIES (ordered by priority)
|
|
|
472 ## CATEGORY:CODING-SYSTEM
|
|
|
473 ##
|
|
|
474 ")
|
|
|
475 (let ((l coding-category-list))
|
|
|
476 (while l
|
|
|
477 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
|
|
|
478 (setq l (cdr l))))))
|
|
|
479
|
|
|
480 ;;; FONT
|
|
|
481
|
|
|
482 ;; Print information of a font in FONTINFO.
|
|
|
483 (defun describe-font-internal (font-info &optional verbose)
|
|
|
484 (print-list "name (opened by):" (aref font-info 0))
|
|
|
485 (print-list " full name:" (aref font-info 1))
|
|
|
486 (let ((charset (aref font-info 2)))
|
|
|
487 (print-list " charset:"
|
|
|
488 (format "%s (%s)" charset (charset-description charset))))
|
|
|
489 (print-list " size:" (format "%d" (aref font-info 3)))
|
|
|
490 (print-list " height:" (format "%d" (aref font-info 4)))
|
|
|
491 (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
|
|
|
492 (print-list "relative-compose:" (format "%d" (aref font-info 6))))
|
|
|
493
|
|
|
494 ;;;###autoload
|
|
|
495 (defun describe-font (fontname)
|
|
|
496 "Display information about fonts which partially match FONTNAME."
|
|
|
497 (interactive "sFontname (default, current choise for ASCII chars): ")
|
|
|
498 (or window-system
|
|
|
499 (error "No window system being used"))
|
|
|
500 (when (or (not fontname) (= (length fontname) 0))
|
|
|
501 (setq fontname (cdr (assq 'font (frame-parameters))))
|
|
|
502 (if (query-fontset fontname)
|
|
|
503 (setq fontname
|
|
|
504 (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
|
|
|
505 (let ((font-info (font-info fontname)))
|
|
|
506 (if (null font-info)
|
|
|
507 (message "No matching font")
|
|
|
508 (with-output-to-temp-buffer "*Help*"
|
|
|
509 (describe-font-internal font-info 'verbose)))))
|
|
|
510
|
|
|
511 ;; Print information of FONTSET. If optional arg PRINT-FONTS is
|
|
|
512 ;; non-nil, print also names of all fonts in FONTSET. This function
|
|
|
513 ;; actually INSERT such information in the current buffer.
|
|
|
514 (defun print-fontset (fontset &optional print-fonts)
|
|
|
515 (let* ((fontset-info (fontset-info fontset))
|
|
|
516 (size (aref fontset-info 0))
|
|
|
517 (height (aref fontset-info 1))
|
|
|
518 (fonts (and print-fonts (aref fontset-info 2)))
|
|
|
519 (xlfd-fields (x-decompose-font-name fontset))
|
|
|
520 style)
|
|
|
521 (if xlfd-fields
|
|
|
522 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
|
|
|
523 (slant (aref xlfd-fields xlfd-regexp-slant-subnum)))
|
|
|
524 (if (string-match "^bold$\\|^demibold$" weight)
|
|
|
525 (setq style (concat weight " "))
|
|
|
526 (setq style "medium "))
|
|
|
527 (cond ((string-match "^i$" slant)
|
|
|
528 (setq style (concat style "italic")))
|
|
|
529 ((string-match "^o$" slant)
|
|
|
530 (setq style (concat style "slant")))
|
|
|
531 ((string-match "^ri$" slant)
|
|
|
532 (setq style (concat style "reverse italic")))
|
|
|
533 ((string-match "^ro$" slant)
|
|
|
534 (setq style (concat style "reverse slant")))))
|
|
|
535 (setq style " ? "))
|
|
|
536 (beginning-of-line)
|
|
|
537 (insert fontset)
|
|
|
538 (indent-to 58)
|
|
|
539 (insert (if (> size 0) (format "%2dx%d" size height) " -"))
|
|
|
540 (indent-to 64)
|
|
|
541 (insert style "\n")
|
|
|
542 (when print-fonts
|
|
|
543 (insert " O Charset / Fontname\n"
|
|
|
544 " - ------------------\n")
|
|
|
545 (sort-charset-list)
|
|
|
546 (let ((l charset-list)
|
|
|
547 charset font-info opened fontname)
|
|
|
548 (while l
|
|
|
549 (setq charset (car l) l (cdr l))
|
|
|
550 (setq font-info (assq charset fonts))
|
|
|
551 (if (null font-info)
|
|
|
552 (setq opened ?? fontname "not specified")
|
|
|
553 (if (nth 2 font-info)
|
|
|
554 (if (stringp (nth 2 font-info))
|
|
|
555 (setq opened ?o fontname (nth 2 font-info))
|
|
|
556 (setq opened ?- fontname (nth 1 font-info)))
|
|
|
557 (setq opened ?x fontname (nth 1 font-info))))
|
|
|
558 (insert (format " %c %s\n %s\n"
|
|
|
559 opened charset fontname)))))))
|
|
|
560
|
|
|
561 ;;;###autoload
|
|
|
562 (defun describe-fontset (fontset)
|
|
|
563 "Display information of FONTSET.
|
|
|
564
|
|
|
565 It prints name, size, and style of FONTSET, and lists up fonts
|
|
|
566 contained in FONTSET.
|
|
|
567
|
|
|
568 The column WDxHT contains width and height (pixels) of each fontset
|
|
|
569 \(i.e. those of ASCII font in the fontset). The letter `-' in this
|
|
|
570 column means that the corresponding fontset is not yet used in any
|
|
|
571 frame.
|
|
|
572
|
|
|
573 The O column of each font contains one of the following letters.
|
|
|
574 o -- font already opened
|
|
|
575 - -- font not yet opened
|
|
|
576 x -- font can't be opened
|
|
|
577 ? -- no font specified
|
|
|
578
|
|
|
579 The Charset column of each font contains a name of character set
|
|
|
580 displayed by the font."
|
|
|
581 (interactive
|
|
|
582 (if (not window-system)
|
|
|
583 (error "No window system being used")
|
|
|
584 (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
|
|
|
585 (completion-ignore-case t))
|
|
|
586 (list (completing-read
|
|
|
587 "Fontset (default, used by the current frame): "
|
|
|
588 fontset-list nil t)))))
|
|
|
589 (if (= (length fontset) 0)
|
|
|
590 (setq fontset (cdr (assq 'font (frame-parameters)))))
|
|
|
591 (if (not (query-fontset fontset))
|
|
|
592 (error "Current frame is using font, not fontset"))
|
|
|
593 (let ((fontset-info (fontset-info fontset)))
|
|
|
594 (with-output-to-temp-buffer "*Help*"
|
|
|
595 (save-excursion
|
|
|
596 (set-buffer standard-output)
|
|
|
597 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
|
|
|
598 (insert "------------\t\t\t\t\t\t ----- -----\n")
|
|
|
599 (print-fontset fontset t)))))
|
|
|
600
|
|
|
601 ;;;###autoload
|
|
|
602 (defun list-fontsets (arg)
|
|
|
603 "Display a list of all fontsets.
|
|
|
604
|
|
|
605 It prints name, size, and style of each fontset.
|
|
|
606 With prefix arg, it also lists up fonts contained in each fontset.
|
|
|
607 See the function `describe-fontset' for the format of the list."
|
|
|
608 (interactive "P")
|
|
|
609 (with-output-to-temp-buffer "*Help*"
|
|
|
610 (save-excursion
|
|
|
611 (set-buffer standard-output)
|
|
|
612 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
|
|
|
613 (insert "------------\t\t\t\t\t\t ----- -----\n")
|
|
|
614 (let ((fontsets (fontset-list)))
|
|
|
615 (while fontsets
|
|
|
616 (print-fontset (car fontsets) arg)
|
|
|
617 (setq fontsets (cdr fontsets)))))))
|
|
|
618
|
|
|
619 ;;;###autoload
|
|
|
620 (defun list-input-methods ()
|
|
|
621 "Print information of all input methods."
|
|
|
622 (interactive)
|
|
|
623 (with-output-to-temp-buffer "*Help*"
|
|
|
624 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
|
|
|
625 (princ " SHORT-DESCRIPTION\n------------------------------\n")
|
|
|
626 (setq input-method-alist
|
|
|
627 (sort input-method-alist
|
|
|
628 (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
|
|
|
629 (let ((l input-method-alist)
|
|
|
630 language elt)
|
|
|
631 (while l
|
|
|
632 (setq elt (car l) l (cdr l))
|
|
|
633 (when (not (equal language (nth 1 elt)))
|
|
|
634 (setq language (nth 1 elt))
|
|
|
635 (princ language)
|
|
|
636 (terpri))
|
|
|
637 (princ (format " %s (`%s' in mode line)\n %s\n"
|
|
|
638 (car elt) (nth 3 elt)
|
|
|
639 (let ((title (nth 4 elt)))
|
|
|
640 (string-match ".*" title)
|
|
|
641 (match-string 0 title))))))))
|
|
|
642
|
|
|
643 ;;; DIAGNOSIS
|
|
|
644
|
|
|
645 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
|
|
|
646 (defun insert-section (section-number title)
|
|
|
647 (insert "########################################\n"
|
|
|
648 "# Section " (format "%d" section-number) ". " title "\n"
|
|
|
649 "########################################\n\n"))
|
|
|
650
|
|
|
651 ;;;###autoload
|
|
|
652 (defun mule-diag ()
|
|
|
653 "Display diagnosis of the multilingual environment (MULE).
|
|
|
654
|
|
|
655 It prints various information related to the current multilingual
|
|
|
656 environment, including lists of input methods, coding systems,
|
|
|
657 character sets, and fontsets (if Emacs running under some window
|
|
|
658 system)."
|
|
|
659 (interactive)
|
|
|
660 (with-output-to-temp-buffer "*Mule-Diagnosis*"
|
|
|
661 (save-excursion
|
|
|
662 (set-buffer standard-output)
|
|
|
663 (insert "\t###############################\n"
|
|
|
664 "\t### Diagnosis of your Emacs ###\n"
|
|
|
665 "\t###############################\n\n"
|
|
|
666 "CONTENTS: Section 1. General Information\n"
|
|
|
667 " Section 2. Display\n"
|
|
|
668 " Section 3. Input methods\n"
|
|
|
669 " Section 4. Coding systems\n"
|
|
|
670 " Section 5. Character sets\n")
|
|
|
671 (if window-system
|
|
|
672 (insert " Section 6. Fontsets\n"))
|
|
|
673 (insert "\n")
|
|
|
674
|
|
|
675 (insert-section 1 "General Information")
|
|
|
676 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
|
|
|
677
|
|
|
678 (insert-section 2 "Display")
|
|
|
679 (if window-system
|
|
|
680 (insert "Window-system: "
|
|
|
681 (symbol-name window-system)
|
|
|
682 (format "%s" window-system-version))
|
|
|
683 (insert "Terminal: " (getenv "TERM")))
|
|
|
684 (insert "\n\n")
|
|
|
685
|
|
|
686 (if (eq window-system 'x)
|
|
|
687 (let ((font (cdr (assq 'font (frame-parameters)))))
|
|
|
688 (insert "The selected frame is using the "
|
|
|
689 (if (query-fontset font) "fontset" "font")
|
|
|
690 ":\n\t" font))
|
|
|
691 (insert "Coding system of the terminal: "
|
|
|
692 (symbol-name (terminal-coding-system))))
|
|
|
693 (insert "\n\n")
|
|
|
694
|
|
|
695 (insert-section 3 "Input methods")
|
|
|
696 (save-excursion (list-input-methods))
|
|
|
697 (insert-buffer-substring "*Help*")
|
|
|
698 (insert "\n")
|
|
|
699 (if default-input-method
|
|
|
700 (insert "Default input method: " default-input-method "\n")
|
|
|
701 (insert "No default input method is specified\n"))
|
|
|
702
|
|
|
703 (insert-section 4 "Coding systems")
|
|
|
704 (save-excursion (list-coding-systems t))
|
|
|
705 (insert-buffer-substring "*Help*")
|
|
|
706 (save-excursion (list-coding-categories))
|
|
|
707 (insert-buffer-substring "*Help*")
|
|
|
708 (insert "\n")
|
|
|
709
|
|
|
710 (insert-section 5 "Character sets")
|
|
|
711 (save-excursion (list-character-sets t))
|
|
|
712 (insert-buffer-substring "*Help*")
|
|
|
713 (insert "\n")
|
|
|
714
|
|
|
715 (when window-system
|
|
|
716 (insert-section 6 "Fontsets")
|
|
|
717 (save-excursion (list-fontsets t))
|
|
|
718 (insert-buffer-substring "*Help*"))
|
|
|
719 (help-mode))))
|
|
|
720
|
|
|
721
|
|
|
722 ;;; DUMP DATA FILE
|
|
|
723
|
|
|
724 ;;;###autoload
|
|
|
725 (defun dump-charsets ()
|
|
|
726 "Dump information of all charsets into the file \"CHARSETS\".
|
|
|
727 The file is saved in the directory `data-directory'."
|
|
|
728 (let ((file (expand-file-name "CHARSETS" data-directory))
|
|
|
729 buf)
|
|
|
730 (or (file-writable-p file)
|
|
|
731 (error "Can't write to file %s" file))
|
|
|
732 (setq buf (find-file-noselect file))
|
|
|
733 (save-window-excursion
|
|
|
734 (save-excursion
|
|
|
735 (set-buffer buf)
|
|
|
736 (setq buffer-read-only nil)
|
|
|
737 (erase-buffer)
|
|
|
738 (list-character-sets t)
|
|
|
739 (insert-buffer-substring "*Help*")
|
|
|
740 (let (make-backup-files
|
|
|
741 coding-system-for-write)
|
|
|
742 (save-buffer))))
|
|
|
743 (kill-buffer buf))
|
|
|
744 (if noninteractive
|
|
|
745 (kill-emacs)))
|
|
|
746
|
|
|
747 ;;;###autoload
|
|
|
748 (defun dump-codings ()
|
|
|
749 "Dump information of all coding systems into the file \"CODINGS\".
|
|
|
750 The file is saved in the directory `data-directory'."
|
|
|
751 (let ((file (expand-file-name "CODINGS" data-directory))
|
|
|
752 buf)
|
|
|
753 (or (file-writable-p file)
|
|
|
754 (error "Can't write to file %s" file))
|
|
|
755 (setq buf (find-file-noselect file))
|
|
|
756 (save-window-excursion
|
|
|
757 (save-excursion
|
|
|
758 (set-buffer buf)
|
|
|
759 (setq buffer-read-only nil)
|
|
|
760 (erase-buffer)
|
|
|
761 (list-coding-systems t)
|
|
|
762 (insert-buffer-substring "*Help*")
|
|
|
763 (list-coding-categories)
|
|
|
764 (insert-buffer-substring "*Help*")
|
|
|
765 (let (make-backup-files
|
|
|
766 coding-system-for-write)
|
|
|
767 (save-buffer))))
|
|
|
768 (kill-buffer buf))
|
|
|
769 (if noninteractive
|
|
|
770 (kill-emacs)))
|
|
|
771
|
|
|
772 ;;; mule-diag.el ends here
|
