lisp/international/mule-diag.el

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