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