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                 ((eq type 5)
 190                  (princ " (text with random binary characters)"))
 191                 (t (princ ": invalid coding-system."))))
 192         (princ "\nEOL type: ")
 193         (let ((eol-type (coding-system-eol-type coding-system)))
 194           (cond ((vectorp eol-type)
 195                  (princ "Automatic selection from:\n\t")
 196                  (princ eol-type)
 197                  (princ "\n"))
 198                 ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
 199                 ((eq eol-type 1) (princ "CRLF\n"))
 200                 ((eq eol-type 2) (princ "CR\n"))
 201                 (t (princ "invalid\n")))))
 202       (let ((postread (coding-system-get coding-system 'post-read-conversion)))
 203         (when postread
 204           (princ "After decoding a text normally,")
 205           (princ " perform post-conversion by the function: ")
 206           (princ "\n  ")
 207           (princ postread)
 208           (princ "\n")))
 209       (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
 210         (when prewrite
 211           (princ "Before encoding a text normally,")
 212           (princ " perform pre-conversion by the function: ")
 213           (princ "\n  ")
 214           (princ prewrite)
 215           (princ "\n")))
 216       (let ((charsets (coding-system-get coding-system 'safe-charsets)))
 217         (when charsets
 218           (if (eq charsets t)
 219               (princ "This coding system can encode charsets:\n")
 220             (princ "This coding system encode the following charsets:\n")
 221             (princ " ")
 222             (while charsets
 223               (princ " ")
 224               (princ (car charsets))
 225               (setq charsets (cdr charsets))))))
 226       (save-excursion
 227         (set-buffer standard-output)
 228         (help-mode)))))
 229
 230 ;;;###autoload
 231 (defun describe-current-coding-system-briefly ()
 232   "Display coding systems currently used in a brief format in echo area.
 233
 234 The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
 235 where mnemonics of the following coding systems come in this order
 236 at the place of `..':
 237   buffer-file-coding-system (of the current buffer)
 238   eol-type of buffer-file-coding-system (of the current buffer)
 239   (keyboard-coding-system)
 240   eol-type of (keyboard-coding-system)
 241   (terminal-coding-system)
 242   eol-type of (terminal-coding-system)
 243   process-coding-system for read (of the current buffer, if any)
 244   eol-type of process-coding-system for read (of the current buffer, if any)
 245   process-coding-system for write (of the current buffer, if any)
 246   eol-type of process-coding-system for write (of the current buffer, if any)
 247   default-buffer-file-coding-system
 248   eol-type of default-buffer-file-coding-system
 249   default-process-coding-system for read
 250   eol-type of default-process-coding-system for read
 251   default-process-coding-system for write
 252   eol-type of default-process-coding-system"
 253   (interactive)
 254   (let* ((proc (get-buffer-process (current-buffer)))
 255          (process-coding-systems (if proc (process-coding-system proc))))
 256     (message
 257      "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]"
 258      (coding-system-mnemonic buffer-file-coding-system)
 259      (coding-system-eol-type-mnemonic buffer-file-coding-system)
 260      (coding-system-mnemonic (keyboard-coding-system))
 261      (coding-system-eol-type-mnemonic (keyboard-coding-system))
 262      (coding-system-mnemonic (terminal-coding-system))
 263      (coding-system-eol-type-mnemonic (terminal-coding-system))
 264      (coding-system-mnemonic (car process-coding-systems))
 265      (coding-system-eol-type-mnemonic (car process-coding-systems))
 266      (coding-system-mnemonic (cdr process-coding-systems))
 267      (coding-system-eol-type-mnemonic (cdr process-coding-systems))
 268      (coding-system-mnemonic default-buffer-file-coding-system)
 269      (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
 270      (coding-system-mnemonic (car default-process-coding-system))
 271      (coding-system-eol-type-mnemonic (car default-process-coding-system))
 272      (coding-system-mnemonic (cdr default-process-coding-system))
 273      (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
 274      )))
 275
 276 ;; Print symbol name and mnemonic letter of CODING-SYSTEM by `princ'.
 277 (defun print-coding-system-briefly (coding-system &optional doc-string)
 278   (if (not coding-system)
 279       (princ "nil\n")
 280     (princ (format "%c -- %s"
 281                    (coding-system-mnemonic coding-system)
 282                    coding-system))
 283     (let ((aliases (coding-system-get coding-system 'alias-coding-systems)))
 284       (if (eq coding-system (car aliases))
 285           (if (cdr aliases)
 286               (princ (format " %S" (cons 'alias: (cdr aliases)))))
 287         (if (memq coding-system aliases)
 288             (princ (format " (alias of %s)" (car aliases))))))
 289     (princ "\n")
 290     (if (and doc-string
 291              (setq doc-string (coding-system-doc-string coding-system)))
 292         (princ (format "  %s\n" doc-string)))))
 293
 294 ;;;###autoload
 295 (defun describe-current-coding-system ()
 296   "Display coding systems currently used in a detailed format."
 297   (interactive)
 298   (with-output-to-temp-buffer "*Help*"
 299     (let* ((proc (get-buffer-process (current-buffer)))
 300            (process-coding-systems (if proc (process-coding-system proc))))
 301       (princ "Coding system for saving this buffer:\n  ")
 302       (if (local-variable-p 'buffer-file-coding-system)
 303           (print-coding-system-briefly buffer-file-coding-system)
 304         (princ "Not set locally, use the default.\n"))
 305       (princ "Default coding system (for new files):\n  ")
 306       (print-coding-system-briefly default-buffer-file-coding-system)
 307       (princ "Coding system for keyboard input:\n  ")
 308       (print-coding-system-briefly (keyboard-coding-system))
 309       (princ "Coding system for terminal output:\n  ")
 310       (print-coding-system-briefly (terminal-coding-system))
 311       (when (get-buffer-process (current-buffer))
 312         (princ "Coding systems for process I/O:\n")
 313         (princ "  encoding input to the process: ")
 314         (print-coding-system-briefly (cdr process-coding-systems))
 315         (princ "  decoding output from the process: ")
 316         (print-coding-system-briefly (car process-coding-systems)))
 317       (princ "Defaults for subprocess I/O:\n")
 318       (princ "  decoding: ")
 319       (print-coding-system-briefly (car default-process-coding-system))
 320       (princ "  encoding: ")
 321       (print-coding-system-briefly (cdr default-process-coding-system)))
 322
 323     (save-excursion
 324       (set-buffer standard-output)
 325
 326       (princ "\nPriority order for recognizing coding systems when reading files:\n")
 327       (let ((l coding-category-list)
 328             (i 1)
 329             (coding-list nil)
 330             coding aliases)
 331         (while l
 332           (setq coding (symbol-value (car l)))
 333           ;; Do not list up the same coding system twice.
 334           (when (not (memq coding coding-list))
 335             (setq coding-list (cons coding coding-list))
 336             (princ (format "  %d. %s " i coding))
 337             (setq aliases (coding-system-get coding 'alias-coding-systems))
 338             (if (eq coding (car aliases))
 339                 (if (cdr aliases)
 340                     (princ (cons 'alias: (cdr aliases))))
 341               (if (memq coding aliases)
 342                   (princ (list 'alias 'of (car aliases)))))
 343             (terpri)
 344             (setq i (1+ i)))
 345           (setq l (cdr l))))
 346
 347       (princ "\n  Other coding systems cannot be distinguished automatically
 348   from these, and therefore cannot be recognized automatically
 349   with the present coding system priorities.\n\n")
 350
 351       (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
 352             coding-system codings)
 353         (while categories
 354           (setq coding-system (symbol-value (car categories)))
 355           (mapcar
 356            (function
 357             (lambda (x)
 358               (if (and (not (eq x coding-system))
 359                        (coding-system-get x 'no-initial-designation)
 360                        (let ((flags (coding-system-flags x)))
 361                          (not (or (aref flags 10) (aref flags 11)))))
 362                   (setq codings (cons x codings)))))
 363            (get (car categories) 'coding-systems))
 364           (if codings
 365               (let ((max-col (frame-width))
 366                     pos)
 367                 (princ (format "  The followings are decoded correctly but recognized as %s:\n   " coding-system))
 368                 (while codings
 369                   (setq pos (point))
 370                   (insert (format " %s" (car codings)))
 371                   (when (> (current-column) max-col)
 372                     (goto-char pos)
 373                     (insert "\n   ")
 374                     (goto-char (point-max)))
 375                   (setq codings (cdr codings)))
 376                 (insert "\n\n")))
 377           (setq categories (cdr categories))))
 378
 379       (princ "Particular coding systems specified for certain file names:\n")
 380       (terpri)
 381       (princ "  OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
 382       (princ "  ---------\t--------------\t\t----------------\n")
 383       (let ((func (lambda (operation alist)
 384                     (princ "  ")
 385                     (princ operation)
 386                     (if (not alist)
 387                         (princ "\tnothing specified\n")
 388                       (while alist
 389                         (indent-to 16)
 390                         (prin1 (car (car alist)))
 391                         (if (>= (current-column) 40)
 392                             (newline))
 393                         (indent-to 40)
 394                         (princ (cdr (car alist)))
 395                         (princ "\n")
 396                         (setq alist (cdr alist)))))))
 397         (funcall func "File I/O" file-coding-system-alist)
 398         (funcall func "Process I/O" process-coding-system-alist)
 399         (funcall func "Network I/O" network-coding-system-alist))
 400       (help-mode))))
 401
 402 ;; Print detailed information on CODING-SYSTEM.
 403 (defun print-coding-system (coding-system)
 404   (let ((type (coding-system-type coding-system))
 405         (eol-type (coding-system-eol-type coding-system))
 406         (flags (coding-system-flags coding-system))
 407         (aliases (coding-system-get coding-system 'alias-coding-systems)))
 408     (if (not (eq (car aliases) coding-system))
 409         (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
 410       (princ coding-system)
 411       (setq aliases (cdr aliases))
 412       (while aliases
 413         (princ ",")
 414         (princ (car aliases))
 415         (setq aliases (cdr aliases)))
 416       (princ (format ":%s:%c:%d:"
 417                      type
 418                      (coding-system-mnemonic coding-system)
 419                      (if (integerp eol-type) eol-type 3)))
 420       (cond ((eq type 2)                ; ISO-2022
 421              (let ((idx 0)
 422                    charset)
 423                (while (< idx 4)
 424                  (setq charset (aref flags idx))
 425                  (cond ((null charset)
 426                         (princ -1))
 427                        ((eq charset t)
 428                         (princ -2))
 429                        ((charsetp charset)
 430                         (princ charset))
 431                        ((listp charset)
 432                         (princ "(")
 433                         (princ (car charset))
 434                         (setq charset (cdr charset))
 435                         (while charset
 436                           (princ ",")
 437                           (princ (car charset))
 438                           (setq charset (cdr charset)))
 439                         (princ ")")))
 440                  (princ ",")
 441                  (setq idx (1+ idx)))
 442                (while (< idx 12)
 443                  (princ (if (aref flags idx) 1 0))
 444                  (princ ",")
 445                  (setq idx (1+ idx)))
 446                (princ (if (aref flags idx) 1 0))))
 447             ((eq type 4)                ; CCL
 448              (let (i len)
 449                (if (symbolp (car flags))
 450                    (princ (format " %s" (car flags)))
 451                  (setq i 0 len (length (car flags)))
 452                  (while (< i len)
 453                    (princ (format " %x" (aref (car flags) i)))
 454                    (setq i (1+ i))))
 455                (princ ",")
 456                (if (symbolp (cdr flags))
 457                    (princ (format "%s" (cdr flags)))
 458                  (setq i 0 len (length (cdr flags)))
 459                  (while (< i len)
 460                    (princ (format " %x" (aref (cdr flags) i)))
 461                    (setq i (1+ i))))))
 462             (t (princ 0)))
 463       (princ ":")
 464       (princ (coding-system-doc-string coding-system))
 465       (princ "\n"))))
 466
 467 ;;;###autoload
 468 (defun list-coding-systems (&optional arg)
 469   "Display a list of all coding systems.
 470 It prints mnemonic letter, name, and description of each coding systems.
 471
 472 With prefix arg, the output format gets more cryptic,
 473 but contains full information about each coding systems."
 474   (interactive "P")
 475   (with-output-to-temp-buffer "*Help*"
 476     (if (null arg)
 477         (princ "\
 478 ###############################################
 479 # List of coding systems in the following format:
 480 # MNEMONIC-LETTER -- CODING-SYSTEM-NAME
 481 #       DOC-STRING
 482 ")
 483       (princ "\
 484 #########################
 485 ## LIST OF CODING SYSTEMS
 486 ## Each line corresponds to one coding system
 487 ## Format of a line is:
 488 ##   NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
 489 ##      :PRE-WRITE-CONVERSION:DOC-STRING,
 490 ## where
 491 ##  NAME = coding system name
 492 ##  ALIAS = alias of the coding system
 493 ##  TYPE = nil (no conversion), t (undecided or automatic detection),
 494 ##         0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
 495 ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
 496 ##  FLAGS =
 497 ##    if TYPE = 2 then
 498 ##      comma (`,') separated data of the followings:
 499 ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
 500 ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
 501 ##    else if TYPE = 4 then
 502 ##      comma (`,') separated CCL programs for read and write
 503 ##    else
 504 ##      0
 505 ##  POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
 506 ##
 507 "))
 508     (let ((bases (coding-system-list 'base-only))
 509           coding-system)
 510       (while bases
 511         (setq coding-system (car bases))
 512         (if (null arg)
 513             (print-coding-system-briefly coding-system 'doc-string)
 514           (print-coding-system coding-system))
 515         (setq bases (cdr bases))))))
 516
 517 ;;;###automatic
 518 (defun list-coding-categories ()
 519   "Display a list of all coding categories."
 520   (with-output-to-temp-buffer "*Help*"
 521     (princ "\
 522 ############################
 523 ## LIST OF CODING CATEGORIES (ordered by priority)
 524 ## CATEGORY:CODING-SYSTEM
 525 ##
 526 ")
 527     (let ((l coding-category-list))
 528       (while l
 529         (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
 530         (setq l (cdr l))))))
 531 \f
 532 ;;; FONT
 533
 534 ;; Print information of a font in FONTINFO.
 535 (defun describe-font-internal (font-info &optional verbose)
 536   (print-list "name (opened by):" (aref font-info 0))
 537   (print-list "       full name:" (aref font-info 1))
 538   (let ((charset (aref font-info 2)))
 539     (print-list "   charset:"
 540                 (format "%s (%s)" charset (charset-description charset))))
 541   (print-list "            size:" (format "%d" (aref font-info 3)))
 542   (print-list "          height:" (format "%d" (aref font-info 4)))
 543   (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
 544   (print-list "relative-compose:" (format "%d" (aref font-info 6))))
 545
 546 ;;;###autoload
 547 (defun describe-font (fontname)
 548   "Display information about fonts which partially match FONTNAME."
 549   (interactive "sFontname (default, current choice for ASCII chars): ")
 550   (or (and window-system (boundp 'global-fontset-alist))
 551       (error "No fontsets being used"))
 552   (when (or (not fontname) (= (length fontname) 0))
 553     (setq fontname (cdr (assq 'font (frame-parameters))))
 554     (if (query-fontset fontname)
 555         (setq fontname
 556               (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
 557   (let ((font-info (font-info fontname)))
 558     (if (null font-info)
 559         (message "No matching font")
 560       (with-output-to-temp-buffer "*Help*"
 561         (describe-font-internal font-info 'verbose)))))
 562
 563 ;; Print information of FONTSET.  If optional arg PRINT-FONTS is
 564 ;; non-nil, print also names of all fonts in FONTSET.  This function
 565 ;; actually INSERT such information in the current buffer.
 566 (defun print-fontset (fontset &optional print-fonts)
 567   (let* ((fontset-info (fontset-info fontset))
 568          (size (aref fontset-info 0))
 569          (height (aref fontset-info 1))
 570          (fonts (and print-fonts (aref fontset-info 2)))
 571          (xlfd-fields (x-decompose-font-name fontset))
 572          style)
 573     (if xlfd-fields
 574         (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
 575               (slant  (aref xlfd-fields xlfd-regexp-slant-subnum)))
 576           (if (string-match "^bold$\\|^demibold$" weight)
 577               (setq style (concat weight " "))
 578             (setq style "medium "))
 579           (cond ((string-match "^i$" slant)
 580                  (setq style (concat style "italic")))
 581                 ((string-match "^o$" slant)
 582                  (setq style (concat style "slant")))
 583                 ((string-match "^ri$" slant)
 584                  (setq style (concat style "reverse italic")))
 585                 ((string-match "^ro$" slant)
 586                  (setq style (concat style "reverse slant")))))
 587       (setq style " ? "))
 588     (beginning-of-line)
 589     (insert fontset)
 590     (indent-to 58)
 591     (insert (if (> size 0) (format "%2dx%d" size height) "  -"))
 592     (indent-to 64)
 593     (insert style "\n")
 594     (when print-fonts
 595       (insert "  O Charset / Fontname\n"
 596               "  - ------------------\n")
 597       (sort-charset-list)
 598       (let ((l charset-list)
 599             charset font-info opened fontname)
 600         (while l
 601           (setq charset (car l) l (cdr l))
 602           (setq font-info (assq charset fonts))
 603           (if (null font-info)
 604               (setq opened ?? fontname "not specified")
 605             (if (nth 2 font-info)
 606                 (if (stringp (nth 2 font-info))
 607                     (setq opened ?o fontname (nth 2 font-info))
 608                   (setq opened ?- fontname (nth 1 font-info)))
 609               (setq opened ?x fontname (nth 1 font-info))))
 610           (insert (format "  %c %s\n    %s\n"
 611                           opened charset fontname)))))))
 612
 613 ;;;###autoload
 614 (defun describe-fontset (fontset)
 615   "Display information of FONTSET.
 616
 617 It prints name, size, and style of FONTSET, and lists up fonts
 618 contained in FONTSET.
 619
 620 The column WDxHT contains width and height (pixels) of each fontset
 621 \(i.e. those of ASCII font in the fontset).  The letter `-' in this
 622 column means that the corresponding fontset is not yet used in any
 623 frame.
 624
 625 The O column of each font contains one of the following letters.
 626  o -- font already opened
 627  - -- font not yet opened
 628  x -- font can't be opened
 629  ? -- no font specified
 630
 631 The Charset column of each font contains a name of character set
 632 displayed by the font."
 633   (interactive
 634    (if (not (and window-system (boundp 'global-fontset-alist)))
 635        (error "No fontsets being used")
 636      (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
 637            (completion-ignore-case t))
 638        (list (completing-read
 639               "Fontset (default, used by the current frame): "
 640               fontset-list nil t)))))
 641   (if (= (length fontset) 0)
 642       (setq fontset (cdr (assq 'font (frame-parameters)))))
 643   (if (not (query-fontset fontset))
 644       (error "Current frame is using font, not fontset"))
 645   (let ((fontset-info (fontset-info fontset)))
 646     (with-output-to-temp-buffer "*Help*"
 647       (save-excursion
 648         (set-buffer standard-output)
 649         (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 650         (insert "------------\t\t\t\t\t\t  ----- -----\n")
 651         (print-fontset fontset t)))))
 652
 653 ;;;###autoload
 654 (defun list-fontsets (arg)
 655   "Display a list of all fontsets.
 656
 657 It prints name, size, and style of each fontset.
 658 With prefix arg, it also lists up fonts contained in each fontset.
 659 See the function `describe-fontset' for the format of the list."
 660   (interactive "P")
 661   (if (not (and window-system (boundp 'global-fontset-alist)))
 662       (error "No fontsets being used")
 663     (with-output-to-temp-buffer "*Help*"
 664       (save-excursion
 665         (set-buffer standard-output)
 666         (insert "Fontset-Name\t\t\t\t\t\t  WDxHT Style\n")
 667         (insert "------------\t\t\t\t\t\t  ----- -----\n")
 668         (let ((fontsets (fontset-list)))
 669           (while fontsets
 670             (print-fontset (car fontsets) arg)
 671             (setq fontsets (cdr fontsets))))))))
 672 \f
 673 ;;;###autoload
 674 (defun list-input-methods ()
 675   "Print information of all input methods."
 676   (interactive)
 677   (with-output-to-temp-buffer "*Help*"
 678     (if (not input-method-alist)
 679         (progn
 680           (princ "
 681 No input method is available, perhaps because you have not yet
 682 installed LEIM (Libraries of Emacs Input Method).
 683
 684 LEIM is available from the same ftp directory as Emacs.  For instance,
 685 if there exists an archive file `emacs-20.N.tar.gz', there should also
 686 be a file `leim-20.N.tar.gz'.  When you extract this file, LEIM files
 687 are put under the subdirectory `emacs-20.N/leim'.  When you install
 688 Emacs again, you should be able to use various input methods."))
 689       (princ "LANGUAGE\n  NAME (`TITLE' in mode line)\n")
 690       (princ "    SHORT-DESCRIPTION\n------------------------------\n")
 691       (setq input-method-alist
 692             (sort input-method-alist
 693                   (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
 694       (let ((l input-method-alist)
 695             language elt)
 696         (while l
 697           (setq elt (car l) l (cdr l))
 698           (when (not (equal language (nth 1 elt)))
 699             (setq language (nth 1 elt))
 700             (princ language)
 701             (terpri))
 702           (princ (format "  %s (`%s' in mode line)\n    %s\n"
 703                          (car elt)
 704                          (let ((title (nth 3 elt)))
 705                            (if (and (consp title) (stringp (car title)))
 706                                (car title)
 707                              title))
 708                          (let ((description (nth 4 elt)))
 709                            (string-match ".*" description)
 710                            (match-string 0 description)))))))))
 711 \f
 712 ;;; DIAGNOSIS
 713
 714 ;; Insert a header of a section with SECTION-NUMBER and TITLE.
 715 (defun insert-section (section-number title)
 716   (insert "########################################\n"
 717           "# Section " (format "%d" section-number) ".  " title "\n"
 718           "########################################\n\n"))
 719
 720 ;;;###autoload
 721 (defun mule-diag ()
 722   "Display diagnosis of the multilingual environment (MULE).
 723
 724 It prints various information related to the current multilingual
 725 environment, including lists of input methods, coding systems,
 726 character sets, and fontsets (if Emacs running under some window
 727 system which uses fontsets)."
 728   (interactive)
 729   (with-output-to-temp-buffer "*Mule-Diagnosis*"
 730     (save-excursion
 731       (set-buffer standard-output)
 732       (insert "\t###############################\n"
 733               "\t### Diagnosis of your Emacs ###\n"
 734               "\t###############################\n\n"
 735               "CONTENTS: Section 1.  General Information\n"
 736               "          Section 2.  Display\n"
 737               "          Section 3.  Input methods\n"
 738               "          Section 4.  Coding systems\n"
 739               "          Section 5.  Character sets\n")
 740       (if (and window-system (boundp 'global-fontset-alist))
 741           (insert "          Section 6.  Fontsets\n"))
 742       (insert "\n")
 743
 744       (insert-section 1 "General Information")
 745       (insert "Version of this emacs:\n  " (emacs-version) "\n\n")
 746
 747       (insert-section 2 "Display")
 748       (if window-system
 749           (insert "Window-system: "
 750                   (symbol-name window-system)
 751                   (format "%s" window-system-version))
 752         (insert "Terminal: " (getenv "TERM")))
 753       (insert "\n\n")
 754
 755       (if (eq window-system 'x)
 756           (let ((font (cdr (assq 'font (frame-parameters)))))
 757             (insert "The selected frame is using the "
 758                     (if (query-fontset font) "fontset" "font")
 759                     ":\n\t" font))
 760         (insert "Coding system of the terminal: "
 761                 (symbol-name (terminal-coding-system))))
 762       (insert "\n\n")
 763
 764       (insert-section 3 "Input methods")
 765       (save-excursion (list-input-methods))
 766       (insert-buffer-substring "*Help*")
 767       (insert "\n")
 768       (if default-input-method
 769           (insert "Default input method: " default-input-method "\n")
 770         (insert "No default input method is specified\n"))
 771
 772       (insert-section 4 "Coding systems")
 773       (save-excursion (list-coding-systems t))
 774       (insert-buffer-substring "*Help*")
 775       (save-excursion (list-coding-categories))
 776       (insert-buffer-substring "*Help*")
 777       (insert "\n")
 778
 779       (insert-section 5 "Character sets")
 780       (save-excursion (list-character-sets t))
 781       (insert-buffer-substring "*Help*")
 782       (insert "\n")
 783
 784       (when (and window-system (boundp 'global-fontset-alist))
 785         (insert-section 6 "Fontsets")
 786         (save-excursion (list-fontsets t))
 787         (insert-buffer-substring "*Help*"))
 788       (help-mode))))
 789
 790 \f
 791 ;;; DUMP DATA FILE
 792
 793 ;;;###autoload
 794 (defun dump-charsets ()
 795   "Dump information of all charsets into the file \"CHARSETS\".
 796 The file is saved in the directory `data-directory'."
 797   (let ((file (expand-file-name "CHARSETS" data-directory))
 798         buf)
 799     (or (file-writable-p file)
 800         (error "Can't write to file %s" file))
 801     (setq buf (find-file-noselect file))
 802     (save-window-excursion
 803       (save-excursion
 804         (set-buffer buf)
 805         (setq buffer-read-only nil)
 806         (erase-buffer)
 807         (list-character-sets t)
 808         (insert-buffer-substring "*Help*")
 809         (let (make-backup-files
 810               coding-system-for-write)
 811           (save-buffer))))
 812     (kill-buffer buf))
 813   (if noninteractive
 814       (kill-emacs)))
 815
 816 ;;;###autoload
 817 (defun dump-codings ()
 818   "Dump information of all coding systems into the file \"CODINGS\".
 819 The file is saved in the directory `data-directory'."
 820   (let ((file (expand-file-name "CODINGS" data-directory))
 821         buf)
 822     (or (file-writable-p file)
 823         (error "Can't write to file %s" file))
 824     (setq buf (find-file-noselect file))
 825     (save-window-excursion
 826       (save-excursion
 827         (set-buffer buf)
 828         (setq buffer-read-only nil)
 829         (erase-buffer)
 830         (list-coding-systems t)
 831         (insert-buffer-substring "*Help*")
 832         (list-coding-categories)
 833         (insert-buffer-substring "*Help*")
 834         (let (make-backup-files
 835               coding-system-for-write)
 836           (save-buffer))))
 837     (kill-buffer buf))
 838   (if noninteractive
 839       (kill-emacs)))
 840
 841 ;;; mule-diag.el ends here