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

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