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