lisp/international/mule-diag.el

   1 ;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
   2
   3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   5
   6 ;; Keywords: multilingual, charset, coding system, fontset, diagnosis
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; General utility function
  26
  27 ;; Print all arguments with single space separator in one line.
  28 (defun print-list (&rest args)
  29   (while (cdr args)
  30     (when (car args)
  31       (princ (car args))
  32       (princ " "))
  33     (setq args (cdr args)))
  34   (princ (car args))
  35   (princ "\n"))
  36
  37 ;; Re-order the elements of charset-list.
  38 (defun sort-charset-list ()
  39   (setq charset-list
  40         (sort charset-list
  41               (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
  42
  43 ;;; CHARSET
  44
  45 ;;;###autoload
  46 (defun list-character-sets (&optional arg)
  47   "Display a list of all character sets.
  48
  49 The ID column contains a charset identification number for internal use.
  50 The B column contains a number of bytes occupied in a buffer.
  51 The W column contains a number of columns occupied in a screen.
  52
  53 With prefix arg, the output format gets more cryptic
  54 but contains full information about each character sets."
  55   (interactive "P")
  56   (sort-charset-list)
  57   (with-output-to-temp-buffer "*Help*"
  58     (save-excursion
  59       (set-buffer standard-output)
  60       (let ((l charset-list)
  61             charset)
  62         (if (null arg)
  63             (progn
  64               (insert "ID  Name             B W Description\n")
  65               (insert "--  ----             - - -----------\n")
  66               (while l
  67                 (setq charset (car l) l (cdr l))
  68                 (insert (format "%03d %s" (charset-id charset) charset))
  69                 (indent-to 28)
  70                 (insert (format "%d %d %s\n"
  71                                 (charset-bytes charset)
  72                                 (charset-width charset)
  73                                 (charset-description charset)))))
  74           (insert "\
  75 #########################
  76 ## LIST OF CHARSETS
  77 ## Each line corresponds to one charset.
  78 ## The following attributes are listed in this order
  79 ## separated by a colon `:' in one line.
  80 ##      CHARSET-ID,
  81 ##      CHARSET-SYMBOL-NAME,
  82 ##      DIMENSION (1 or 2)
  83 ##      CHARS (94 or 96)
  84 ##      BYTES (of multibyte form: 1, 2, 3, or 4),
  85 ##      WIDTH (occupied column numbers: 1 or 2),
  86 ##      DIRECTION (0:left-to-right, 1:right-to-left),
  87 ##      ISO-FINAL-CHAR (character code of ISO-2022's final character)
  88 ##      ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
  89 ##      DESCRIPTION (describing string of the charset)
  90 ")
  91           (while l
  92             (setq charset (car l) l (cdr l))
  93             (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
  94                            (charset-id charset)
  95                            charset
  96                            (charset-dimension charset)
  97                            (charset-chars charset)
  98                            (charset-bytes charset)
  99                            (charset-width charset)
 100                            (charset-direction charset)
 101                            (charset-iso-final-char charset)
 102                            (charset-iso-graphic-plane charset)
 103                            (charset-description charset))))))
 104       (help-mode)
 105       (setq truncate-lines t))))
 106 \f
 107 ;;; CODING-SYSTEM
 108
 109 ;; Print information of designation of each graphic register in FLAGS
 110 ;; in human readable format.  See the documentation of
 111 ;; `make-coding-system' for the meaning of FLAGS.
 112 (defun print-designation (flags)
 113   (let ((graphic-register 0)
 114         charset)
 115     (while (< graphic-register 4)
 116       (setq charset (aref flags graphic-register))
 117       (princ (format
 118               "  G%d -- %s\n"
 119               graphic-register
 120               (cond ((null charset)
 121                      "never used")
 122                     ((eq charset t)
 123                      "no initial designation, and used by any charsets")
 124                     ((symbolp charset)
 125                      (format "%s:%s"
 126                              charset (charset-description charset)))
 127                     ((listp charset)
 128                      (if (charsetp (car charset))
 129                          (format "%s:%s, and also used by the followings:"
 130                                  (car charset)
 131                                  (charset-description (car charset)))
 132                        "no initial designation, and used by the followings:"))
 133                     (t
 134                      "invalid designation information"))))
 135       (when (listp charset)
 136         (setq charset (cdr charset))
 137         (while charset
 138           (cond ((eq (car charset) t)
 139                  (princ "\tany other charsets\n"))
 140                 ((charsetp (car charset))
 141                  (princ (format "\t%s:%s\n"
 142                                 (car charset)
 143                                 (charset-description (car charset)))))
 144                 (t
 145                  "invalid designation information"))
 146           (setq charset (cdr charset))))
 147       (setq graphic-register (1+ graphic-register)))))
 148
 149 ;;;###autoload
 150 (defun describe-coding-system (coding-system)
 151   "Display information of CODING-SYSTEM."
 152   (interactive "zDescribe coding system (default, current choices): ")
 153   (if (null coding-system)
 154       (describe-current-coding-system)
 155     (with-output-to-temp-buffer "*Help*"
 156       (print-coding-system-briefly coding-system 'doc-string)
 157       (let ((coding-spec (coding-system-spec coding-system)))
 158         (princ "Type: ")
 159         (let ((type (coding-system-type coding-system))
 160               (flags (coding-system-flags coding-system)))
 161           (princ type)
 162           (cond ((eq type nil)
 163                  (princ " (do no conversion)"))
 164                 ((eq type t)
 165                  (princ " (do automatic conversion)"))
 166                 ((eq type 0)
 167                  (princ " (Emacs internal multibyte form)"))
 168                 ((eq type 1)
 169                  (princ " (Shift-JIS, MS-KANJI)"))
 170                 ((eq type 2)
 171                  (princ " (variant of ISO-2022)\n")
 172                  (princ "Initial designations:\n")
 173                  (print-designation flags)
 174                  (princ "Other Form: \n  ")
 175                  (princ (if (aref flags 4) "short-form" "long-form"))
 176                  (if (aref flags 5) (princ ", ASCII@EOL"))
 177                  (if (aref flags 6) (princ ", ASCII@CNTL"))
 178                  (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
 179                  (if (aref flags 8) (princ ", use-locking-shift"))
 180                  (if (aref flags 9) (princ ", use-single-shift"))
 181                  (if (aref flags 10) (princ ", use-roman"))
 182                  (if (aref flags 10) (princ ", use-old-jis"))
 183                  (if (aref flags 11) (princ ", no-ISO6429"))
 184                  (princ "."))
 185                 ((eq type 3)
 186                  (princ " (Big5)"))
 187                 ((eq type 4)
 188                  (princ " (do conversion by CCL program)"))
 189                 (t (princ "invalid coding-system."))))
 190         (princ "\nEOL type:\n  ")
 191         (let ((eol-type (coding-system-eol-type coding-system)))
 192           (cond ((vectorp eol-type)
 193                  (princ "Automatic selection from:\n\t")
 194                  (princ eol-type)
 195                  (princ "\n"))
 196                 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
 197                 ((eq eol-type 1) (princ "CRLF\n"))
 198                 ((eq eol-type 2) (princ "CR\n"))
 199                 (t (princ "invalid\n")))))
 200       (save-excursion
 201         (set-buffer standard-output)
 202         (help-mode)))))
 203
 204 ;;;###autoload
 205 (defun describe-current-coding-system-briefly ()
 206   "Display coding systems currently used in a brief format in echo area.
 207
 208 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
 209 where mnemonics of the following coding systems come in this order
 210 at the place of `..':
 211   buffer-file-coding-system (of the current buffer)
 212   eol-type of buffer-file-coding-system (of the current buffer)
 213   (keyboard-coding-system)
 214   eol-type of (keyboard-coding-system)
 215   (terminal-coding-system)
 216   eol-type of (terminal-coding-system)
 217   process-coding-system for read (of the current buffer, if any)
 218   eol-type of process-coding-system for read (of the current buffer, if any)
 219   process-coding-system for write (of the current buffer, if any)
 220   eol-type of process-coding-system for write (of the current buffer, if any)
 221   default-buffer-file-coding-system
 222   eol-type of default-buffer-file-coding-system
 223   default-process-coding-system for read
 224   eol-type of default-process-coding-system for read
 225   default-process-coding-system for write
 226   eol-type of default-process-coding-system"
 227   (interactive)
 228   (let* ((proc (get-buffer-process (current-buffer)))
 229          (process-coding-systems (if proc (process-coding-system proc))))
 230     (message
 231      "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]"
 232      (coding-system-mnemonic buffer-file-coding-system)
 233      (coding-system-eol-type-mnemonic buffer-file-coding-system)
 234      (coding-system-mnemonic (keyboard-coding-system))
 235      (coding-system-eol-type-mnemonic (keyboard-coding-system))
 236      (coding-system-mnemonic (terminal-coding-system))
 237      (coding-system-eol-type-mnemonic (terminal-coding-system))
 238      (coding-system-mnemonic (car process-coding-systems))
 239      (coding-system-eol-type-mnemonic (car process-coding-systems))
 240      (coding-system-mnemonic (cdr process-coding-systems))
 241      (coding-system-eol-type-mnemonic (cdr process-coding-systems))
 242      (coding-system-mnemonic default-buffer-file-coding-system)
 243      (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
 244      (coding-system-mnemonic (car default-process-coding-system))
 245      (coding-system-eol-type-mnemonic (car default-process-coding-system))
 246      (coding-system-mnemonic (cdr default-process-coding-system))
 247      (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
 248      )))
 249
 250 ;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'.
 251 (defun print-coding-system-briefly (coding-system &optional doc-string)
 252   (if (not coding-system)
 253       (princ "nil\n")
 254     (princ (format "%c -- %s"
 255                    (coding-system-mnemonic coding-system)
 256                    coding-system))
 257     (let ((parent (coding-system-parent coding-system)))
 258       (if parent
 259           (princ (format " (alias of %s)" parent))))
 260     (let ((aliases (get coding-system 'alias-coding-systems)))
 261       (if aliases
 262           (princ (format " %S" (cons 'alias: aliases)))))
 263     (princ "\n")
 264     (if (and doc-string
 265              (setq doc-string (coding-system-doc-string coding-system)))
 266         (princ (format "  %s\n" doc-string)))))
 267
 268 ;;;###autoload
 269 (defun describe-current-coding-system ()
 270   "Display coding systems currently used in a detailed format."
 271   (interactive)
 272   (with-output-to-temp-buffer "*Help*"
 273     (let* ((proc (get-buffer-process (current-buffer)))
 274            (process-coding-systems (if proc (process-coding-system proc))))
 275       (princ "Coding system for saving this buffer:\n  ")
 276       (if (local-variable-p 'buffer-file-coding-system)
 277           (print-coding-system-briefly buffer-file-coding-system)
 278         (princ "Not set locally, use the default.\n"))
 279       (princ "Default coding system (for new files):\n  ")
 280       (print-coding-system-briefly default-buffer-file-coding-system)
 281       (princ "Coding system for keyboard input:\n  ")
 282       (print-coding-system-briefly (keyboard-coding-system))
 283       (princ "Coding system for terminal output:\n  ")
 284       (print-coding-system-briefly (terminal-coding-system))
 285       (when (get-buffer-process (current-buffer))
 286         (princ "Coding systems for process I/O:\n")
 287         (princ "  encoding input to the process: ")
 288         (print-coding-system-briefly (cdr process-coding-systems))
 289         (princ "  decoding output from the process: ")
 290         (print-coding-system-briefly (car process-coding-systems)))
 291       (princ "Defaults for subprocess I/O:")
 292       (princ "  decoding: ")
 293       (print-coding-system-briefly (car default-process-coding-system))
 294       (princ "  encoding: ")
 295       (print-coding-system-briefly (cdr default-process-coding-system)))
 296
 297     (save-excursion
 298       (set-buffer standard-output)
 299
 300       (princ "\nPriority order for recognizing coding systems when reading files:\n")
 301       (let ((l coding-category-list)
 302             (i 1)
 303             (coding-list nil)
 304             coding aliases)
 305         (while l
 306           (setq coding (symbol-value (car l)))
 307           (when (not (memq coding coding-list))
 308             (setq coding-list (cons coding coding-list))
 309             (princ (format "  %d. %s" i coding))
 310             (when (setq aliases (get coding 'alias-coding-systems))
 311               (princ " ")
 312               (princ (cons 'alias: aliases)))
 313             (terpri)
 314             (setq i (1+ i)))
 315           (setq l (cdr l))))
 316       (princ "\n  Other coding systems cannot be distinguished automatically
 317   from these, and therefore cannot be recognized automatically
 318   with the present coding system priorities.\n\n")
 319
 320       (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
 321             coding-system codings)
 322         (while categories
 323           (setq coding-system (symbol-value (car categories)))
 324           (mapcar
 325            (function
 326             (lambda (x)
 327               (if (and (not (eq x coding-system))
 328                        (get x 'no-initial-designation)
 329                        (let ((flags (coding-system-flags x)))
 330                          (not (or (aref flags 10) (aref flags 11)))))
 331                   (setq codings (cons x codings)))))
 332            (get (car categories) 'coding-systems))
 333           (if codings
 334               (let ((max-col (frame-width))
 335                     pos)
 336                 (princ (format "  The followings are decoded correctly but recognized as %s:\n   " coding-system))
 337                 (while codings
 338                   (setq pos (point))
 339                   (insert (format " %s" (car codings)))
 340                   (when (> (current-column) max-col)
 341                     (goto-char pos)
 342                     (insert "\n   ")
 343                     (goto-char (point-max)))
 344                   (setq codings (cdr codings)))
 345                 (insert "\n\n")))
 346           (setq categories (cdr categories))))
 347
 348       (princ "Particular coding systems specified for certain file names:\n")
 349       (terpri)
 350       (princ "  OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
 351       (princ "  ---------\t--------------\t\t----------------\n")
 352       (let ((func (lambda (operation alist)
 353                     (princ "  ")
 354                     (princ operation)
 355                     (if (not alist)
 356                         (princ "\tnothing specified\n")
 357                       (while alist
 358                         (indent-to 16)
 359                         (prin1 (car (car alist)))
 360                         (indent-to 40)
 361                         (princ (cdr (car alist)))
 362                         (princ "\n")
 363                         (setq alist (cdr alist)))))))
 364         (funcall func "File I/O" file-coding-system-alist)
 365         (funcall func "Process I/O" process-coding-system-alist)
 366         (funcall func "Network I/O" network-coding-system-alist))
 367       (help-mode))))
 368
 369 ;; Print detailed information on CODING-SYSTEM.
 370 (defun print-coding-system (coding-system &optional aliases)
 371   (let ((type (coding-system-type coding-system))
 372         (eol-type (coding-system-eol-type coding-system))
 373         (flags (coding-system-flags coding-system))
 374         (base (coding-system-base coding-system)))
 375     (if (not (eq base coding-system))
 376         (princ (format "%s (alias of %s)\n" coding-system base))
 377       (princ coding-system)
 378       (while aliases
 379         (princ ",")
 380         (princ (car aliases))
 381         (setq aliases (cdr aliases)))
 382       (princ (format ":%s:%c:%d:"
 383                      type
 384                      (coding-system-mnemonic coding-system)
 385                      (if (integerp eol-type) eol-type 3)))
 386       (cond ((eq type 2)                ; ISO-2022
 387              (let ((idx 0)
 388                    charset)
 389                (while (< idx 4)
 390                  (setq charset (aref flags idx))
 391                  (cond ((null charset)
 392                         (princ -1))
 393                        ((eq charset t)
 394                         (princ -2))
 395                        ((charsetp charset)
 396                         (princ charset))
 397                        ((listp charset)
 398                         (princ "(")
 399                         (princ (car charset))
 400                         (setq charset (cdr charset))
 401                         (while charset
 402                           (princ ",")
 403                           (princ (car charset))
 404                           (setq charset (cdr charset)))
 405                         (princ ")")))
 406                  (princ ",")
 407                  (setq idx (1+ idx)))
 408                (while (< idx 12)
 409                  (princ (if (aref flags idx) 1 0))
 410                  (princ ",")
 411                  (setq idx (1+ idx)))
 412                (princ (if (aref flags idx) 1 0))))
 413             ((eq type 4)                ; CCL
 414              (let (i len)
 415                (setq i 0 len (length (car flags)))
 416                (while (< i len)
 417                  (princ (format " %x" (aref (car flags) i)))
 418                  (setq i (1+ i)))
 419                (princ ",")
 420                (setq i 0 len (length (cdr flags)))
 421                (while (< i len)
 422                  (princ (format " %x" (aref (cdr flags) i)))
 423                  (setq i (1+ i)))))
 424             (t (princ 0)))
 425       (princ ":")
 426       (princ (coding-system-doc-string coding-system))
 427       (princ "\n"))))
 428
 429 ;;;###autoload
 430 (defun list-coding-systems (&optional arg)
 431   "Display a list of all coding systems.
 432 It prints mnemonic letter, name, and description of each coding systems.
 433
 434 With prefix arg, the output format gets more cryptic,
 435 but contains full information about each coding systems."
 436   (interactive "P")
 437   (with-output-to-temp-buffer "*Help*"
 438     (if (null arg)
 439         (princ "\
 440 ###############################################
 441 # List of coding systems in the following format:
 442 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
 443 #       DOC-STRING
 444 ")
 445       (princ "\
 446 #########################
 447 ## LIST OF CODING SYSTEMS
 448 ## Each line corresponds to one coding system
 449 ## Format of a line is:
 450 ##   NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
 451 ##      :PRE-WRITE-CONVERSION:DOC-STRING,
 452 ## where
 453 ##  NAME = coding system name
 454 ##  ALIAS = alias of the coding system
 455 ##  TYPE = nil (no conversion), t (undecided or automatic detection),
 456 ##         0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
 457 ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
 458 ##  FLAGS =
 459 ##    if TYPE = 2 then
 460 ##      comma (`,') separated data of the followings:
 461 ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
 462 ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
 463 ##    else if TYPE = 4 then
 464 ##      comma (`,') separated CCL programs for read and write
 465 ##    else
 466 ##      0
 467 ##  POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
 468 ##
 469 "))
 470     (let ((bases (coding-system-list 'base-only))
 471           coding-system)
 472       (while bases
 473         (setq coding-system (car bases))
 474         (if (null arg)
 475             (print-coding-system-briefly coding-system 'doc-string)
 476           (print-coding-system coding-system))
 477         (setq bases (cdr bases))))))
 478
 479 ;;;###automatic
 480 (defun list-coding-categories ()
 481   "Display a list of all coding categories."
 482   (with-output-to-temp-buffer "*Help*"
 483     (princ "\
 484 ############################
 485 ## LIST OF CODING CATEGORIES (ordered by priority)
 486 ## CATEGORY:CODING-SYSTEM
 487 ##
 488 ")
 489     (let ((l coding-category-list))
 490       (while l
 491         (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
 492         (setq l (cdr l))))))
 493 \f
 494 ;;; FONT
 495
 496 ;; Print information of a font in FONTINFO.
 497 (defun describe-font-internal (font-info &optional verbose)
 498   (print-list "name (opened by):" (aref font-info 0))
 499   (print-list "       full name:" (aref font-info 1))
 500   (let ((charset (aref font-info 2)))
 501     (print-list "   charset:"
 502                 (format "%s (%s)" charset (charset-description charset))))
 503   (print-list "            size:" (format "%d" (aref font-info 3)))
 504   (print-list "          height:" (format "%d" (aref font-info 4)))
 505   (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
 506   (print-list "relative-compose:" (format "%d" (aref font-info 6))))
 507
 508 ;;;###autoload
 509 (defun describe-font (fontname)
 510   "Display information about fonts which partially match FONTNAME."
 511   (interactive "sFontname (default, current choise for ASCII chars): ")
 512   (or window-system
 513       (error "No window system being used"))
 514   (when (or (not fontname) (= (length fontname) 0))
 515     (setq fontname (cdr (assq 'font (frame-parameters))))
 516     (if (query-fontset fontname)
 517         (setq fontname
 518               (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
 519   (let ((font-info (font-info fontname)))
 520     (if (null font-info)
 521         (message "No matching font")
 522       (with-output-to-temp-buffer "*Help*"
 523         (describe-font-internal font-info 'verbose)))))
 524
 525 ;; Print information of FONTSET.  If optional arg PRINT-FONTS is
 526 ;; non-nil, print also names of all fonts in FONTSET.  This function
 527 ;; actually INSERT such information in the current buffer.
 528 (defun print-fontset (fontset &optional print-fonts)
 529   (let* ((fontset-info (fontset-info fontset))
 530          (size (aref fontset-info 0))
 531          (height (aref fontset-info 1))
 532          (fonts (and print-fonts (aref fontset-info 2)))
 533          (xlfd-fields (x-decompose-font-name fontset))
 534          style)
 535     (if xlfd-fields
 536         (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
 537               (slant  (aref xlfd-fields xlfd-regexp-slant-subnum)))
 538           (if (string-match "^bold$\\|^demibold$" weight)
 539               (setq style (concat weight " "))
 540             (setq style "medium "))
 541           (cond ((string-match "^i$" slant)
 542                  (setq style (concat style "italic")))
 543                 ((string-match "^o$" slant)
 544                  (setq style (concat style "slant")))
 545                 ((string-match "^ri$" slant)
 546                  (setq style (concat style "reverse italic")))
 547                 ((string-match "^ro$" slant)
 548                  (setq style (concat style "reverse slant")))))
 549       (setq style " ? "))
 550     (beginning-of-line)
 551     (insert fontset)
 552     (indent-to 58)
 553     (insert (if (> size 0) (format "%2dx%d" size height) "  -"))
 554     (indent-to 64)
 555     (insert style "\n")
 556     (when print-fonts
 557       (insert "  O Charset / Fontname\n"
 558               "  - ------------------\n")
 559       (sort-charset-list)
 560       (let ((l charset-list)
 561             charset font-info opened fontname)
 562         (while l
 563           (setq charset (car l) l (cdr l))
 564           (setq font-info (assq charset fonts))
 565           (if (null font-info)
 566               (setq opened ?? fontname "not specified")
 567             (if (nth 2 font-info)
 568                 (if (stringp (nth 2 font-info))
 569                     (setq opened ?o fontname (nth 2 font-info))
 570                   (setq opened ?- fontname (nth 1 font-info)))
 571               (setq opened ?x fontname (nth 1 font-info))))
 572           (insert (format "  %c %s\n    %s\n"
 573                           opened charset fontname)))))))
 574
 575 ;;;###autoload
 576 (defun describe-fontset (fontset)
 577   "Display information of FONTSET.
 578
 579 It prints name, size, and style of FONTSET, and lists up fonts
 580 contained in FONTSET.
 581
 582 The column WDxHT contains width and height (pixels) of each fontset
 583 \(i.e. those of ASCII font in the fontset).  The letter `-' in this
 584 column means that the corresponding fontset is not yet used in any
 585 frame.
 586
 587 The O column of each font contains one of the following letters.
 588  o -- font already opened
 589  - -- font not yet opened
 590  x -- font can't be opened
 591  ? -- no font specified
 592
 593 The Charset column of each font contains a name of character set
 594 displayed by the font."
 595   (interactive
 596    (if (not window-system)
 597        (error "No window system being used")
 598      (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
 599            (completion-ignore-case t))
 600        (list (completing-read
 601               "Fontset (default, used by the current frame): "
 602               fontset-list nil t)))))
 603   (if (= (length fontset) 0)
 604       (setq fontset (cdr (assq 'font (frame-parameters)))))
 605   (if (not (query-fontset fontset))
 606       (error "Current frame is using font, not fontset"))
 607   (let ((fontset-info (fontset-info fontset)))
 608     (with-output-to-temp-buffer "*Help*"
 609       (save-excursion
 610         (set-buffer standard-output)
 611         (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 612         (insert "------------\t\t\t\t\t\t  ----- -----\n")
 613         (print-fontset fontset t)))))
 614
 615 ;;;###autoload
 616 (defun list-fontsets (arg)
 617   "Display a list of all fontsets.
 618
 619 It prints name, size, and style of each fontset.
 620 With prefix arg, it also lists up fonts contained in each fontset.
 621 See the function `describe-fontset' for the format of the list."
 622   (interactive "P")
 623   (with-output-to-temp-buffer "*Help*"
 624     (save-excursion
 625       (set-buffer standard-output)
 626       (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 627       (insert "------------\t\t\t\t\t\t  ----- -----\n")
 628       (let ((fontsets (fontset-list)))
 629         (while fontsets
 630           (print-fontset (car fontsets) arg)
 631           (setq fontsets (cdr fontsets)))))))
 632 \f
 633 ;;;###autoload
 634 (defun list-input-methods ()
 635   "Print information of all input methods."
 636   (interactive)
 637   (with-output-to-temp-buffer "*Help*"
 638     (princ "LANGUAGE\n  NAME (`TITLE' in mode line)\n")
 639     (princ "    SHORT-DESCRIPTION\n------------------------------\n")
 640     (setq input-method-alist
 641           (sort input-method-alist
 642                 (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
 643     (let ((l input-method-alist)
 644           language elt)
 645       (while l
 646         (setq elt (car l) l (cdr l))
 647         (when (not (equal language (nth 1 elt)))
 648           (setq language (nth 1 elt))
 649           (princ language)
 650           (terpri))
 651         (princ (format "  %s (`%s' in mode line)\n    %s\n"
 652                        (car elt) (nth 3 elt)
 653                        (let ((title (nth 4 elt)))
 654                          (string-match ".*" title)
 655                          (match-string 0 title))))))))
 656 \f
 657 ;;; DIAGNOSIS
 658
 659 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
 660 (defun insert-section (section-number title)
 661   (insert "########################################\n"
 662           "# Section " (format "%d" section-number) ".  " title "\n"
 663           "########################################\n\n"))
 664
 665 ;;;###autoload
 666 (defun mule-diag ()
 667   "Display diagnosis of the multilingual environment (MULE).
 668
 669 It prints various information related to the current multilingual
 670 environment, including lists of input methods, coding systems,
 671 character sets, and fontsets (if Emacs running under some window
 672 system)."
 673   (interactive)
 674   (with-output-to-temp-buffer "*Mule-Diagnosis*"
 675     (save-excursion
 676       (set-buffer standard-output)
 677       (insert "\t###############################\n"
 678               "\t### Diagnosis of your Emacs ###\n"
 679               "\t###############################\n\n"
 680               "CONTENTS: Section 1.  General Information\n"
 681               "          Section 2.  Display\n"
 682               "          Section 3.  Input methods\n"
 683               "          Section 4.  Coding systems\n"
 684               "          Section 5.  Character sets\n")
 685       (if window-system
 686           (insert "          Section 6.  Fontsets\n"))
 687       (insert "\n")
 688
 689       (insert-section 1 "General Information")
 690       (insert "Version of this emacs:\n  " (emacs-version) "\n\n")
 691
 692       (insert-section 2 "Display")
 693       (if window-system
 694           (insert "Window-system: "
 695                   (symbol-name window-system)
 696                   (format "%s" window-system-version))
 697         (insert "Terminal: " (getenv "TERM")))
 698       (insert "\n\n")
 699
 700       (if (eq window-system 'x)
 701           (let ((font (cdr (assq 'font (frame-parameters)))))
 702             (insert "The selected frame is using the "
 703                     (if (query-fontset font) "fontset" "font")
 704                     ":\n\t" font))
 705         (insert "Coding system of the terminal: "
 706                 (symbol-name (terminal-coding-system))))
 707       (insert "\n\n")
 708
 709       (insert-section 3 "Input methods")
 710       (save-excursion (list-input-methods))
 711       (insert-buffer-substring "*Help*")
 712       (insert "\n")
 713       (if default-input-method
 714           (insert "Default input method: %s\n" default-input-method)
 715         (insert "No default input method is specified.\n"))
 716
 717       (insert-section 4 "Coding systems")
 718       (save-excursion (list-coding-systems t))
 719       (insert-buffer-substring "*Help*")
 720       (list-coding-categories)
 721       (insert-buffer-substring "*Help*")
 722       (insert "\n")
 723
 724       (insert-section 5 "Character sets")
 725       (list-character-sets t)
 726       (insert-buffer-substring "*Help*")
 727       (insert "\n")
 728
 729       (when window-system
 730         (insert-section 6 "Fontsets")
 731         (list-fontsets t)
 732         (insert-buffer-substring "*Help*"))
 733       (help-mode))))
 734
 735 \f
 736 ;;; DUMP DATA FILE
 737
 738 ;;;###autoload
 739 (defun dump-charsets ()
 740   "Dump information of all charsets into the file \"CHARSETS\".
 741 The file is saved in the directory `data-directory'."
 742   (let ((file (expand-file-name "CHARSETS" data-directory))
 743         buf)
 744     (or (file-writable-p file)
 745         (error "Can't write to file %s" file))
 746     (setq buf (find-file-noselect file))
 747     (save-window-excursion
 748       (save-excursion
 749         (set-buffer buf)
 750         (setq buffer-read-only nil)
 751         (erase-buffer)
 752         (list-character-sets t)
 753         (insert-buffer-substring "*Help*")
 754         (let (make-backup-files
 755               coding-system-for-write)
 756           (save-buffer))))
 757     (kill-buffer buf))
 758   (if noninteractive
 759       (kill-emacs)))
 760
 761 ;;;###autoload
 762 (defun dump-codings ()
 763   "Dump information of all coding systems into the file \"CODINGS\".
 764 The file is saved in the directory `data-directory'."
 765   (let ((file (expand-file-name "CODINGS" data-directory))
 766         buf)
 767     (or (file-writable-p file)
 768         (error "Can't write to file %s" file))
 769     (setq buf (find-file-noselect file))
 770     (save-window-excursion
 771       (save-excursion
 772         (set-buffer buf)
 773         (setq buffer-read-only nil)
 774         (erase-buffer)
 775         (list-coding-systems t)
 776         (insert-buffer-substring "*Help*")
 777         (list-coding-categories)
 778         (insert-buffer-substring "*Help*")
 779         (let (make-backup-files
 780               coding-system-for-write)
 781           (save-buffer))))
 782     (kill-buffer buf))
 783   (if noninteractive
 784       (kill-emacs)))
 785
 786 ;;; mule-diag.el ends here