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