HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
(w32-menu-bar-open): Declare for compiler.
[bpt/emacs.git] / lisp / international / mule-diag.el
CommitLineData
60370d40 1;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
4ed46869 2
26b3dce6
GM		 3;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4;; 2007, 2008 Free Software Foundation, Inc.
7976eda0 5;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
e3fe4da0 6;; 2005, 2006, 2007, 2008
2fd125a3
KH		 7;; National Institute of Advanced Industrial Science and Technology (AIST)
8;; Registration Number H14PRO021
8f924df7 9;; Copyright (C) 2003
2c390c27
KH		 10;; National Institute of Advanced Industrial Science and Technology (AIST)
11;; Registration Number H13PRO009
4ed46869 12
3a4df6e5 13;; Keywords: multilingual, charset, coding system, fontset, diagnosis, i18n
4ed46869
KH		 14
15;; This file is part of GNU Emacs.
16
4936186e 17;; GNU Emacs is free software: you can redistribute it and/or modify
4ed46869 18;; it under the terms of the GNU General Public License as published by
4936186e
GM		 19;; the Free Software Foundation, either version 3 of the License, or
20;; (at your option) any later version.
4ed46869
KH		 21
22;; GNU Emacs is distributed in the hope that it will be useful,
23;; but WITHOUT ANY WARRANTY; without even the implied warranty of
24;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25;; GNU General Public License for more details.
26
27;; You should have received a copy of the GNU General Public License
4936186e 28;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
4ed46869 29
60370d40
PJ		 30;;; Commentary:
31
32;;; Code:
33
0abeb602 34;; Make sure the help-xref button type is defined.
abf545c4 35(require 'help-fns)
0abeb602 36
4ed46869
KH		 37;;; General utility function
38
4ed46869 39(defun print-list (&rest args)
3a1ef8f5 40 "Print all arguments with single space separator in one line."
4ed46869 41 (while (cdr args)
4472a77b
KH		 42 (when (car args)
43 (princ (car args))
44 (princ " "))
4ed46869
KH		 45 (setq args (cdr args)))
46 (princ (car args))
47 (princ "\n"))
48
49;;; CHARSET
50
e8cdeaca
MB		 51(define-button-type 'sort-listed-character-sets
52 'help-echo (purecopy "mouse-2, RET: sort on this column")
53 'face 'bold
54 'action #'(lambda (button)
55 (sort-listed-character-sets (button-get button 'sort-key))))
56
57(define-button-type 'list-charset-chars
58 :supertype 'help-xref
59 'help-function #'list-charset-chars
60 'help-echo "mouse-2, RET: show table of characters for this character set")
61
4ed46869 62;;;###autoload
efdd2d79 63(defun list-character-sets (arg)
4472a77b
KH		 64 "Display a list of all character sets.
65
7cc8aac3
PJ		 66The D column contains the dimension of this character set. The CH
67column contains the number of characters in a block of this character
68set. The FINAL-CHAR column contains an ISO-2022 <final-char> to use
69for designating this character set in ISO-2022-based coding systems.
4472a77b 70
4527adca
KH		 71With prefix arg, the output format gets more cryptic,
72but still shows the full information."
4472a77b 73 (interactive "P")
55140940 74 (help-setup-xref (list #'list-character-sets arg) (interactive-p))
3aab6d06 75 (with-output-to-temp-buffer "*Character Set List*"
efdd2d79
KH		 76 (with-current-buffer standard-output
77 (if arg
78 (list-character-sets-2)
79 ;; Insert header.
875d7ad9 80 (insert "Supplementary character sets are shown below.\n")
efdd2d79
KH		 81 (insert
82 (substitute-command-keys
e5b99cff
KH		 83 (concat "Use "
84 (if (display-mouse-p) "\\[help-follow-mouse] or ")
85 "\\[help-follow]:\n")))
86 (insert " on a column title to sort by that title,")
3a1ef8f5 87 (indent-to 48)
efdd2d79 88 (insert "+----DIMENSION\n")
e5b99cff 89 (insert " on a charset name to list characters.")
3a1ef8f5 90 (indent-to 48)
efdd2d79 91 (insert "| +--CHARS\n")
3a1ef8f5
DL		 92 (let ((columns '(("CHARSET-NAME" . name) "\t\t\t\t\t"
93 ("D CH FINAL-CHAR" . iso-spec)))
efdd2d79
KH		 94 pos)
95 (while columns
96 (if (stringp (car columns))
97 (insert (car columns))
e8cdeaca
MB		 98 (insert-text-button (car (car columns))
99 :type 'sort-listed-character-sets
100 'sort-key (cdr (car columns)))
efdd2d79
KH		 101 (goto-char (point-max)))
102 (setq columns (cdr columns)))
103 (insert "\n"))
3a1ef8f5 104 (insert "------------\t\t\t\t\t- --- ----------\n")
13cef08d 105
efdd2d79 106 ;; Insert body sorted by charset IDs.
3a1ef8f5 107 (list-character-sets-1 'name)))))
efdd2d79 108
efdd2d79
KH		 109(defun sort-listed-character-sets (sort-key)
110 (if sort-key
111 (save-excursion
112 (let ((buffer-read-only nil))
113 (goto-char (point-min))
875d7ad9
KH		 114 (search-forward "\n-")
115 (forward-line 1)
116 (delete-region (point) (point-max))
117 (list-character-sets-1 sort-key)))))
efdd2d79 118
efdd2d79 119(defun list-character-sets-1 (sort-key)
3a1ef8f5
DL		 120 "Insert a list of character sets sorted by SORT-KEY.
121SORT-KEY should be `name' or `iso-spec' (default `name')."
efdd2d79 122 (or sort-key
3a1ef8f5
DL		 123 (setq sort-key 'name))
124 (let ((tail charset-list)
875d7ad9 125 charset-info-list supplementary-list charset sort-func)
3a1ef8f5 126 (dolist (charset charset-list)
efdd2d79 127 ;; Generate a list that contains all information to display.
875d7ad9
KH		 128 (let ((elt (list charset
129 (charset-dimension charset)
130 (charset-chars charset)
131 (charset-iso-final-char charset))))
132 (if (plist-get (charset-plist charset) :supplementary-p)
133 (push elt supplementary-list)
134 (push elt charset-info-list))))
efdd2d79
KH		 135
136 ;; Determine a predicate for `sort' by SORT-KEY.
137 (setq sort-func
3a1ef8f5
DL		 138 (cond ((eq sort-key 'name)
139 (lambda (x y) (string< (car x) (car y))))
efdd2d79
KH		 140
141 ((eq sort-key 'iso-spec)
142 ;; Sort by DIMENSION CHARS FINAL-CHAR
143 (function
144 (lambda (x y)
3a1ef8f5
DL		 145 (or (< (nth 1 x) (nth 1 y))
146 (and (= (nth 1 x) (nth 1 y))
147 (or (< (nth 2 x) (nth 2 y))
148 (and (= (nth 2 x) (nth 2 y))
149 (< (nth 3 x) (nth 3 y)))))))))
efdd2d79
KH		 150 (t
151 (error "Invalid charset sort key: %s" sort-key))))
152
153 (setq charset-info-list (sort charset-info-list sort-func))
875d7ad9 154 (setq supplementary-list (sort supplementary-list sort-func))
efdd2d79
KH		 155
156 ;; Insert information of character sets.
875d7ad9
KH		 157 (dolist (elt (append charset-info-list (list t) supplementary-list))
158 (if (eq elt t)
159 (insert "-------------- Supplementary Character Sets --------------")
160 (insert-text-button (symbol-name (car elt)) ; NAME
161 :type 'list-charset-chars
162 'help-args (list (car elt)))
163 (goto-char (point-max))
164 (insert "\t")
165 (indent-to 48)
166 (insert (format "%d %3d "
167 (nth 1 elt) (nth 2 elt)) ; DIMENSION and CHARS
168 (if (< (nth 3 elt) 0)
169 "none"
170 (nth 3 elt)))) ; FINAL-CHAR
efdd2d79
KH		 171 (insert "\n"))))
172
173
174;; List all character sets in a form that a program can easily parse.
175
176(defun list-character-sets-2 ()
177 (insert "#########################
4ed46869
KH		 178## LIST OF CHARSETS
179## Each line corresponds to one charset.
180## The following attributes are listed in this order
181## separated by a colon `:' in one line.
4472a77b 182## CHARSET-SYMBOL-NAME,
4ed46869
KH		 183## DIMENSION (1 or 2)
184## CHARS (94 or 96)
4ed46869 185## ISO-FINAL-CHAR (character code of ISO-2022's final character)
f3df78db 186## -1 means that no final character is assigned.
4ed46869
KH		 187## DESCRIPTION (describing string of the charset)
188")
efdd2d79
KH		 189 (let ((l charset-list)
190 charset)
191 (while l
192 (setq charset (car l) l (cdr l))
f3df78db 193 (princ (format "%s:%d:%d:%d:%s\n"
efdd2d79
KH		 194 charset
195 (charset-dimension charset)
196 (charset-chars charset)
f3df78db 197;;; (char-width (make-char charset))
3a1ef8f5 198;;; (charset-direction charset)
efdd2d79 199 (charset-iso-final-char charset)
3a1ef8f5 200;;; (charset-iso-graphic-plane charset)
efdd2d79
KH		 201 (charset-description charset))))))
202
3a1ef8f5
DL		 203(defvar non-iso-charset-alist nil
204 "Obsolete.")
bc01a178 205(make-obsolete-variable 'non-iso-charset-alist "no longer relevant." "23.1")
efdd2d79 206
efdd2d79 207(defun decode-codepage-char (codepage code)
7cc8aac3
PJ		 208 "Decode a character that has code CODE in CODEPAGE.
209Return a decoded character string. Each CODEPAGE corresponds to a
bc01a178 210coding system cpCODEPAGE."
3a1ef8f5 211 (decode-char (intern (format "cp%d" codepage)) code))
8589dc17 212(make-obsolete 'decode-codepage-char 'decode-char "23.1")
efdd2d79
KH		 213
214;; A variable to hold charset input history.
215(defvar charset-history nil)
216
217
218;;;###autoload
219(defun read-charset (prompt &optional default-value initial-input)
220 "Read a character set from the minibuffer, prompting with string PROMPT.
3a1ef8f5 221It must be an Emacs character set listed in the variable `charset-list'.
efdd2d79
KH		 222
223Optional arguments are DEFAULT-VALUE and INITIAL-INPUT.
224DEFAULT-VALUE, if non-nil, is the default value.
225INITIAL-INPUT, if non-nil, is a string inserted in the minibuffer initially.
226See the documentation of the function `completing-read' for the
227detailed meanings of these arguments."
3a1ef8f5 228 (let* ((table (mapcar (lambda (x) (list (symbol-name x))) charset-list))
efdd2d79
KH		 229 (charset (completing-read prompt table
230 nil t initial-input 'charset-history
231 default-value)))
232 (if (> (length charset) 0)
233 (intern charset))))
187bd11c 234
efdd2d79
KH		 235;; List characters of the range MIN and MAX of CHARSET. If dimension
236;; of CHARSET is two (i.e. 2-byte charset), ROW is the first byte
237;; (block index) of the characters, and MIN and MAX are the second
238;; bytes of the characters. If the dimension is one, ROW should be 0.
efdd2d79
KH		 239
240(defun list-block-of-chars (charset row min max)
241 (let (i ch)
35650cd2
KH		 242 (insert-char ?- (+ 7 (* 4 16)))
243 (insert "\n ")
efdd2d79
KH		 244 (setq i 0)
245 (while (< i 16)
8f924df7 246 (insert (format "%4X" i))
efdd2d79
KH		 247 (setq i (1+ i)))
248 (setq i (* (/ min 16) 16))
249 (while (<= i max)
250 (if (= (% i 16) 0)
35650cd2 251 (insert (format "\n%6Xx" (/ (+ (* row 256) i) 16))))
8f924df7
KH		 252 (setq ch (if (< i min)
253 32
254 (or (decode-char charset (+ (* row 256) i))
255 32))) ; gap in mapping
ea60d50f 256 ;; Don't insert control codes, non-Unicode characters.
8f924df7
KH		 257 (if (or (< ch 32) (= ch 127))
258 (setq ch (single-key-description ch))
259 (if (and (>= ch 128) (< ch 160))
ea60d50f
KH		 260 (setq ch (format "%02Xh" ch))
261 (if (> ch #x10FFFF)
262 (setq ch 32))))
35650cd2 263 (insert "\t" ch)
efdd2d79
KH		 264 (setq i (1+ i))))
265 (insert "\n"))
266
efdd2d79
KH		 267;;;###autoload
268(defun list-charset-chars (charset)
205a973c 269 "Display a list of characters in character set CHARSET."
efdd2d79 270 (interactive (list (read-charset "Character set: ")))
875d7ad9
KH		 271 (or (charsetp charset)
272 (error "Invalid character set: %s" charset))
3aab6d06 273 (with-output-to-temp-buffer "*Character List*"
efdd2d79 274 (with-current-buffer standard-output
8a97200f
DL		 275 (if (coding-system-p charset)
276 ;; Useful to be able to do C-u C-x = to find file code, for
277 ;; instance:
278 (set-buffer-file-coding-system charset))
3aab6d06
KH		 279 (setq mode-line-format (copy-sequence mode-line-format))
280 (let ((slot (memq 'mode-line-buffer-identification mode-line-format)))
281 (if slot
282 (setcdr slot
283 (cons (format " (%s)" charset)
284 (cdr slot)))))
35650cd2 285 (setq tab-width 4)
efdd2d79 286 (set-buffer-multibyte t)
205a973c
DL		 287 (let ((dim (charset-dimension charset))
288 (chars (charset-chars charset))
289 ;; (plane (charset-iso-graphic-plane charset))
290 (plane 1)
291 (range (plist-get (charset-plist charset) :code-space))
292 min max min2 max2)
293 (if (> dim 2)
294 (error "Can only list 1- and 2-dimensional charsets"))
295 (insert (format "Characters in the coded character set %s.\n" charset))
4a64ad45 296 (narrow-to-region (point) (point))
205a973c
DL		 297 (setq min (aref range 0)
298 max (aref range 1))
299 (if (= dim 1)
205a973c
DL		 300 (list-block-of-chars charset 0 min max)
301 (setq min2 (aref range 2)
302 max2 (aref range 3))
303 (let ((i min2))
304 (while (<= i max2)
305 (list-block-of-chars charset i min max)
4a64ad45
KH		 306 (setq i (1+ i)))))
307 (put-text-property (point-min) (point-max) 'charset charset)
308 (widen)))))
efdd2d79 309
b1e3566c 310
a399ef7b
KH		 311;;;###autoload
312(defun describe-character-set (charset)
7cc8aac3 313 "Display information about built-in character set CHARSET."
3a1ef8f5 314 (interactive (list (read-charset "Charset: ")))
a399ef7b
KH		 315 (or (charsetp charset)
316 (error "Invalid charset: %S" charset))
af279988
DL		 317 (help-setup-xref (list #'describe-character-set charset) (interactive-p))
318 (with-output-to-temp-buffer (help-buffer)
319 (with-current-buffer standard-output
feff73a4
DL		 320 (insert "Character set: " (symbol-name charset))
321 (let ((name (get-charset-property charset :name)))
322 (if (not (eq name charset))
323 (insert " (alias of " (symbol-name name) ?\))))
324 (insert "\n\n" (charset-description charset) "\n\n")
3918e9c9
DL		 325 (insert "Number of contained characters: ")
326 (dotimes (i (charset-dimension charset))
327 (unless (= i 0)
92c15c34 328 (insert ?x))
f21ee25f 329 (insert (format "%d" (charset-chars charset (1+ i)))))
3918e9c9 330 (insert ?\n)
feff73a4
DL		 331 (let ((char (charset-iso-final-char charset)))
332 (when (> char 0)
333 (insert "Final char of ISO2022 designation sequence: ")
334 (insert (format "`%c'\n" char))))
af279988 335 (insert (format "Width (how many columns on screen): %d\n"
205a973c 336 (aref char-width-table (make-char charset))))
feff73a4
DL		 337 (let (aliases)
338 (dolist (c charset-list)
339 (if (and (not (eq c charset))
340 (eq charset (get-charset-property c :name)))
341 (push c aliases)))
342 (if aliases
343 (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n)))
bc01a178 344
feff73a4
DL		 345 (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil)
346 (:map "Map file: " identity)
347 (:unify-map "Unification map file: " identity)
348 (:invalid-code
349 nil
350 ,(lambda (c)
351 (format "Invalid character: %c (code %d)" c c)))
352 (:emacs-mule-id "Id in emacs-mule coding system: "
353 number-to-string)
354 (:parents "Parents: "
355 (lambda (parents)
356 (mapconcat ,(lambda (elt)
357 (format "%s" elt))
358 parents
359 ", ")))
360 (:code-space "Code space: " ,(lambda (c)
361 (format "%s" c)))
362 (:code-offset "Code offset: " number-to-string)
363 (:iso-revision-number "ISO revision number: "
364 number-to-string)
365 (:supplementary-p
366 "Used only as a parent of some other charset." nil)))
367 (let ((val (get-charset-property charset (car elt))))
368 (when val
369 (if (cadr elt) (insert (cadr elt)))
370 (if (nth 2 elt)
371 (insert (funcall (nth 2 elt) val)))
372 (insert ?\n)))))))
4ed46869
KH		 373\f
374;;; CODING-SYSTEM
375
26b3dce6 376(defvar graphic-register) ; dynamic bondage
8285fa96
DL		 377
378;; Print information about designation of each graphic register in
379;; DESIGNATIONS in human readable format. See the documentation of
380;; `define-coding-system' for the meaning of DESIGNATIONS
381;; (`:designation' property).
382(defun print-designation (designations)
383 (let (charset)
384 (dotimes (graphic-register 4)
385 (setq charset (aref designations graphic-register))
4ed46869
KH		 386 (princ (format
387 " G%d -- %s\n"
388 graphic-register
389 (cond ((null charset)
390 "never used")
391 ((eq charset t)
392 "no initial designation, and used by any charsets")
393 ((symbolp charset)
394 (format "%s:%s"
395 charset (charset-description charset)))
396 ((listp charset)
397 (if (charsetp (car charset))
8285fa96 398 (format "%s:%s, and also used by the following:"
4ed46869
KH		 399 (car charset)
400 (charset-description (car charset)))
92c15c34 401 "no initial designation, and used by the following:"))
4ed46869
KH		 402 (t
403 "invalid designation information"))))
4472a77b
KH		 404 (when (listp charset)
405 (setq charset (cdr charset))
406 (while charset
407 (cond ((eq (car charset) t)
408 (princ "\tany other charsets\n"))
409 ((charsetp (car charset))
410 (princ (format "\t%s:%s\n"
411 (car charset)
412 (charset-description (car charset)))))
413 (t
187bd11c 414 "invalid designation information"))
8285fa96 415 (setq charset (cdr charset)))))))
4ed46869
KH		 416
417;;;###autoload
418(defun describe-coding-system (coding-system)
4527adca 419 "Display information about CODING-SYSTEM."
5b76833f 420 (interactive "zDescribe coding system (default current choices): ")
426f97dc
KH		 421 (if (null coding-system)
422 (describe-current-coding-system)
55140940
SM		 423 (help-setup-xref (list #'describe-coding-system coding-system)
424 (interactive-p))
425 (with-output-to-temp-buffer (help-buffer)
426f97dc 426 (print-coding-system-briefly coding-system 'doc-string)
02e91426 427 (let ((type (coding-system-type coding-system))
8f924df7
KH		 428 ;; Fixme: use this
429 (extra-spec (coding-system-plist coding-system)))
426f97dc 430 (princ "Type: ")
02e91426 431 (princ type)
2c390c27 432 (cond ((eq type 'undecided)
02e91426 433 (princ " (do automatic conversion)"))
2c390c27
KH		 434 ((eq type 'utf-8)
435 (princ " (UTF-8: Emacs internal multibyte form)"))
f3d983d8
DL		 436 ((eq type 'utf-16)
437 ;; (princ " (UTF-16)")
438 )
8285fa96 439 ((eq type 'shift-jis)
02e91426 440 (princ " (Shift-JIS, MS-KANJI)"))
2c390c27 441 ((eq type 'iso-2022)
02e91426
SM		 442 (princ " (variant of ISO-2022)\n")
443 (princ "Initial designations:\n")
8285fa96
DL		 444 (print-designation (coding-system-get coding-system
445 :designation))
446
447 (when (coding-system-get coding-system :flags)
448 (princ "Other specifications: \n ")
449 (apply #'print-list
450 (coding-system-get coding-system :flags))))
2c390c27
KH		 451 ((eq type 'charset)
452 (princ " (charset)"))
453 ((eq type 'ccl)
02e91426 454 (princ " (do conversion by CCL program)"))
2c390c27 455 ((eq type 'raw-text)
02e91426 456 (princ " (text with random binary characters)"))
9be33434
DL		 457 ((eq type 'emacs-mule)
458 (princ " (Emacs 21 internal encoding)"))
2c390c27 459 (t (princ ": invalid coding-system.")))
753fd9ca 460 (princ "\nEOL type: ")
426f97dc
KH		 461 (let ((eol-type (coding-system-eol-type coding-system)))
462 (cond ((vectorp eol-type)
463 (princ "Automatic selection from:\n\t")
464 (princ eol-type)
465 (princ "\n"))
466 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
467 ((eq eol-type 1) (princ "CRLF\n"))
468 ((eq eol-type 2) (princ "CR\n"))
469 (t (princ "invalid\n")))))
3a1ef8f5 470 (let ((postread (coding-system-get coding-system :post-read-conversion)))
ff8909d8 471 (when postread
71527e5d
DL		 472 (princ "After decoding text normally,")
473 (princ " perform post-conversion using the function: ")
ff8909d8
KH		 474 (princ "\n ")
475 (princ postread)
476 (princ "\n")))
3a1ef8f5 477 (let ((prewrite (coding-system-get coding-system :pre-write-conversion)))
ff8909d8 478 (when prewrite
71527e5d
DL		 479 (princ "Before encoding text normally,")
480 (princ " perform pre-conversion using the function: ")
ff8909d8
KH		 481 (princ "\n ")
482 (princ prewrite)
483 (princ "\n")))
55140940 484 (with-current-buffer standard-output
9be33434
DL		 485 (let ((charsets (coding-system-charset-list coding-system)))
486 (when (and (not (eq (coding-system-base coding-system) 'raw-text))
97b14492 487 charsets)
9be33434
DL		 488 (cond
489 ((eq charsets 'iso-2022)
490 (insert "This coding system can encode all ISO 2022 charsets."))
491 ((eq charsets 'emacs-mule)
492 (insert "This coding system can encode all emacs-mule charsets\
493."""))
494 (t
71527e5d 495 (insert "This coding system encodes the following charsets:\n ")
a399ef7b
KH		 496 (while charsets
497 (insert " " (symbol-name (car charsets)))
498 (search-backward (symbol-name (car charsets)))
e8cdeaca 499 (help-xref-button 0 'help-character-set (car charsets))
a399ef7b 500 (goto-char (point-max))
9be33434 501 (setq charsets (cdr charsets)))))))))))
4ed46869
KH		 502
503;;;###autoload
504(defun describe-current-coding-system-briefly ()
795a5f84 505 "Display coding systems currently used in a brief format in echo area.
4ed46869 506
795a5f84 507The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
4ed46869 508where mnemonics of the following coding systems come in this order
7cc8aac3 509in place of `..':
187bd11c
SS		 510 `buffer-file-coding-system' (of the current buffer)
511 eol-type of `buffer-file-coding-system' (of the current buffer)
4527adca 512 Value returned by `keyboard-coding-system'
187bd11c
SS		 513 eol-type of `keyboard-coding-system'
514 Value returned by `terminal-coding-system'.
515 eol-type of `terminal-coding-system'
4527adca 516 `process-coding-system' for read (of the current buffer, if any)
187bd11c 517 eol-type of `process-coding-system' for read (of the current buffer, if any)
4527adca 518 `process-coding-system' for write (of the current buffer, if any)
187bd11c 519 eol-type of `process-coding-system' for write (of the current buffer, if any)
4527adca 520 `default-buffer-file-coding-system'
187bd11c 521 eol-type of `default-buffer-file-coding-system'
4527adca 522 `default-process-coding-system' for read
187bd11c 523 eol-type of `default-process-coding-system' for read
4527adca 524 `default-process-coding-system' for write
187bd11c 525 eol-type of `default-process-coding-system'"
4ed46869
KH		 526 (interactive)
527 (let* ((proc (get-buffer-process (current-buffer)))
528 (process-coding-systems (if proc (process-coding-system proc))))
529 (message
bb89cd2a 530 "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 531 (coding-system-mnemonic buffer-file-coding-system)
795a5f84 532 (coding-system-eol-type-mnemonic buffer-file-coding-system)
4ed46869 533 (coding-system-mnemonic (keyboard-coding-system))
795a5f84 534 (coding-system-eol-type-mnemonic (keyboard-coding-system))
4ed46869 535 (coding-system-mnemonic (terminal-coding-system))
795a5f84 536 (coding-system-eol-type-mnemonic (terminal-coding-system))
4ed46869 537 (coding-system-mnemonic (car process-coding-systems))
795a5f84 538 (coding-system-eol-type-mnemonic (car process-coding-systems))
4ed46869 539 (coding-system-mnemonic (cdr process-coding-systems))
795a5f84
KH		 540 (coding-system-eol-type-mnemonic (cdr process-coding-systems))
541 (coding-system-mnemonic default-buffer-file-coding-system)
542 (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
4ed46869 543 (coding-system-mnemonic (car default-process-coding-system))
795a5f84 544 (coding-system-eol-type-mnemonic (car default-process-coding-system))
4ed46869 545 (coding-system-mnemonic (cdr default-process-coding-system))
795a5f84 546 (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
4ed46869
KH		 547 )))
548
426f97dc 549(defun print-coding-system-briefly (coding-system &optional doc-string)
8f924df7
KH		 550 "Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
551If DOC-STRING is non-nil, print also the docstring of CODING-SYSTEM.
552If DOC-STRING is `tightly', don't print an empty line before the
553docstring, and print only the first line of the docstring."
795a5f84
KH		 554 (if (not coding-system)
555 (princ "nil\n")
556 (princ (format "%c -- %s"
557 (coding-system-mnemonic coding-system)
558 coding-system))
a8692ed8 559 (let ((aliases (coding-system-aliases coding-system)))
91e854f2
KH		 560 (cond ((eq coding-system (car aliases))
561 (if (cdr aliases)
562 (princ (format " %S" (cons 'alias: (cdr aliases))))))
563 ((memq coding-system aliases)
564 (princ (format " (alias of %s)" (car aliases))))
565 (t
566 (let ((eol-type (coding-system-eol-type coding-system))
567 (base-eol-type (coding-system-eol-type (car aliases))))
568 (if (and (integerp eol-type)
569 (vectorp base-eol-type)
570 (not (eq coding-system (aref base-eol-type eol-type))))
571 (princ (format " (alias of %s)"
572 (aref base-eol-type eol-type))))))))
60b898c6
KH		 573 (princ "\n")
574 (or (eq doc-string 'tightly)
575 (princ "\n"))
576 (if doc-string
577 (let ((doc (or (coding-system-doc-string coding-system) "")))
578 (when (eq doc-string 'tightly)
579 (if (string-match "\n" doc)
580 (setq doc (substring doc 0 (match-beginning 0))))
581 (setq doc (concat " " doc)))
582 (princ (format "%s\n" doc))))))
4ed46869
KH		 583
584;;;###autoload
585(defun describe-current-coding-system ()
4527adca 586 "Display coding systems currently used, in detail."
4ed46869
KH		 587 (interactive)
588 (with-output-to-temp-buffer "*Help*"
589 (let* ((proc (get-buffer-process (current-buffer)))
590 (process-coding-systems (if proc (process-coding-system proc))))
e72e91e9 591 (princ "Coding system for saving this buffer:\n ")
795a5f84
KH		 592 (if (local-variable-p 'buffer-file-coding-system)
593 (print-coding-system-briefly buffer-file-coding-system)
e72e91e9
RS		 594 (princ "Not set locally, use the default.\n"))
595 (princ "Default coding system (for new files):\n ")
795a5f84 596 (print-coding-system-briefly default-buffer-file-coding-system)
e72e91e9 597 (princ "Coding system for keyboard input:\n ")
4ed46869 598 (print-coding-system-briefly (keyboard-coding-system))
e72e91e9 599 (princ "Coding system for terminal output:\n ")
4ed46869 600 (print-coding-system-briefly (terminal-coding-system))
0fe44409
SM		 601 (when (boundp 'selection-coding-system)
602 (princ "Coding system for inter-client cut and paste:\n ")
603 (print-coding-system-briefly selection-coding-system))
e72e91e9
RS		 604 (when (get-buffer-process (current-buffer))
605 (princ "Coding systems for process I/O:\n")
606 (princ " encoding input to the process: ")
607 (print-coding-system-briefly (cdr process-coding-systems))
608 (princ " decoding output from the process: ")
609 (print-coding-system-briefly (car process-coding-systems)))
1b76aedd 610 (princ "Defaults for subprocess I/O:\n")
795a5f84 611 (princ " decoding: ")
4ed46869 612 (print-coding-system-briefly (car default-process-coding-system))
795a5f84
KH		 613 (princ " encoding: ")
614 (print-coding-system-briefly (cdr default-process-coding-system)))
426f97dc 615
55140940 616 (with-current-buffer standard-output
426f97dc 617
7cc8aac3
PJ		 618 (princ "
619Priority order for recognizing coding systems when reading files:\n")
2c390c27
KH		 620 (let ((i 1))
621 (dolist (elt (coding-system-priority-list))
622 (princ (format " %d. %s " i elt))
623 (let ((aliases (coding-system-aliases elt)))
624 (if (eq elt (car aliases))
ff8909d8
KH		 625 (if (cdr aliases)
626 (princ (cons 'alias: (cdr aliases))))
2c390c27 627 (princ (list 'alias 'of (car aliases))))
5cfcd8bc 628 (terpri)
2c390c27 629 (setq i (1+ i)))))
ff8909d8 630
426f97dc
KH		 631 (princ "\n Other coding systems cannot be distinguished automatically
632 from these, and therefore cannot be recognized automatically
633 with the present coding system priorities.\n\n")
634
a8692ed8 635 ;; Fixme: should this be replaced or junked?
2c390c27 636 (if nil
b585fb6c 637 (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
426f97dc
KH		 638 coding-system codings)
639 (while categories
640 (setq coding-system (symbol-value (car categories)))
1249c1d1 641 (mapc
02e91426
SM		 642 (lambda (x)
643 (if (and (not (eq x coding-system))
feff73a4
DL		 644 (let ((flags (coding-system-get :flags)))
645 (not (or (memq 'use-roman flags)
646 (memq 'use-oldjis flags)))))
02e91426 647 (setq codings (cons x codings))))
426f97dc
KH		 648 (get (car categories) 'coding-systems))
649 (if codings
92c15c34 650 (let ((max-col (window-width))
426f97dc 651 pos)
7cc8aac3
PJ		 652 (princ (format "\
653 The following are decoded correctly but recognized as %s:\n "
654 coding-system))
426f97dc
KH		 655 (while codings
656 (setq pos (point))
657 (insert (format " %s" (car codings)))
4472a77b
KH		 658 (when (> (current-column) max-col)
659 (goto-char pos)
660 (insert "\n ")
661 (goto-char (point-max)))
426f97dc
KH		 662 (setq codings (cdr codings)))
663 (insert "\n\n")))
2c390c27 664 (setq categories (cdr categories)))))
426f97dc 665
e72e91e9 666 (princ "Particular coding systems specified for certain file names:\n")
426f97dc
KH		 667 (terpri)
668 (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
669 (princ " ---------\t--------------\t\t----------------\n")
670 (let ((func (lambda (operation alist)
671 (princ " ")
672 (princ operation)
673 (if (not alist)
674 (princ "\tnothing specified\n")
675 (while alist
676 (indent-to 16)
677 (prin1 (car (car alist)))
ff8909d8
KH		 678 (if (>= (current-column) 40)
679 (newline))
426f97dc
KH		 680 (indent-to 40)
681 (princ (cdr (car alist)))
682 (princ "\n")
683 (setq alist (cdr alist)))))))
684 (funcall func "File I/O" file-coding-system-alist)
685 (funcall func "Process I/O" process-coding-system-alist)
686 (funcall func "Network I/O" network-coding-system-alist))
687 (help-mode))))
4ed46869 688
ff8909d8 689(defun print-coding-system (coding-system)
3a1ef8f5 690 "Print detailed information on CODING-SYSTEM."
4ed46869 691 (let ((type (coding-system-type coding-system))
795a5f84 692 (eol-type (coding-system-eol-type coding-system))
feff73a4 693 (flags (coding-system-get coding-system :flags))
a8692ed8 694 (aliases (coding-system-aliases coding-system)))
ff8909d8
KH		 695 (if (not (eq (car aliases) coding-system))
696 (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
795a5f84 697 (princ coding-system)
ff8909d8 698 (setq aliases (cdr aliases))
795a5f84 699 (while aliases
4472a77b
KH		 700 (princ ",")
701 (princ (car aliases))
702 (setq aliases (cdr aliases)))
795a5f84
KH		 703 (princ (format ":%s:%c:%d:"
704 type
705 (coding-system-mnemonic coding-system)
706 (if (integerp eol-type) eol-type 3)))
feff73a4 707 (cond ((eq type 'iso2022)
795a5f84
KH		 708 (let ((idx 0)
709 charset)
710 (while (< idx 4)
711 (setq charset (aref flags idx))
712 (cond ((null charset)
713 (princ -1))
714 ((eq charset t)
715 (princ -2))
716 ((charsetp charset)
717 (princ charset))
718 ((listp charset)
719 (princ "(")
4ed46869 720 (princ (car charset))
795a5f84
KH		 721 (setq charset (cdr charset))
722 (while charset
723 (princ ",")
724 (princ (car charset))
725 (setq charset (cdr charset)))
726 (princ ")")))
727 (princ ",")
728 (setq idx (1+ idx)))
729 (while (< idx 12)
730 (princ (if (aref flags idx) 1 0))
731 (princ ",")
732 (setq idx (1+ idx)))
733 (princ (if (aref flags idx) 1 0))))
feff73a4 734 ((eq type 'ccl)
795a5f84 735 (let (i len)
0d5f1e3a
RS		 736 (if (symbolp (car flags))
737 (princ (format " %s" (car flags)))
738 (setq i 0 len (length (car flags)))
739 (while (< i len)
740 (princ (format " %x" (aref (car flags) i)))
741 (setq i (1+ i))))
4ed46869 742 (princ ",")
0d5f1e3a
RS		 743 (if (symbolp (cdr flags))
744 (princ (format "%s" (cdr flags)))
745 (setq i 0 len (length (cdr flags)))
746 (while (< i len)
747 (princ (format " %x" (aref (cdr flags) i)))
748 (setq i (1+ i))))))
795a5f84
KH		 749 (t (princ 0)))
750 (princ ":")
751 (princ (coding-system-doc-string coding-system))
752 (princ "\n"))))
4ed46869 753
795a5f84 754;;;###autoload
4472a77b
KH		 755(defun list-coding-systems (&optional arg)
756 "Display a list of all coding systems.
4527adca 757This shows the mnemonic letter, name, and description of each coding system.
4472a77b
KH		 758
759With prefix arg, the output format gets more cryptic,
4527adca 760but still contains full information about each coding system."
4472a77b 761 (interactive "P")
4ed46869 762 (with-output-to-temp-buffer "*Help*"
13cef08d
KH		 763 (list-coding-systems-1 arg)))
764
765(defun list-coding-systems-1 (arg)
766 (if (null arg)
767 (princ "\
795a5f84
KH		 768###############################################
769# List of coding systems in the following format:
770# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
60b898c6 771# DOC-STRING
795a5f84 772")
13cef08d 773 (princ "\
4ed46869
KH		 774#########################
775## LIST OF CODING SYSTEMS
776## Each line corresponds to one coding system
777## Format of a line is:
795a5f84
KH		 778## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
779## :PRE-WRITE-CONVERSION:DOC-STRING,
4ed46869 780## where
795a5f84
KH		 781## NAME = coding system name
782## ALIAS = alias of the coding system
783## TYPE = nil (no conversion), t (undecided or automatic detection),
784## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
4ed46869
KH		 785## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
786## FLAGS =
787## if TYPE = 2 then
92c15c34 788## comma (`,') separated data of the following:
4ed46869
KH		 789## G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
790## LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
791## else if TYPE = 4 then
792## comma (`,') separated CCL programs for read and write
793## else
794## 0
795a5f84 795## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
4ed46869 796##
795a5f84 797"))
60b898c6
KH		 798 (dolist (coding-system (sort-coding-systems (coding-system-list 'base-only)))
799 (if (null arg)
800 (print-coding-system-briefly coding-system 'tightly)
801 (print-coding-system coding-system))))
4472a77b 802
a8692ed8 803;; Fixme: delete?
867ef43a 804;;;###autoload
4472a77b
KH		 805(defun list-coding-categories ()
806 "Display a list of all coding categories."
807 (with-output-to-temp-buffer "*Help*"
808 (princ "\
4ed46869
KH		 809############################
810## LIST OF CODING CATEGORIES (ordered by priority)
811## CATEGORY:CODING-SYSTEM
812##
813")
4472a77b
KH		 814 (let ((l coding-category-list))
815 (while l
816 (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
817 (setq l (cdr l))))))
4ed46869
KH		 818\f
819;;; FONT
820
4ed46869 821(defun describe-font-internal (font-info &optional verbose)
3a1ef8f5 822 "Print information about a font in FONT-INFO."
4ed46869
KH		 823 (print-list "name (opened by):" (aref font-info 0))
824 (print-list " full name:" (aref font-info 1))
b1e3566c
KH		 825 (print-list " size:" (format "%2d" (aref font-info 2)))
826 (print-list " height:" (format "%2d" (aref font-info 3)))
827 (print-list " baseline-offset:" (format "%2d" (aref font-info 4)))
828 (print-list "relative-compose:" (format "%2d" (aref font-info 5))))
4ed46869
KH		 829
830;;;###autoload
831(defun describe-font (fontname)
fca31fbb
KH		 832 "Display information about a font whose name is FONTNAME.
833The font must be already used by Emacs."
834 (interactive "sFont name (default current choice for ASCII chars): ")
ee5f768d 835 (or (and window-system (fboundp 'fontset-list))
fca31fbb 836 (error "No fonts being used"))
7736dabe
KH		 837 (let (font-info)
838 (if (or (not fontname) (= (length fontname) 0))
839 (setq fontname (face-attribute 'default :font)))
fca31fbb 840 (setq font-info (font-info fontname))
4ed46869 841 (if (null font-info)
7736dabe 842 (if (fontp fontname 'font-object)
fca31fbb
KH		 843 ;; The font should be surely used. So, there's some
844 ;; problem about getting information about it. It is
845 ;; better to print the fontname to show which font has
846 ;; this problem.
7736dabe
KH		 847 (message "No information about \"%s\"" (font-xlfd-name fontname))
848 (message "No matching font found"))
4ed46869
KH		 849 (with-output-to-temp-buffer "*Help*"
850 (describe-font-internal font-info 'verbose)))))
851
5c117135
KH		 852(defun print-fontset-element (val)
853 ;; VAL has this format:
854 ;; ((REQUESTED-FONT-NAME OPENED-FONT-NAME ...) ...)
855 ;; CHAR RANGE is already inserted. Get character codes from
856 ;; the current line.
857 (beginning-of-line)
858 (let ((from (following-char))
859 (to (if (looking-at "[^.]*[.]* ")
860 (char-after (match-end 0)))))
861 (if (re-search-forward "[ \t]*$" nil t)
862 (delete-region (match-beginning 0) (match-end 0)))
863
864 ;; For non-ASCII characters, insert also CODE RANGE.
865 (if (or (>= from 128) (and to (>= to 128)))
866 (if to
867 (insert (format " (#x%02X .. #x%02X)" from to))
868 (insert (format " (#x%02X)" from))))
869
870 ;; Insert a requested font name.
871 (dolist (elt val)
e94848ea
KH		 872 (if (not elt)
873 (insert "\n -- inhibit fallback fonts --")
874 (let ((requested (car elt)))
875 (if (stringp requested)
876 (insert "\n " requested)
877 (let (family registry weight slant width adstyle)
878 (if (and (fboundp 'fontp) (fontp requested))
879 (setq family (font-get requested :family)
880 registry (font-get requested :registry)
881 weight (font-get requested :weight)
882 slant (font-get requested :slant)
883 width (font-get requested :width)
884 adstyle (font-get requested :adstyle))
885 (setq family (aref requested 0)
886 registry (aref requested 5)
887 weight (aref requested 1)
888 slant (aref requested 2)
889 width (aref requested 3)
890 adstyle (aref requested 4)))
891 (if (not family)
892 (setq family "*-*")
893 (if (symbolp family)
894 (setq family (symbol-name family)))
895 (or (string-match "-" family)
896 (setq family (concat "*-" family))))
897 (if (not registry)
898 (setq registry "*-*")
899 (if (symbolp registry)
900 (setq registry (symbol-name registry)))
901 (or (string-match "-" registry)
902 (= (aref registry (1- (length registry))) ?*)
903 (setq registry (concat registry "*"))))
904 (insert (format"\n -%s-%s-%s-%s-%s-*-*-*-*-*-*-%s"
905 family (or weight "*") (or slant "*") (or width "*")
906 (or adstyle "*") registry)))))
907
908 ;; Insert opened font names (if any).
909 (if (and (boundp 'print-opened) (symbol-value 'print-opened))
910 (dolist (opened (cdr elt))
911 (insert "\n\t[" opened "]")))))))
5c117135
KH		 912
913(defun print-fontset (fontset &optional print-opened)
7cc8aac3 914 "Print information about FONTSET.
c0e70a9f 915If FONTSET is nil, print information about the default fontset.
5c117135 916If optional arg PRINT-OPENED is non-nil, also print names of all opened
7cc8aac3
PJ		 917fonts for FONTSET. This function actually inserts the information in
918the current buffer."
c0e70a9f
KH		 919 (or fontset
920 (setq fontset (query-fontset "fontset-default")))
b827d571
KH		 921 (beginning-of-line)
922 (insert "Fontset: " fontset "\n")
5c117135
KH		 923 (insert (propertize "CHAR RANGE" 'face 'underline)
924 " (" (propertize "CODE RANGE" 'face 'underline) ")\n")
925 (insert " " (propertize "FONT NAME" 'face 'underline)
926 " (" (propertize "REQUESTED" 'face 'underline)
927 " and [" (propertize "OPENED" 'face 'underline) "])")
928 (let ((info (fontset-info fontset)))
929 (describe-vector info 'print-fontset-element)
930 (insert "\n ---<fallback to the default fontset>---")
931 (describe-vector (char-table-extra-slot info 0) 'print-fontset-element)))
4ed46869
KH		 932
933;;;###autoload
934(defun describe-fontset (fontset)
7cc8aac3 935 "Display information about FONTSET.
b1e3566c 936This shows which font is used for which character(s)."
4ed46869 937 (interactive
ee5f768d 938 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 939 (error "No fontsets being used")
71527e5d 940 (let ((fontset-list (nconc
f95b7b89
SM		 941 (fontset-list)
942 (mapcar 'cdr fontset-alias-alist)))
4472a77b
KH		 943 (completion-ignore-case t))
944 (list (completing-read
5b76833f 945 "Fontset (default used by the current frame): "
4472a77b
KH		 946 fontset-list nil t)))))
947 (if (= (length fontset) 0)
c0e70a9f
KH		 948 (setq fontset (frame-parameter nil 'font)))
949 (setq fontset (query-fontset fontset))
55140940
SM		 950 (help-setup-xref (list #'describe-fontset fontset) (interactive-p))
951 (with-output-to-temp-buffer (help-buffer)
952 (with-current-buffer standard-output
b1e3566c 953 (print-fontset fontset t))))
4472a77b
KH		 954
955;;;###autoload
956(defun list-fontsets (arg)
957 "Display a list of all fontsets.
4527adca 958This shows the name, size, and style of each fontset.
7cc8aac3 959With prefix arg, also list the fonts contained in each fontset;
4527adca 960see the function `describe-fontset' for the format of the list."
4472a77b 961 (interactive "P")
ee5f768d 962 (if (not (and window-system (fboundp 'fontset-list)))
effd4e82 963 (error "No fontsets being used")
55140940
SM		 964 (help-setup-xref (list #'list-fontsets arg) (interactive-p))
965 (with-output-to-temp-buffer (help-buffer)
966 (with-current-buffer standard-output
13cef08d 967 ;; This code is duplicated near the end of mule-diag.
dc1f8c72
KH		 968 (let ((fontsets
969 (sort (fontset-list)
02e91426
SM		 970 (lambda (x y)
971 (string< (fontset-plain-name x)
972 (fontset-plain-name y))))))
effd4e82 973 (while fontsets
b1e3566c
KH		 974 (if arg
975 (print-fontset (car fontsets) nil)
976 (insert "Fontset: " (car fontsets) "\n"))
effd4e82 977 (setq fontsets (cdr fontsets))))))))
426f97dc
KH		 978\f
979;;;###autoload
980(defun list-input-methods ()
4527adca 981 "Display information about all input methods."
426f97dc 982 (interactive)
02e91426
SM		 983 (help-setup-xref '(list-input-methods) (interactive-p))
984 (with-output-to-temp-buffer (help-buffer)
7cc8aac3
PJ		 985 (list-input-methods-1)
986 (with-current-buffer standard-output
987 (save-excursion
988 (goto-char (point-min))
989 (while (re-search-forward
990 "^ \\([^ ]+\\) (`.*' in mode line)$" nil t)
ee592269 991 (help-xref-button 1 'help-input-method (match-string 1)))))))
13cef08d
KH		 992
993(defun list-input-methods-1 ()
994 (if (not input-method-alist)
995 (progn
996 (princ "
10de7378
PJ		 997No input method is available, perhaps because you have not
998installed LEIM (Libraries of Emacs Input Methods)."))
13cef08d
KH		 999 (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
1000 (princ " SHORT-DESCRIPTION\n------------------------------\n")
1001 (setq input-method-alist
1002 (sort input-method-alist
02e91426 1003 (lambda (x y) (string< (nth 1 x) (nth 1 y)))))
13cef08d
KH		 1004 (let ((l input-method-alist)
1005 language elt)
1006 (while l
1007 (setq elt (car l) l (cdr l))
1008 (when (not (equal language (nth 1 elt)))
1009 (setq language (nth 1 elt))
1010 (princ language)
1011 (terpri))
1012 (princ (format " %s (`%s' in mode line)\n %s\n"
1013 (car elt)
1014 (let ((title (nth 3 elt)))
1015 (if (and (consp title) (stringp (car title)))
1016 (car title)
1017 title))
1018 (let ((description (nth 4 elt)))
1019 (string-match ".*" description)
1020 (match-string 0 description))))))))
4ed46869
KH		 1021\f
1022;;; DIAGNOSIS
1023
4472a77b
KH		 1024;; Insert a header of a section with SECTION-NUMBER and TITLE.
1025(defun insert-section (section-number title)
4ed46869 1026 (insert "########################################\n"
4472a77b 1027 "# Section " (format "%d" section-number) ". " title "\n"
4ed46869
KH		 1028 "########################################\n\n"))
1029
1030;;;###autoload
1031(defun mule-diag ()
3fdaafa6 1032 "Display diagnosis of the multilingual environment (Mule).
4472a77b 1033
4527adca 1034This shows various information related to the current multilingual
4472a77b 1035environment, including lists of input methods, coding systems,
4527adca 1036character sets, and fontsets (if Emacs is running under a window
effd4e82 1037system which uses fontsets)."
4ed46869 1038 (interactive)
4472a77b 1039 (with-output-to-temp-buffer "*Mule-Diagnosis*"
55140940 1040 (with-current-buffer standard-output
13cef08d
KH		 1041 (insert "###############################################\n"
1042 "### Current Status of Multilingual Features ###\n"
1043 "###############################################\n\n"
4ed46869
KH		 1044 "CONTENTS: Section 1. General Information\n"
1045 " Section 2. Display\n"
1046 " Section 3. Input methods\n"
1047 " Section 4. Coding systems\n"
4472a77b 1048 " Section 5. Character sets\n")
ee5f768d 1049 (if (and window-system (fboundp 'fontset-list))
4472a77b 1050 (insert " Section 6. Fontsets\n"))
4ed46869
KH		 1051 (insert "\n")
1052
1053 (insert-section 1 "General Information")
7bce107c 1054 (insert "Version of this emacs:\n " (emacs-version) "\n\n")
cbbe6489
KH		 1055 (insert "Configuration options:\n " system-configuration-options "\n\n")
1056 (insert "Multibyte characters awareness:\n"
1057 (format " default: %S\n" default-enable-multibyte-characters)
1058 (format " current-buffer: %S\n\n" enable-multibyte-characters))
1059 (insert "Current language environment: " current-language-environment
1060 "\n\n")
4ed46869
KH		 1061
1062 (insert-section 2 "Display")
1063 (if window-system
1064 (insert "Window-system: "
1065 (symbol-name window-system)
1066 (format "%s" window-system-version))
1067 (insert "Terminal: " (getenv "TERM")))
1068 (insert "\n\n")
1069
1070 (if (eq window-system 'x)
1071 (let ((font (cdr (assq 'font (frame-parameters)))))
1072 (insert "The selected frame is using the "
1073 (if (query-fontset font) "fontset" "font")
1074 ":\n\t" font))
1075 (insert "Coding system of the terminal: "
1076 (symbol-name (terminal-coding-system))))
1077 (insert "\n\n")
1078
1079 (insert-section 3 "Input methods")
13cef08d 1080 (list-input-methods-1)
4ed46869
KH		 1081 (insert "\n")
1082 (if default-input-method
d4b11c67 1083 (insert (format "Default input method: %s\n" default-input-method))
1b76aedd 1084 (insert "No default input method is specified\n"))
4ed46869
KH		 1085
1086 (insert-section 4 "Coding systems")
13cef08d 1087 (list-coding-systems-1 t)
4ed46869
KH		 1088 (insert "\n")
1089
4472a77b 1090 (insert-section 5 "Character sets")
efdd2d79 1091 (list-character-sets-2)
4ed46869
KH		 1092 (insert "\n")
1093
ee5f768d 1094 (when (and window-system (fboundp 'fontset-list))
13cef08d 1095 ;; This code duplicates most of list-fontsets.
4472a77b 1096 (insert-section 6 "Fontsets")
13cef08d
KH		 1097 (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
1098 (insert "------------\t\t\t\t\t\t ----- -----\n")
1099 (let ((fontsets (fontset-list)))
1100 (while fontsets
1101 (print-fontset (car fontsets) t)
1102 (setq fontsets (cdr fontsets)))))
eabe0ad3 1103 (print-help-return-message))))
4ed46869 1104
8f924df7 1105;;;###autoload
a7a75a47
DL		 1106(defcustom unicodedata-file nil
1107 "Location of UnicodeData file.
1108This is the UnicodeData.txt file from the Unicode consortium, used for
1109diagnostics. If it is non-nil `describe-char-after' will print data
1110looked up from it."
1111 :group 'mule
1112 :type '(choice (const :tag "None" nil)
1113 file))
1114
1115;; We could convert the unidata file into a Lispy form once-for-all
1116;; and distribute it for loading on demand. It might be made more
1117;; space-efficient by splitting strings word-wise and replacing them
1118;; with lists of symbols interned in a private obarray, e.g.
1119;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
8f924df7
KH		 1120
1121;;;###autoload
a7a75a47
DL		 1122(defun unicode-data (char)
1123 "Return a list of Unicode data for unicode CHAR.
1124Each element is a list of a property description and the property value.
1125The list is null if CHAR isn't found in `unicodedata-file'."
42ea0349
DL		 1126 (when unicodedata-file
1127 (unless (file-exists-p unicodedata-file)
1128 (error "`unicodedata-file' %s not found" unicodedata-file))
1129 (save-excursion
724a86cc 1130 (set-buffer (find-file-noselect unicodedata-file t t))
42ea0349
DL		 1131 (goto-char (point-min))
1132 (let ((hex (format "%04X" char))
1133 found first last)
1134 (if (re-search-forward (concat "^" hex) nil t)
1135 (setq found t)
1136 ;; It's not listed explicitly. Look for ranges, e.g. CJK
1137 ;; ideographs, and check whether it's in one of them.
1138 (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
1139 (>= char (setq first
1140 (string-to-number (match-string 1) 16)))
1141 (progn
1142 (forward-line 1)
1143 (looking-at "^\\([^;]+\\);[^;]+Last>;")
1144 (> char
1145 (setq last
1146 (string-to-number (match-string 1) 16))))))
1147 (if (and (>= char first)
1148 (<= char last))
1149 (setq found t)))
1150 (if found
1151 (let ((fields (mapcar (lambda (elt)
1152 (if (> (length elt) 0)
1153 elt))
1154 (cdr (split-string
1155 (buffer-substring
1156 (line-beginning-position)
1157 (line-end-position))
1158 ";")))))
1159 ;; The length depends on whether the last field was empty.
1160 (unless (or (= 13 (length fields))
1161 (= 14 (length fields)))
1162 (error "Invalid contents in %s" unicodedata-file))
1163 ;; The field names and values lists are slightly
1164 ;; modified from Mule-UCS unidata.el.
1165 (list
1166 (list "Name" (let ((name (nth 0 fields)))
1167 ;; Check for <..., First>, <..., Last>
1168 (if (string-match "\\`\\(<[^,]+\\)," name)
1169 (concat (match-string 1 name) ">")
1170 name)))
1171 (list "Category"
1172 (cdr (assoc
1173 (nth 1 fields)
1174 '(("Lu" . "uppercase letter")
1175 ("Ll" . "lowercase letter")
1176 ("Lt" . "titlecase letter")
1177 ("Mn" . "non-spacing mark")
1178 ("Mc" . "spacing-combining mark")
1179 ("Me" . "enclosing mark")
1180 ("Nd" . "decimal digit")
1181 ("Nl" . "letter number")
1182 ("No" . "other number")
1183 ("Zs" . "space separator")
1184 ("Zl" . "line separator")
1185 ("Zp" . "paragraph separator")
1186 ("Cc" . "other control")
1187 ("Cf" . "other format")
1188 ("Cs" . "surrogate")
1189 ("Co" . "private use")
1190 ("Cn" . "not assigned")
1191 ("Lm" . "modifier letter")
1192 ("Lo" . "other letter")
1193 ("Pc" . "connector punctuation")
1194 ("Pd" . "dash punctuation")
1195 ("Ps" . "open punctuation")
1196 ("Pe" . "close punctuation")
1197 ("Pi" . "initial-quotation punctuation")
1198 ("Pf" . "final-quotation punctuation")
1199 ("Po" . "other punctuation")
1200 ("Sm" . "math symbol")
1201 ("Sc" . "currency symbol")
1202 ("Sk" . "modifier symbol")
1203 ("So" . "other symbol")))))
1204 (list "Combining class"
1205 (cdr (assoc
1206 (string-to-number (nth 2 fields))
1207 '((0 . "Spacing")
1208 (1 . "Overlays and interior")
bc01a178 1209 (7 . "Nuktas")
42ea0349
DL		 1210 (8 . "Hiragana/Katakana voicing marks")
1211 (9 . "Viramas")
1212 (10 . "Start of fixed position classes")
1213 (199 . "End of fixed position classes")
1214 (200 . "Below left attached")
1215 (202 . "Below attached")
1216 (204 . "Below right attached")
1217 (208 . "Left attached (reordrant around \
a7a75a47 1218single base character)")
42ea0349
DL		 1219 (210 . "Right attached")
1220 (212 . "Above left attached")
1221 (214 . "Above attached")
1222 (216 . "Above right attached")
1223 (218 . "Below left")
1224 (220 . "Below")
1225 (222 . "Below right")
1226 (224 . "Left (reordrant around single base \
a7a75a47 1227character)")
42ea0349
DL		 1228 (226 . "Right")
1229 (228 . "Above left")
1230 (230 . "Above")
1231 (232 . "Above right")
1232 (233 . "Double below")
1233 (234 . "Double above")
1234 (240 . "Below (iota subscript)")))))
1235 (list "Bidi category"
1236 (cdr (assoc
1237 (nth 3 fields)
1238 '(("L" . "Left-to-Right")
1239 ("LRE" . "Left-to-Right Embedding")
1240 ("LRO" . "Left-to-Right Override")
1241 ("R" . "Right-to-Left")
1242 ("AL" . "Right-to-Left Arabic")
1243 ("RLE" . "Right-to-Left Embedding")
1244 ("RLO" . "Right-to-Left Override")
1245 ("PDF" . "Pop Directional Format")
1246 ("EN" . "European Number")
1247 ("ES" . "European Number Separator")
1248 ("ET" . "European Number Terminator")
1249 ("AN" . "Arabic Number")
1250 ("CS" . "Common Number Separator")
1251 ("NSM" . "Non-Spacing Mark")
1252 ("BN" . "Boundary Neutral")
1253 ("B" . "Paragraph Separator")
1254 ("S" . "Segment Separator")
1255 ("WS" . "Whitespace")
1256 ("ON" . "Other Neutrals")))))
1257 (list "Decomposition"
1258 (if (nth 4 fields)
1259 (let* ((parts (split-string (nth 4 fields)))
1260 (info (car parts)))
1261 (if (string-match "\\`<\\(.+\\)>\\'" info)
1262 (setq info (match-string 1 info))
1263 (setq info nil))
1264 (if info (setq parts (cdr parts)))
1265 (setq parts (mapconcat
1266 (lambda (arg)
1267 (string (string-to-number arg 16)))
1268 parts " "))
1269 (concat info parts))))
1270 (list "Decimal digit value"
fa64065b 1271 (nth 5 fields))
42ea0349 1272 (list "Digit value"
fa64065b 1273 (nth 6 fields))
42ea0349 1274 (list "Numeric value"
fa64065b 1275 (nth 7 fields))
42ea0349
DL		 1276 (list "Mirrored"
1277 (if (equal "Y" (nth 8 fields))
1278 "yes"))
1279 (list "Old name" (nth 9 fields))
1280 (list "ISO 10646 comment" (nth 10 fields))
1281 (list "Uppercase" (and (nth 11 fields)
1282 (string (string-to-number
1283 (nth 11 fields) 16))))
1284 (list "Lowercase" (and (nth 12 fields)
1285 (string (string-to-number
1286 (nth 12 fields) 16))))
1287 (list "Titlecase" (and (nth 13 fields)
1288 (string (string-to-number
1289 (nth 13 fields) 16)))))))))))
a7a75a47 1290
fa5ee889
KH		 1291;;;###autoload
1292(defun font-show-log ()
af6061b1 1293 "Show log of font listing and opening."
fa5ee889
KH		 1294 (interactive)
1295 (if (eq font-log t)
1296 (message "Font logging is currently suppressed")
1297 (with-output-to-temp-buffer "*Help*"
1298 (set-buffer standard-output)
1299 (dolist (elt (reverse font-log))
1300 (insert (format "%s: %s\n" (car elt) (cadr elt)))
1301 (setq elt (nth 2 elt))
1302 (if (or (vectorp elt) (listp elt))
bcd79f83
KH		 1303 (let ((limit 20)
1304 (i 0))
1305 (catch 'tag
1306 (mapc #'(lambda (x)
1307 (setq i (1+ i))
1308 (when (= i 20)
1309 (insert " ...\n")
1310 (throw 'tag nil))
1311 (insert (format " %s\n" x)))
1312 elt)))
fa5ee889
KH		 1313 (insert (format " %s\n" elt)))))))
1314
1315
bfe77626
DL		 1316(provide 'mule-diag)
1317
cbee283d 1318;; arch-tag: cd3b607c-2893-45a0-a4fa-a6535754dbee
795a5f84 1319;;; mule-diag.el ends here
Unnamed repository; edit this file 'description' to name the repository.