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
   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 "Current buffer file: buffer-file-coding-system\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 following default.\n"))
 279       (princ "Default buffer file: default-buffer-file-coding-system\n  ")
 280       (print-coding-system-briefly default-buffer-file-coding-system)
 281       (princ "Keyboard: (keyboard-coding-system)\n  ")
 282       (print-coding-system-briefly (keyboard-coding-system))
 283       (princ "Terminal: (display-coding-system)\n  ")
 284       (print-coding-system-briefly (terminal-coding-system))
 285       (princ "Current buffer process: (process-coding-system)\n")
 286       (if (not process-coding-systems)
 287           (princ "  No process.\n")
 288         (princ "  decoding: ")
 289         (print-coding-system-briefly (car process-coding-systems))
 290         (princ "  encoding: ")
 291         (print-coding-system-briefly (cdr process-coding-systems)))
 292       (princ "Default process: default-process-coding-system\n")
 293       (princ "  decoding: ")
 294       (print-coding-system-briefly (car default-process-coding-system))
 295       (princ "  encoding: ")
 296       (print-coding-system-briefly (cdr default-process-coding-system)))
 297
 298     (save-excursion
 299       (set-buffer standard-output)
 300
 301       (princ "\nPriority order of coding systems:\n")
 302       (let ((l coding-category-list)
 303             (i 1)
 304             coding aliases)
 305         (while l
 306           (setq coding (symbol-value (car l)))
 307           (princ (format "  %d. %s" i coding))
 308           (when (setq aliases (get coding 'alias-coding-systems))
 309             (princ " ")
 310             (princ (cons 'alias: aliases)))
 311           (terpri)
 312           (setq l (cdr l) i (1+ i))))
 313       (princ "\n  Other coding systems cannot be distinguished automatically
 314   from these, and therefore cannot be recognized automatically
 315   with the present coding system priorities.\n\n")
 316
 317       (let ((categories '(coding-category-iso-7 coding-category-iso-else))
 318             coding-system codings)
 319         (while categories
 320           (setq coding-system (symbol-value (car categories)))
 321           (mapcar
 322            (function
 323             (lambda (x)
 324               (if (and (not (eq x coding-system))
 325                        (get x 'no-initial-designation)
 326                        (let ((flags (coding-system-flags x)))
 327                          (not (or (aref flags 10) (aref flags 11)))))
 328                   (setq codings (cons x codings)))))
 329            (get (car categories) 'coding-systems))
 330           (if codings
 331               (let ((max-col (frame-width))
 332                     pos)
 333                 (princ (format "  The followings are decoded correctly but recognized as %s:\n   " coding-system))
 334                 (while codings
 335                   (setq pos (point))
 336                   (insert (format " %s" (car codings)))
 337                   (when (> (current-column) max-col)
 338                     (goto-char pos)
 339                     (insert "\n   ")
 340                     (goto-char (point-max)))
 341                   (setq codings (cdr codings)))
 342                 (insert "\n\n")))
 343           (setq categories (cdr categories))))
 344
 345       (princ "Look up tables for finding a coding system on I/O operations:\n")
 346       (terpri)
 347       (princ "  OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
 348       (princ "  ---------\t--------------\t\t----------------\n")
 349       (let ((func (lambda (operation alist)
 350                     (princ "  ")
 351                     (princ operation)
 352                     (if (not alist)
 353                         (princ "\tnothing specified\n")
 354                       (while alist
 355                         (indent-to 16)
 356                         (prin1 (car (car alist)))
 357                         (indent-to 40)
 358                         (princ (cdr (car alist)))
 359                         (princ "\n")
 360                         (setq alist (cdr alist)))))))
 361         (funcall func "File I/O" file-coding-system-alist)
 362         (funcall func "Process I/O" process-coding-system-alist)
 363         (funcall func "Network I/O" network-coding-system-alist))
 364       (help-mode))))
 365
 366 ;; Print detailed information on CODING-SYSTEM.
 367 (defun print-coding-system (coding-system &optional aliases)
 368   (let ((type (coding-system-type coding-system))
 369         (eol-type (coding-system-eol-type coding-system))
 370         (flags (coding-system-flags coding-system))
 371         (base (coding-system-base coding-system)))
 372     (if (not (eq base coding-system))
 373         (princ (format "%s (alias of %s)\n" coding-system base))
 374       (princ coding-system)
 375       (while aliases
 376         (princ ",")
 377         (princ (car aliases))
 378         (setq aliases (cdr aliases)))
 379       (princ (format ":%s:%c:%d:"
 380                      type
 381                      (coding-system-mnemonic coding-system)
 382                      (if (integerp eol-type) eol-type 3)))
 383       (cond ((eq type 2)                ; ISO-2022
 384              (let ((idx 0)
 385                    charset)
 386                (while (< idx 4)
 387                  (setq charset (aref flags idx))
 388                  (cond ((null charset)
 389                         (princ -1))
 390                        ((eq charset t)
 391                         (princ -2))
 392                        ((charsetp charset)
 393                         (princ charset))
 394                        ((listp charset)
 395                         (princ "(")
 396                         (princ (car charset))
 397                         (setq charset (cdr charset))
 398                         (while charset
 399                           (princ ",")
 400                           (princ (car charset))
 401                           (setq charset (cdr charset)))
 402                         (princ ")")))
 403                  (princ ",")
 404                  (setq idx (1+ idx)))
 405                (while (< idx 12)
 406                  (princ (if (aref flags idx) 1 0))
 407                  (princ ",")
 408                  (setq idx (1+ idx)))
 409                (princ (if (aref flags idx) 1 0))))
 410             ((eq type 4)                ; CCL
 411              (let (i len)
 412                (setq i 0 len (length (car flags)))
 413                (while (< i len)
 414                  (princ (format " %x" (aref (car flags) i)))
 415                  (setq i (1+ i)))
 416                (princ ",")
 417                (setq i 0 len (length (cdr flags)))
 418                (while (< i len)
 419                  (princ (format " %x" (aref (cdr flags) i)))
 420                  (setq i (1+ i)))))
 421             (t (princ 0)))
 422       (princ ":")
 423       (princ (coding-system-doc-string coding-system))
 424       (princ "\n"))))
 425
 426 ;;;###autoload
 427 (defun list-coding-systems (&optional arg)
 428   "Display a list of all coding systems.
 429 It prints mnemonic letter, name, and description of each coding systems.
 430
 431 With prefix arg, the output format gets more cryptic,
 432 but contains full information about each coding systems."
 433   (interactive "P")
 434   (with-output-to-temp-buffer "*Help*"
 435     (if (null arg)
 436         (princ "\
 437 ###############################################
 438 # List of coding systems in the following format:
 439 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
 440 #       DOC-STRING
 441 ")
 442       (princ "\
 443 #########################
 444 ## LIST OF CODING SYSTEMS
 445 ## Each line corresponds to one coding system
 446 ## Format of a line is:
 447 ##   NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
 448 ##      :PRE-WRITE-CONVERSION:DOC-STRING,
 449 ## where
 450 ##  NAME = coding system name
 451 ##  ALIAS = alias of the coding system
 452 ##  TYPE = nil (no conversion), t (undecided or automatic detection),
 453 ##         0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
 454 ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
 455 ##  FLAGS =
 456 ##    if TYPE = 2 then
 457 ##      comma (`,') separated data of the followings:
 458 ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
 459 ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
 460 ##    else if TYPE = 4 then
 461 ##      comma (`,') separated CCL programs for read and write
 462 ##    else
 463 ##      0
 464 ##  POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
 465 ##
 466 "))
 467     (let ((bases (coding-system-list 'base-only))
 468           coding-system)
 469       (while bases
 470         (setq coding-system (car bases))
 471         (if (interactive-p)
 472             (print-coding-system-briefly coding-system 'doc-string)
 473           (print-coding-system coding-system))
 474         (setq bases (cdr bases))))))
 475
 476 ;;;###automatic
 477 (defun list-coding-categories ()
 478   "Display a list of all coding categories."
 479   (with-output-to-temp-buffer "*Help*"
 480     (princ "\
 481 ############################
 482 ## LIST OF CODING CATEGORIES (ordered by priority)
 483 ## CATEGORY:CODING-SYSTEM
 484 ##
 485 ")
 486     (let ((l coding-category-list))
 487       (while l
 488         (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
 489         (setq l (cdr l))))))
 490 \f
 491 ;;; FONT
 492
 493 ;; Print information of a font in FONTINFO.
 494 (defun describe-font-internal (font-info &optional verbose)
 495   (print-list "name (opened by):" (aref font-info 0))
 496   (print-list "       full name:" (aref font-info 1))
 497   (let ((charset (aref font-info 2)))
 498     (print-list "   charset:"
 499                 (format "%s (%s)" charset (charset-description charset))))
 500   (print-list "            size:" (format "%d" (aref font-info 3)))
 501   (print-list "          height:" (format "%d" (aref font-info 4)))
 502   (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
 503   (print-list "relative-compose:" (format "%d" (aref font-info 6))))
 504
 505 ;;;###autoload
 506 (defun describe-font (fontname)
 507   "Display information about fonts which partially match FONTNAME."
 508   (interactive "sFontname (default, current choise for ASCII chars): ")
 509   (or window-system
 510       (error "No window system being used"))
 511   (when (or (not fontname) (= (length fontname) 0))
 512     (setq fontname (cdr (assq 'font (frame-parameters))))
 513     (if (query-fontset fontname)
 514         (setq fontname
 515               (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
 516   (let ((font-info (font-info fontname)))
 517     (if (null font-info)
 518         (message "No matching font")
 519       (with-output-to-temp-buffer "*Help*"
 520         (describe-font-internal font-info 'verbose)))))
 521
 522 ;; Print information of FONTSET.  If optional arg PRINT-FONTS is
 523 ;; non-nil, print also names of all fonts in FONTSET.  This function
 524 ;; actually INSERT such information in the current buffer.
 525 (defun print-fontset (fontset &optional print-fonts)
 526   (let* ((fontset-info (fontset-info fontset))
 527          (size (aref fontset-info 0))
 528          (height (aref fontset-info 1))
 529          (fonts (and print-fonts (aref fontset-info 2)))
 530          (xlfd-fields (x-decompose-font-name fontset))
 531          (weight (aref xlfd-fields xlfd-regexp-weight-subnum))
 532          (slant  (aref xlfd-fields xlfd-regexp-slant-subnum))
 533          style)
 534     (if (string-match "^bold$\\|^demibold$" weight)
 535         (setq style (concat weight " "))
 536       (setq style "medium "))
 537     (cond ((string-match "^i$" slant)
 538            (setq style (concat style "italic")))
 539           ((string-match "^o$" slant)
 540            (setq style (concat style "slant")))
 541           ((string-match "^ri$" slant)
 542            (setq style (concat style "reverse italic")))
 543           ((string-match "^ro$" slant)
 544            (setq style (concat style "reverse slant"))))
 545     (beginning-of-line)
 546     (insert fontset)
 547     (indent-to 58)
 548     (insert (if (> size 0) (format "%2dx%d" size height) "  -"))
 549     (indent-to 64)
 550     (insert style "\n")
 551     (when print-fonts
 552       (insert "  O Charset / Fontname\n"
 553               "  - ------------------\n")
 554       (sort-charset-list)
 555       (let ((l charset-list)
 556             charset font-info opened fontname)
 557         (while l
 558           (setq charset (car l) l (cdr l))
 559           (setq font-info (assq charset fonts))
 560           (if (null font-info)
 561               (setq opened ?? fontname "not specified")
 562             (if (nth 2 font-info)
 563                 (if (stringp (nth 2 font-info))
 564                     (setq opened ?o fontname (nth 2 font-info))
 565                   (setq opened ?- fontname (nth 1 font-info)))
 566               (setq opened ?x fontname (nth 1 font-info))))
 567           (insert (format "  %c %s\n    %s\n"
 568                           opened charset fontname)))))))
 569
 570 ;;;###autoload
 571 (defun describe-fontset (fontset)
 572   "Display information of FONTSET.
 573
 574 It prints name, size, and style of FONTSET, and lists up fonts
 575 contained in FONTSET.
 576
 577 The column WDxHT contains width and height (pixels) of each fontset
 578 \(i.e. those of ASCII font in the fontset).  The letter `-' in this
 579 column means that the corresponding fontset is not yet used in any
 580 frame.
 581
 582 The O column of each font contains one of the following letters.
 583  o -- font already opened
 584  - -- font not yet opened
 585  x -- font can't be opened
 586  ? -- no font specified
 587
 588 The Charset column of each font contains a name of character set
 589 displayed by the font."
 590   (interactive
 591    (if (not window-system)
 592        (error "No window system being used")
 593      (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
 594            (completion-ignore-case t))
 595        (list (completing-read
 596               "Fontset (default, used by the current frame): "
 597               fontset-list nil t)))))
 598   (if (= (length fontset) 0)
 599       (setq fontset (cdr (assq 'font (frame-parameters)))))
 600   (if (not (query-fontset fontset))
 601       (error "Current frame is using font, not fontset"))
 602   (let ((fontset-info (fontset-info fontset)))
 603     (with-output-to-temp-buffer "*Help*"
 604       (save-excursion
 605         (set-buffer standard-output)
 606         (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 607         (insert "------------\t\t\t\t\t\t  ----- -----\n")
 608         (print-fontset fontset t)))))
 609
 610 ;;;###autoload
 611 (defun list-fontsets (arg)
 612   "Display a list of all fontsets.
 613
 614 It prints name, size, and style of each fontset.
 615 With prefix arg, it also lists up fonts contained in each fontset.
 616 See the function `describe-fontset' for the format of the list."
 617   (interactive "P")
 618   (with-output-to-temp-buffer "*Help*"
 619     (save-excursion
 620       (set-buffer standard-output)
 621       (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 622       (insert "------------\t\t\t\t\t\t  ----- -----\n")
 623       (let ((fontsets (fontset-list)))
 624         (while fontsets
 625           (print-fontset (car fontsets) arg)
 626           (setq fontsets (cdr fontsets)))))))
 627 \f
 628 ;;;###autoload
 629 (defun list-input-methods ()
 630   "Print information of all input methods."
 631   (interactive)
 632   (with-output-to-temp-buffer "*Help*"
 633     (princ "LANGUAGE\n  NAME (`TITLE' in mode line)\n")
 634     (princ "    SHORT-DESCRIPTION\n------------------------------\n")
 635     (setq input-method-alist
 636           (sort input-method-alist
 637                 (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
 638     (let ((l input-method-alist)
 639           language elt)
 640       (while l
 641         (setq elt (car l) l (cdr l))
 642         (when (not (equal language (nth 1 elt)))
 643           (setq language (nth 1 elt))
 644           (princ language)
 645           (terpri))
 646         (princ (format "  %s (`%s' in mode line)\n    %s\n"
 647                        (car elt) (nth 3 elt)
 648                        (let ((title (nth 4 elt)))
 649                          (string-match ".*" title)
 650                          (match-string 0 title))))))))
 651 \f
 652 ;;; DIAGNOSIS
 653
 654 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
 655 (defun insert-section (section-number title)
 656   (insert "########################################\n"
 657           "# Section " (format "%d" section-number) ".  " title "\n"
 658           "########################################\n\n"))
 659
 660 ;;;###autoload
 661 (defun mule-diag ()
 662   "Display diagnosis of the multilingual environment (MULE).
 663
 664 It prints various information related to the current multilingual
 665 environment, including lists of input methods, coding systems,
 666 character sets, and fontsets (if Emacs running under some window
 667 system)."
 668   (interactive)
 669   (with-output-to-temp-buffer "*Mule-Diagnosis*"
 670     (save-excursion
 671       (set-buffer standard-output)
 672       (insert "\t###############################\n"
 673               "\t### Diagnosis of your Emacs ###\n"
 674               "\t###############################\n\n"
 675               "CONTENTS: Section 1.  General Information\n"
 676               "          Section 2.  Display\n"
 677               "          Section 3.  Input methods\n"
 678               "          Section 4.  Coding systems\n"
 679               "          Section 5.  Character sets\n")
 680       (if window-system
 681           (insert "          Section 6.  Fontsets\n"))
 682       (insert "\n")
 683
 684       (insert-section 1 "General Information")
 685       (insert "Version of this emacs:\n  " (emacs-version) "\n"
 686               "Primary language:\n  " primary-language "\n\n")
 687
 688       (insert-section 2 "Display")
 689       (if window-system
 690           (insert "Window-system: "
 691                   (symbol-name window-system)
 692                   (format "%s" window-system-version))
 693         (insert "Terminal: " (getenv "TERM")))
 694       (insert "\n\n")
 695
 696       (if (eq window-system 'x)
 697           (let ((font (cdr (assq 'font (frame-parameters)))))
 698             (insert "The selected frame is using the "
 699                     (if (query-fontset font) "fontset" "font")
 700                     ":\n\t" font))
 701         (insert "Coding system of the terminal: "
 702                 (symbol-name (terminal-coding-system))))
 703       (insert "\n\n")
 704
 705       (insert-section 3 "Input methods")
 706       (save-excursion (list-input-methods))
 707       (insert-buffer-substring "*Help*")
 708       (insert "\n")
 709       (if default-input-method
 710           (insert "Default input method: %s\n" default-input-method)
 711         (insert "No default input method is specified.\n"))
 712
 713       (insert-section 4 "Coding systems")
 714       (save-excursion (list-coding-systems t))
 715       (insert-buffer-substring "*Help*")
 716       (list-coding-categories)
 717       (insert-buffer-substring "*Help*")
 718       (insert "\n")
 719
 720       (insert-section 5 "Character sets")
 721       (list-character-sets t)
 722       (insert-buffer-substring "*Help*")
 723       (insert "\n")
 724
 725       (when window-system
 726         (insert-section 6 "Fontsets")
 727         (list-fontsets t)
 728         (insert-buffer-substring "*Help*"))
 729       (help-mode))))
 730
 731 \f
 732 ;;; DUMP DATA FILE
 733
 734 ;;;###autoload
 735 (defun dump-charsets ()
 736   "Dump information of all charsets into the file \"CHARSETS\".
 737 The file is saved in the directory `data-directory'."
 738   (let ((file (expand-file-name "CHARSETS" data-directory))
 739         buf)
 740     (or (file-writable-p file)
 741         (error "Can't write to file %s" file))
 742     (setq buf (find-file-noselect file))
 743     (save-window-excursion
 744       (save-excursion
 745         (set-buffer buf)
 746         (setq buffer-read-only nil)
 747         (erase-buffer)
 748         (list-character-sets t)
 749         (insert-buffer-substring "*Help*")
 750         (let (make-backup-files
 751               coding-system-for-write)
 752           (save-buffer))))
 753     (kill-buffer buf))
 754   (if noninteractive
 755       (kill-emacs)))
 756
 757 ;;;###autoload
 758 (defun dump-codings ()
 759   "Dump information of all coding systems into the file \"CODINGS\".
 760 The file is saved in the directory `data-directory'."
 761   (let ((file (expand-file-name "CODINGS" data-directory))
 762         buf)
 763     (or (file-writable-p file)
 764         (error "Can't write to file %s" file))
 765     (setq buf (find-file-noselect file))
 766     (save-window-excursion
 767       (save-excursion
 768         (set-buffer buf)
 769         (setq buffer-read-only nil)
 770         (erase-buffer)
 771         (list-coding-systems t)
 772         (insert-buffer-substring "*Help*")
 773         (list-coding-categories)
 774         (insert-buffer-substring "*Help*")
 775         (let (make-backup-files
 776               coding-system-for-write)
 777           (save-buffer))))
 778     (kill-buffer buf))
 779   (if noninteractive
 780       (kill-emacs)))
 781
 782 ;;; mule-diag.el ends here