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

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