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