code.delx.au - gnu-emacs/blob - lisp/international/mule-diag.el

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