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 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
   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     (if (car args)
  31         (progn (princ (car args)) (princ " ")))
  32     (setq args (cdr args)))
  33   (princ (car args))
  34   (princ "\n"))
  35
  36 ;;; CHARSET
  37
  38 ;;;###autoload
  39 (defun list-character-sets ()
  40   "Display a list of all charsets."
  41   (interactive)
  42   (with-output-to-temp-buffer "*Help*"
  43     (print-character-sets)))
  44
  45 (defvar charset-other-info-func nil)
  46
  47 (defun print-character-sets ()
  48   "Print information on all charsets in a machine readable format."
  49   (princ "\
  50 #########################
  51 ## LIST OF CHARSETS
  52 ## Each line corresponds to one charset.
  53 ## The following attributes are listed in this order
  54 ## separated by a colon `:' in one line.
  55 ##      CHARSET-SYMBOL-NAME,
  56 ##      CHARSET-ID,
  57 ##      DIMENSION (1 or 2)
  58 ##      CHARS (94 or 96)
  59 ##      BYTES (of multibyte form: 1, 2, 3, or 4),
  60 ##      WIDTH (occupied column numbers: 1 or 2),
  61 ##      DIRECTION (0:left-to-right, 1:right-to-left),
  62 ##      ISO-FINAL-CHAR (character code of ISO-2022's final character)
  63 ##      ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
  64 ##      DESCRIPTION (describing string of the charset)
  65 ")
  66   (let ((charsets charset-list)
  67         charset)
  68     (while charsets
  69       (setq charset (car charsets))
  70       (princ (format "%s:%03d:%d:%d:%d:%d:%d:%d:%d:%s\n"
  71                      charset
  72                      (charset-id charset)
  73                      (charset-dimension charset)
  74                      (charset-chars charset)
  75                      (charset-bytes charset)
  76                      (charset-width charset)
  77                      (charset-direction charset)
  78                      (charset-iso-final-char charset)
  79                      (charset-iso-graphic-plane charset)
  80                      (charset-description charset)))
  81       (setq charsets (cdr charsets)))))
  82
  83 \f
  84 ;;; CODING-SYSTEM
  85
  86 ;; Print information of designation of each graphic register in FLAGS
  87 ;; in human readable format.  See the documentation of
  88 ;; `make-coding-system' for the meaning of FLAGS.
  89 (defun print-designation (flags)
  90   (let ((graphic-register 0)
  91         charset)
  92     (while (< graphic-register 4)
  93       (setq charset (aref flags graphic-register))
  94       (princ (format
  95               "  G%d -- %s\n"
  96               graphic-register
  97               (cond ((null charset)
  98                      "never used")
  99                     ((eq charset t)
 100                      "no initial designation, and used by any charsets")
 101                     ((symbolp charset)
 102                      (format "%s:%s"
 103                              charset (charset-description charset)))
 104                     ((listp charset)
 105                      (if (charsetp (car charset))
 106                          (format "%s:%s, and also used by the followings:"
 107                                  (car charset)
 108                                  (charset-description (car charset)))
 109                        "no initial designation, and used by the followings:"))
 110                     (t
 111                      "invalid designation information"))))
 112       (if (listp charset)
 113           (progn
 114             (setq charset (cdr charset))
 115             (while charset
 116               (cond ((eq (car charset) t)
 117                      (princ "\tany other charsets\n"))
 118                     ((charsetp (car charset))
 119                      (princ (format "\t%s:%s\n"
 120                                     (car charset)
 121                                     (charset-description (car charset)))))
 122                     (t
 123                      "invalid designation information"))
 124               (setq charset (cdr charset)))))
 125       (setq graphic-register (1+ graphic-register)))))
 126
 127 ;;;###autoload
 128 (defun describe-coding-system (coding-system)
 129   "Display information of CODING-SYSTEM."
 130   (interactive "zCoding-system: ")
 131   (check-coding-system coding-system)
 132   (with-output-to-temp-buffer "*Help*"
 133     (let ((coding-vector (coding-system-vector coding-system)))
 134       (princ "Coding-system ")
 135       (princ coding-system)
 136       (princ " [")
 137       (princ (char-to-string (coding-vector-mnemonic coding-vector)))
 138       (princ "]: \n")
 139       (princ "  ")
 140       (princ (coding-vector-docstring coding-vector))
 141       (princ "\nType: ")
 142       (let ((type (coding-vector-type coding-vector))
 143             (flags (coding-vector-flags coding-vector)))
 144         (princ type)
 145         (princ ", which means ")
 146         (cond ((eq type nil)
 147                (princ "do no conversion."))
 148               ((eq type t)
 149                (princ "do automatic conversion."))
 150               ((eq type 0)
 151                (princ "Emacs internal multibyte form."))
 152               ((eq type 1)
 153                (princ "Shift-JIS (MS-KANJI)."))
 154               ((eq type 2)
 155                (princ "a variant of ISO-2022.\n")
 156                (princ "Initial designations:\n")
 157                (print-designation flags)
 158                (princ "Other Form: \n")
 159                (princ (if (aref flags 4) "short-form" "long-form"))
 160                (if (aref flags 5) (princ ", ASCII@EOL"))
 161                (if (aref flags 6) (princ ", ASCII@CNTL"))
 162                (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
 163                (if (aref flags 8) (princ ", use-locking-shift"))
 164                (if (aref flags 9) (princ ", use-single-shift"))
 165                (if (aref flags 10) (princ ", use-roman"))
 166                (if (aref flags 10) (princ ", use-old-jis"))
 167                (if (aref flags 11) (princ ", no-ISO6429"))
 168                (princ "."))
 169               ((eq type 3)
 170                (princ "Big5."))
 171               ((eq type 4)
 172                (princ "do conversion by CCL program."))
 173               (t (princ "invalid coding-system."))))
 174       (princ "\nEOL-Type: ")
 175       (let ((eol-type (coding-system-eoltype coding-system)))
 176         (cond ((vectorp eol-type)
 177                (princ "Automatic selection from ")
 178                (princ eol-type)
 179                (princ "\n"))
 180               ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
 181               ((eq eol-type 1) (princ "CRLF\n"))
 182               ((eq eol-type 2) (princ "CR\n"))
 183               (t (princ "invalid\n"))))
 184       )))
 185
 186 ;;;###autoload
 187 (defun describe-current-coding-system-briefly ()
 188   "Display coding systems currently used in a brief format in mini-buffer.
 189
 190 The format is \"current: [FKTPp=........] default: [FPp=......]\",
 191 where mnemonics of the following coding systems come in this order
 192 at the place of `...':
 193   buffer-file-coding-system (of the current buffer)
 194   eol-type of buffer-file-coding-system (of the current buffer)
 195   keyboard-coding-system
 196   terminal-coding-system
 197   process-coding-system for read (of the current buffer, if any)
 198   eol-type of process-coding-system for read (of the current buffer, if any)
 199   process-coding-system for write (of the current buffer, if any)
 200   eol-type of process-coding-system for write (of the current buffer, if any)
 201   default buffer-file-coding-system
 202   eol-type of default buffer-file-coding-system
 203   default process-coding-system for read
 204   default eol-type of process-coding-system for read
 205   default process-coding-system for write
 206   default eol-type of process-coding-system"
 207   (interactive)
 208   (let* ((proc (get-buffer-process (current-buffer)))
 209          (process-coding-systems (if proc (process-coding-system proc))))
 210     (message
 211      "current: [FKTPp=%c%c%c%c%c%c%c%c] default: [FPp=%c%c%c%c%c%c]"
 212      (coding-system-mnemonic buffer-file-coding-system)
 213      (coding-system-eoltype-mnemonic buffer-file-coding-system)
 214      (coding-system-mnemonic (keyboard-coding-system))
 215      (coding-system-mnemonic (terminal-coding-system))
 216      (coding-system-mnemonic (car process-coding-systems))
 217      (coding-system-eoltype-mnemonic (car process-coding-systems))
 218      (coding-system-mnemonic (cdr process-coding-systems))
 219      (coding-system-eoltype-mnemonic (cdr process-coding-systems))
 220      (coding-system-mnemonic (default-value 'buffer-file-coding-system))
 221      (coding-system-eoltype-mnemonic (default-value 'buffer-file-coding-system))
 222      (coding-system-mnemonic (car default-process-coding-system))
 223      (coding-system-eoltype-mnemonic (car default-process-coding-system))
 224      (coding-system-mnemonic (cdr default-process-coding-system))
 225      (coding-system-eoltype-mnemonic (cdr default-process-coding-system))
 226      )))
 227
 228 ;; Print symbol name and mnemonics of CODING-SYSTEM by `princ'.
 229 (defsubst print-coding-system-briefly (coding-system)
 230   (print-list ":"
 231               coding-system
 232               (format "[%c%c]"
 233                       (coding-system-mnemonic coding-system)
 234                       (coding-system-eoltype-mnemonic coding-system))))
 235
 236 ;;;###autoload
 237 (defun describe-current-coding-system ()
 238   "Display coding systems currently used in a detailed format."
 239   (interactive)
 240   (with-output-to-temp-buffer "*Help*"
 241     (let* ((proc (get-buffer-process (current-buffer)))
 242            (process-coding-systems (if proc (process-coding-system proc))))
 243       (princ "Current:\n  buffer-file-coding-system")
 244       (print-coding-system-briefly buffer-file-coding-system)
 245       (princ "  keyboard-coding-system")
 246       (print-coding-system-briefly (keyboard-coding-system))
 247       (princ "  terminal-coding-system")
 248       (print-coding-system-briefly (terminal-coding-system))
 249       (if process-coding-systems
 250           (progn (princ "  process-coding-system (read)")
 251                  (print-coding-system-briefly (car process-coding-systems))
 252                  (princ "  process-coding-system (write)")
 253                  (print-coding-system-briefly (cdr process-coding-systems))))
 254       (princ "Default:\n  buffer-file-coding-system")
 255       (print-coding-system-briefly (default-value 'buffer-file-coding-system))
 256       (princ "  process-coding-system (read)")
 257       (print-coding-system-briefly (car default-process-coding-system))
 258       (princ "  process-coding-system (write)")
 259       (print-coding-system-briefly (cdr default-process-coding-system))
 260       (princ "coding-system-alist:\n")
 261       (pp coding-system-alist))
 262     (let ((l coding-category-list))
 263       (princ "\nCoding categories (in the order of priority):\n")
 264       (while l
 265         (princ (format "%s -> %s\n" (car l) (symbol-value (car l))))
 266         (setq l (cdr l))))))
 267
 268 ;; Print detailed information on CODING-SYSTEM.
 269 (defun print-coding-system (coding-system)
 270   (let ((type (coding-system-type coding-system))
 271         (eol-type (coding-system-eoltype coding-system))
 272         (flags (coding-system-flags coding-system)))
 273     (princ (format "%s:%s:%c:%d:"
 274                    coding-system
 275                    type
 276                    (coding-system-mnemonic coding-system)
 277                    (if (integerp eol-type) eol-type 3)))
 278     (cond ((eq type 2)                  ; ISO-2022
 279            (let ((idx 0)
 280                  charset)
 281              (while (< idx 4)
 282                (setq charset (aref flags idx))
 283                (cond ((null charset)
 284                       (princ -1))
 285                      ((eq charset t)
 286                       (princ -2))
 287                      ((charsetp charset)
 288                       (princ charset))
 289                      ((listp charset)
 290                       (princ "(")
 291                       (princ (car charset))
 292                       (setq charset (cdr charset))
 293                       (while charset
 294                         (princ ",")
 295                         (princ (car charset))
 296                         (setq charset (cdr charset)))
 297                       (princ ")")))
 298                (princ ",")
 299                (setq idx (1+ idx)))
 300              (while (< idx 12)
 301                (princ (if (aref flags idx) 1 0))
 302                (princ ",")
 303                (setq idx (1+ idx)))
 304              (princ (if (aref flags idx) 1 0))))
 305           ((eq type 4)                  ; CCL
 306            (let (i len)
 307              (setq i 0 len (length (car flags)))
 308              (while (< i len)
 309                (princ (format " %x" (aref (car flags) i)))
 310                (setq i (1+ i)))
 311              (princ ",")
 312              (setq i 0 len (length (cdr flags)))
 313              (while (< i len)
 314                (princ (format " %x" (aref (cdr flags) i)))
 315                (setq i (1+ i)))))
 316           (t (princ 0)))
 317     (princ ":")
 318     (princ (coding-system-docstring coding-system))
 319     (princ "\n")))
 320
 321 (defun list-coding-systems ()
 322   "Print information on all coding systems in a machine readable format."
 323   (with-output-to-temp-buffer "*Help*"
 324     (princ "\
 325 #########################
 326 ## LIST OF CODING SYSTEMS
 327 ## Each line corresponds to one coding system
 328 ## Format of a line is:
 329 ##   NAME:TYPE:MNEMONIC:EOL:FLAGS:DOCSTRING,
 330 ## where
 331 ##  TYPE = nil (no conversion), t (auto conversion),
 332 ##         0 (Mule internal), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
 333 ##  EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
 334 ##  FLAGS =
 335 ##    if TYPE = 2 then
 336 ##      comma (`,') separated data of the followings:
 337 ##        G0, G1, G2, G3, SHORT-FORM, ASCII-EOL, ASCII-CNTL, SEVEN,
 338 ##        LOCKING-SHIFT, SINGLE-SHIFT, USE-ROMAN, USE-OLDJIS, NO-ISO6429
 339 ##    else if TYPE = 4 then
 340 ##      comma (`,') separated CCL programs for read and write
 341 ##    else
 342 ##      0
 343 ##
 344 ")
 345     (let ((codings (make-vector 7 nil)))
 346       (mapatoms
 347        (function
 348         (lambda (arg)
 349           (if (and arg
 350                    (coding-system-p arg)
 351                    (null (get arg 'pre-write-conversion))
 352                    (null (get arg 'post-read-conversion)))
 353               (let* ((type (coding-system-type arg))
 354                      (idx (if (null type) 0 (if (eq type t) 1 (+ type 2)))))
 355                 (if (or (= idx 0)
 356                         (vectorp (coding-system-eoltype arg)))
 357                     (aset codings idx (cons arg (aref codings idx)))))))))
 358       (let ((idx 0) elt)
 359         (while (< idx 7)
 360           (setq elt (aref codings idx))
 361           (while elt
 362             (print-coding-system (car elt))
 363             (setq elt (cdr elt)))
 364           (setq idx (1+ idx)))))
 365     (princ "\
 366 ############################
 367 ## LIST OF CODING CATEGORIES (ordered by priority)
 368 ## CATEGORY:CODING-SYSTEM
 369 ##
 370 ")
 371     (let ((l coding-category-list))
 372       (while l
 373         (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
 374         (setq l (cdr l))))
 375     ))
 376 \f
 377 ;;; FONT
 378
 379 ;; Print information of a font in FONTINFO.
 380 (defun describe-font-internal (font-info &optional verbose)
 381   (print-list "name (opened by):" (aref font-info 0))
 382   (print-list "       full name:" (aref font-info 1))
 383   (let ((charset (aref font-info 2)))
 384     (print-list "   charset:"
 385                 (format "%s (%s)" charset (charset-description charset))))
 386   (print-list "            size:" (format "%d" (aref font-info 3)))
 387   (print-list "          height:" (format "%d" (aref font-info 4)))
 388   (print-list " baseline-offset:" (format "%d" (aref font-info 5)))
 389   (print-list "relative-compose:" (format "%d" (aref font-info 6))))
 390
 391 ;;;###autoload
 392 (defun describe-font (fontname)
 393   "Display information about fonts which partially match FONTNAME."
 394   (interactive "sFontname: ")
 395   (or window-system
 396       (error "No window system being used"))
 397   (let ((font-info (font-info fontname)))
 398     (if (null font-info)
 399         (message "No matching font")
 400       (with-output-to-temp-buffer "*Help*"
 401         (describe-font-internal font-info 'verbose)))))
 402
 403 ;; Print information in FONTINFO of a fontset named FONTSET.
 404 (defun describe-fontset-internal (fontset fontset-info)
 405   (print-list "Fontset:" fontset)
 406   (let ((size (aref fontset-info 0)))
 407     (print-list "  size:" (format "%d" size)
 408                 (if (= size 0) "... which means not yet used" "")))
 409   (print-list "  height:" (format "%d" (aref fontset-info 1)))
 410   (print-list "  fonts: (charset : font name)")
 411   (let* ((fonts (aref fontset-info 2))
 412          elt charset requested opened)
 413     (while fonts
 414       (setq elt (car fonts)
 415             charset (car elt)
 416             requested (nth 1 elt)
 417             opened (nth 2 elt))
 418       (print-list "   " charset ":" requested)
 419       (if (stringp opened)
 420           (print-list "      Opened as: " opened)
 421         (if (null opened) "      -- open failed --"))
 422       (setq fonts (cdr fonts)))))
 423
 424 ;;;###autoload
 425 (defun describe-fontset (fontset)
 426   "Display information about FONTSET."
 427   (interactive
 428    (if (not window-system)
 429        (error "No window system being used")
 430      (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))))
 431        (list (completing-read "Fontset: " fontset-list)))))
 432   (setq fontset (query-fontset fontset))
 433   (if (null fontset)
 434       (error "No matching fontset")
 435     (let ((fontset-info (fontset-info fontset)))
 436       (with-output-to-temp-buffer "*Help*"
 437         (describe-fontset-internal fontset fontset-info)))))
 438
 439 \f
 440 ;;; DIAGNOSIS
 441
 442 (defun insert-list (args)
 443   (while (cdr args)
 444     (insert (or (car args) "nil") " ")
 445     (setq args (cdr args)))
 446   (if args (insert (or (car args) "nil")))
 447   (insert "\n"))
 448
 449 (defun insert-section (sec title)
 450   (insert "########################################\n"
 451           "# Section " (format "%d" sec) ".  " title "\n"
 452           "########################################\n\n"))
 453
 454 ;;;###autoload
 455 (defun mule-diag ()
 456   "Show diagnosis of the running Mule."
 457   (interactive)
 458   (let ((buf (get-buffer-create "*Diagnosis*")))
 459     (save-excursion
 460       (set-buffer buf)
 461       (erase-buffer)
 462       (insert "\t###############################\n"
 463               "\t### Diagnosis of your Emacs ###\n"
 464               "\t###############################\n\n"
 465               "CONTENTS: Section 1.  General Information\n"
 466               "          Section 2.  Display\n"
 467               "          Section 3.  Input methods\n"
 468               "          Section 4.  Coding systems\n"
 469               "          Section 5.  Charsets\n")
 470       (if window-system
 471           (insert "          Section 6.  Fontset list\n"))
 472       (insert "\n")
 473
 474       (insert-section 1 "General Information")
 475       (insert "Version of this emacs:\n  " (emacs-version) "\n"
 476               "Primary language:\n  " primary-language "\n\n")
 477
 478       (insert-section 2 "Display")
 479       (if window-system
 480           (insert "Window-system: "
 481                   (symbol-name window-system)
 482                   (format "%s" window-system-version))
 483         (insert "Terminal: " (getenv "TERM")))
 484       (insert "\n\n")
 485
 486       (if (eq window-system 'x)
 487           (let ((font (cdr (assq 'font (frame-parameters)))))
 488             (insert "The selected frame is using the "
 489                     (if (query-fontset font) "fontset" "font")
 490                     ":\n\t" font))
 491         (insert "Coding system of the terminal: "
 492                 (symbol-name (terminal-coding-system))))
 493       (insert "\n\n")
 494
 495       (insert-section 3 "Input methods")
 496       (insert "language\tinput-method\n"
 497               "--------\t------------\n")
 498       (let ((alist language-info-alist))
 499         (while alist
 500           (insert (car (car alist)))
 501           (indent-to 16)
 502           (let ((methods (get-language-info (car (car alist)) 'input-method)))
 503             (if methods
 504                 (insert-list (mapcar 'car methods))
 505               (insert "none\n")))
 506           (setq alist (cdr alist))))
 507       (insert "\n")
 508       (if default-input-method
 509           (insert "The input method used last time is: "
 510                   (cdr default-input-method)
 511                   "\n"
 512                   "        for inputting the language: "
 513                   (car default-input-method)
 514                   "\n")
 515         (insert "No input method has ever been selected.\n"))
 516
 517       (insert "\n")
 518
 519       (insert-section 4 "Coding systems")
 520       (save-excursion (list-coding-systems))
 521       (insert-buffer "*Help*")
 522       (goto-char (point-max))
 523       (insert "\n")
 524
 525       (insert-section 5 "Charsets")
 526       (save-excursion (list-character-sets))
 527       (insert-buffer "*Help*")
 528       (goto-char (point-max))
 529       (insert "\n")
 530
 531       (if window-system
 532           (let ((fontsets (fontset-list)))
 533             (insert-section 6 "Fontset list")
 534             (while fontsets
 535               (describe-fontset (car fontsets))
 536               (insert-buffer "*Help*")
 537               (setq fontsets (cdr fontsets)))))
 538
 539       (set-buffer-modified-p nil)
 540       )
 541     (let ((win (display-buffer buf)))
 542       (set-window-point win 1)
 543       (set-window-start win 1))
 544     ))
 545
 546 \f
 547 ;;; DUMP DATA FILE
 548
 549 ;;;###autoload
 550 (defun dump-charsets ()
 551   "Dump information of all charsets into the file \"charsets.dat\"."
 552   (list-character-sets)
 553   (set-buffer (get-buffer "*Help*"))
 554   (let (make-backup-files)
 555     (write-region (point-min) (point-max) "charsets.dat"))
 556   (kill-emacs))
 557
 558 ;;;###autoload
 559 (defun dump-codings ()
 560   "Dump information of all coding systems into the file \"codings.dat\"."
 561   (list-coding-systems)
 562   (set-buffer (get-buffer "*Help*"))
 563   (let (make-backup-files)
 564     (write-region (point-min) (point-max) "codings.dat"))
 565   (kill-emacs))
 566