root/trunk/lisp/international/mule-diag.el

;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)

;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008  Free Software Foundation, Inc.
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008
;;   National Institute of Advanced Industrial Science and Technology (AIST)
;;   Registration Number H14PRO021

;; Keywords: multilingual, charset, coding system, fontset, diagnosis, i18n

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;; Make sure the help-xref button type is defined.
(require 'help-fns)

;;; General utility function

;; Print all arguments with single space separator in one line.
(defun print-list (&rest args)
  (while (cdr args)
    (when (car args)
      (princ (car args))
      (princ " "))
    (setq args (cdr args)))
  (princ (car args))
  (princ "\n"))

;; Re-order the elements of charset-list.
(defun sort-charset-list ()
  (setq charset-list
        (sort charset-list
              (lambda (x y) (< (charset-id x) (charset-id y))))))

;;; CHARSET

(define-button-type 'sort-listed-character-sets
  'help-echo (purecopy "mouse-2, RET: sort on this column")
  'face 'bold
  'action #'(lambda (button)
              (sort-listed-character-sets (button-get button 'sort-key))))

(define-button-type 'list-charset-chars
  :supertype 'help-xref
  'help-function #'list-charset-chars
  'help-echo "mouse-2, RET: show table of characters for this character set")

;;;###autoload
(defvar non-iso-charset-alist
  `((mac-roman
     (ascii latin-iso8859-1 mule-unicode-2500-33ff
            mule-unicode-0100-24ff mule-unicode-e000-ffff)
     mac-roman-decoder
     ((0 255)))
    (viscii
     (ascii vietnamese-viscii-lower vietnamese-viscii-upper)
     viet-viscii-nonascii-translation-table
     ((0 255)))
    (vietnamese-tcvn
     (ascii vietnamese-viscii-lower vietnamese-viscii-upper)
     viet-tcvn-nonascii-translation-table
     ((0 255)))
    (koi8-r
     (ascii cyrillic-iso8859-5)
     cyrillic-koi8-r-nonascii-translation-table
     ((32 255)))
    (alternativnyj
     (ascii cyrillic-iso8859-5)
     cyrillic-alternativnyj-nonascii-translation-table
     ((32 255)))
    (koi8-u
     (ascii cyrillic-iso8859-5 mule-unicode-0100-24ff)
     cyrillic-koi8-u-nonascii-translation-table
     ((32 255)))
    (big5
     (ascii chinese-big5-1 chinese-big5-2)
     decode-big5-char
     ((32 127)
      ((?\xA1 ?\xFE) . (?\x40 ?\x7E ?\xA1 ?\xFE))))
    (sjis
     (ascii katakana-jisx0201 japanese-jisx0208)
     decode-sjis-char
     ((32 127 ?\xA1 ?\xDF)
      ((?\x81 ?\x9F ?\xE0 ?\xEF) . (?\x40 ?\x7E ?\x80 ?\xFC)))))
  "Alist of charset names vs the corresponding information.
This is mis-named for historical reasons.  The charsets are actually
non-built-in ones.  They correspond to Emacs coding systems, not Emacs
charsets, i.e. what Emacs can read (or write) by mapping to (or
from) Emacs internal charsets that typically correspond to a limited
set of ISO charsets.

Each element has the following format:
  (CHARSET CHARSET-LIST TRANSLATION-METHOD [ CODE-RANGE ])

CHARSET is the name (symbol) of the charset.

CHARSET-LIST is a list of Emacs charsets into which characters of
CHARSET are mapped.

TRANSLATION-METHOD is a translation table (symbol) to translate a
character code of CHARSET to the corresponding Emacs character
code.  It can also be a function to call with one argument, a
character code in CHARSET.

CODE-RANGE specifies the valid code ranges of CHARSET.
It is a list of RANGEs, where each RANGE is of the form:
  (FROM1 TO1 FROM2 TO2 ...)
or
  ((FROM1-1 TO1-1 FROM1-2 TO1-2 ...) . (FROM2-1 TO2-1 FROM2-2 TO2-2 ...))
In the first form, valid codes are between FROM1 and TO1, or FROM2 and
TO2, or...
The second form is used for 2-byte codes.  The car part is the ranges
of the first byte, and the cdr part is the ranges of the second byte.")

;;;###autoload
(defun list-character-sets (arg)
  "Display a list of all character sets.

The ID-NUM column contains a charset identification number for
internal Emacs use.

The MULTIBYTE-FORM column contains the format of the buffer and string
multibyte sequence of characters in the charset using one to four
hexadecimal digits.
  `xx' stands for any byte in the range 0..127.
  `XX' stands for any byte in the range 160..255.

The D column contains the dimension of this character set.  The CH
column contains the number of characters in a block of this character
set.  The FINAL-CHAR column contains an ISO-2022 <final-char> to use
for designating this character set in ISO-2022-based coding systems.

With prefix arg, the output format gets more cryptic,
but still shows the full information."
  (interactive "P")
  (help-setup-xref (list #'list-character-sets arg) (interactive-p))
  (with-output-to-temp-buffer "*Character Set List*"
    (with-current-buffer standard-output
      (if arg
          (list-character-sets-2)
        ;; Insert header.
        (insert "Indirectly supported character sets are shown below.\n")
        (insert
         (substitute-command-keys
          (concat "Use "
                  (if (display-mouse-p) "\\[help-follow-mouse] or ")
                  "\\[help-follow]:\n")))
        (insert "  on a column title to sort by that title,")
        (indent-to 56)
        (insert "+----DIMENSION\n")
        (insert "  on a charset name to list characters.")
        (indent-to 56)
        (insert "| +--CHARS\n")
        (let ((columns '(("ID-NUM" . id) "\t"
                         ("CHARSET-NAME" . name) "\t\t\t"
                         ("MULTIBYTE-FORM" . id) "\t"
                         ("D CH FINAL-CHAR" . iso-spec)))
              pos)
          (while columns
            (if (stringp (car columns))
                (insert (car columns))
              (insert-text-button (car (car columns))
                                  :type 'sort-listed-character-sets
                                  'sort-key (cdr (car columns)))
              (goto-char (point-max)))
            (setq columns (cdr columns)))
          (insert "\n"))
        (insert "------\t------------\t\t\t--------------\t- -- ----------\n")

        ;; Insert body sorted by charset IDs.
        (list-character-sets-1 'id)

        ;; Insert non-directly-supported charsets.
        (insert-char ?- 72)
        (insert "\n\nINDIRECTLY SUPPORTED CHARSETS SETS:\n\n"
                (propertize "CHARSET NAME\tMAPPED TO" 'face 'bold)
                "\n------------\t---------\n")
        (dolist (elt non-iso-charset-alist)
          (insert-text-button (symbol-name (car elt))
                              :type 'list-charset-chars
                              'help-args (list (car elt)))
          (indent-to 16)
          (dolist (e (nth 1 elt))
            (when (>= (+ (current-column) 1 (string-width (symbol-name e)))
                      ;; This is an approximate value.  We don't know
                      ;; the correct window width of this buffer yet.
                      78)
              (insert "\n")
              (indent-to 16))

            (insert (format "%s " e)))
          (insert "\n"))))))

(defun sort-listed-character-sets (sort-key)
  (if sort-key
      (save-excursion
        (help-setup-xref (list #'list-character-sets nil) t)
        (let ((buffer-read-only nil))
          (goto-char (point-min))
          (re-search-forward "[0-9][0-9][0-9]")
          (beginning-of-line)
          (let ((pos (point)))
            (search-forward "----------")
            (beginning-of-line)
            (save-restriction
              (narrow-to-region pos (point))
              (delete-region (point-min) (point-max))
              (list-character-sets-1 sort-key)))))))

(defun charset-multibyte-form-string (charset)
  (let ((info (charset-info charset)))
    (cond ((eq charset 'ascii)
           "xx")
          ((eq charset 'eight-bit-control)
           (format "%2X Xx" (aref info 6)))
          ((eq charset 'eight-bit-graphic)
           "XX")
          (t
           (let ((str (format "%2X" (aref info 6))))
             (if (> (aref info 7) 0)
                 (setq str (format "%s %2X"
                                   str (aref info 7))))
             (setq str (concat str " XX"))
             (if (> (aref info 2) 1)
                 (setq str (concat str " XX")))
             str)))))

;; Insert a list of character sets sorted by SORT-KEY.  SORT-KEY
;; should be one of `id', `name', and `iso-spec'.  If SORT-KEY is nil,
;; it defaults to `id'.

(defun list-character-sets-1 (sort-key)
  (or sort-key
      (setq sort-key 'id))
  (let ((tail (charset-list))
        charset-info-list elt charset info sort-func)
    (while tail
      (setq charset (car tail) tail (cdr tail)
            info (charset-info charset))

      ;; Generate a list that contains all information to display.
      (setq charset-info-list
            (cons (list (charset-id charset)    ; ID-NUM
                        charset                 ; CHARSET-NAME
                        (charset-multibyte-form-string charset); MULTIBYTE-FORM
                        (aref info 2)           ; DIMENSION
                        (aref info 3)           ; CHARS
                        (aref info 8)           ; FINAL-CHAR
                        )
                  charset-info-list)))

    ;; Determine a predicate for `sort' by SORT-KEY.
    (setq sort-func
          (cond ((eq sort-key 'id)
                 (lambda (x y) (< (car x) (car y))))

                ((eq sort-key 'name)
                 (lambda (x y) (string< (nth 1 x) (nth 1 y))))

                ((eq sort-key 'iso-spec)
                 ;; Sort by DIMENSION CHARS FINAL-CHAR
                 (lambda (x y)
                   (or (< (nth 3 x) (nth 3 y))
                       (and (= (nth 3 x) (nth 3 y))
                            (or (< (nth 4 x) (nth 4 y))
                                (and (= (nth 4 x) (nth 4 y))
                                     (< (nth 5 x) (nth 5 y))))))))
                (t
                 (error "Invalid charset sort key: %s" sort-key))))

    (setq charset-info-list (sort charset-info-list sort-func))

    ;; Insert information of character sets.
    (while charset-info-list
      (setq elt (car charset-info-list)
            charset-info-list (cdr charset-info-list))
      (insert (format "%03d(%02X)" (car elt) (car elt))) ; ID-NUM
      (indent-to 8)
      (insert-text-button (symbol-name (nth 1 elt))
                          :type 'list-charset-chars
                          'help-args (list (nth 1 elt)))
      (goto-char (point-max))
      (insert "\t")
      (indent-to 40)
      (insert (nth 2 elt))              ; MULTIBYTE-FORM
      (indent-to 56)
      (insert (format "%d %2d " (nth 3 elt) (nth 4 elt)) ; DIMENSION and CHARS
              (if (< (nth 5 elt) 0) "none" (nth 5 elt))) ; FINAL-CHAR
      (insert "\n"))))


;; List all character sets in a form that a program can easily parse.

(defun list-character-sets-2 ()
  (insert "#########################
## LIST OF CHARSETS
## Each line corresponds to one charset.
## The following attributes are listed in this order
## separated by a colon `:' in one line.
##      CHARSET-ID,
##      CHARSET-SYMBOL-NAME,
##      DIMENSION (1 or 2)
##      CHARS (94 or 96)
##      BYTES (of multibyte form: 1, 2, 3, or 4),
##      WIDTH (occupied column numbers: 1 or 2),
##      DIRECTION (0:left-to-right, 1:right-to-left),
##      ISO-FINAL-CHAR (character code of ISO-2022's final character)
##      ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
##      DESCRIPTION (describing string of the charset)
")
  (let ((l charset-list)
        charset)
    (while l
      (setq charset (car l) l (cdr l))
      (princ (format "%03d:%s:%d:%d:%d:%d:%d:%d:%d:%s\n"
                     (charset-id charset)
                     charset
                     (charset-dimension charset)
                     (charset-chars charset)
                     (charset-bytes charset)
                     (charset-width charset)
                     (charset-direction charset)
                     (charset-iso-final-char charset)
                     (charset-iso-graphic-plane charset)
                     (charset-description charset))))))

(defun decode-codepage-char (codepage code)
  "Decode a character that has code CODE in CODEPAGE.
Return a decoded character string.  Each CODEPAGE corresponds to a
coding system cpCODEPAGE."
  (let ((coding-system (intern (format "cp%d" codepage))))
    (or (coding-system-p coding-system)
        (codepage-setup codepage))
    (string-to-char
     (decode-coding-string (char-to-string code) coding-system))))

;; A variable to hold charset input history.
(defvar charset-history nil)


;;;###autoload
(defun read-charset (prompt &optional default-value initial-input)
  "Read a character set from the minibuffer, prompting with string PROMPT.
It must be an Emacs character set listed in the variable `charset-list'
or a non-ISO character set listed in the variable
`non-iso-charset-alist'.

Optional arguments are DEFAULT-VALUE and INITIAL-INPUT.
DEFAULT-VALUE, if non-nil, is the default value.
INITIAL-INPUT, if non-nil, is a string inserted in the minibuffer initially.
See the documentation of the function `completing-read' for the
detailed meanings of these arguments."
  (let* ((table (append (mapcar (lambda (x) (list (symbol-name x)))
                                charset-list)
                        (mapcar (lambda (x) (list (symbol-name (car x))))
                                non-iso-charset-alist)))
         (charset (completing-read prompt table
                                   nil t initial-input 'charset-history
                                   default-value)))
    (if (> (length charset) 0)
        (intern charset))))


;; List characters of the range MIN and MAX of CHARSET.  If dimension
;; of CHARSET is two (i.e. 2-byte charset), ROW is the first byte
;; (block index) of the characters, and MIN and MAX are the second
;; bytes of the characters.  If the dimension is one, ROW should be 0.
;; For a non-ISO charset, CHARSET is a translation table (symbol) or a
;; function to get Emacs' character codes that corresponds to the
;; characters to list.

(defun list-block-of-chars (charset row min max)
  (let (i ch)
    (insert-char ?- (+ 4 (* 3 16)))
    (insert "\n    ")
    (setq i 0)
    (while (< i 16)
      (insert (format "%3X" i))
      (setq i (1+ i)))
    (setq i (* (/ min 16) 16))
    (while (<= i max)
      (if (= (% i 16) 0)
          (insert (format "\n%3Xx" (/ (+ (* row 256) i) 16))))
      (setq ch (cond ((< i min)
                      32)
                     ((charsetp charset)
                      (if (= row 0)
                          (make-char charset i)
                        (make-char charset row i)))
                     ((and (symbolp charset) (get charset 'translation-table))
                      (aref (get charset 'translation-table) i))
                     (t (funcall charset (+ (* row 256) i)))))
      (if (and (char-table-p charset)
               (or (< ch 32) (and (>= ch 127) (<= ch 255))))
          ;; Don't insert a control code.
          (setq ch 32))
      (unless ch (setq ch 32))
      (if (eq ch ?\t)
          ;; Make it visible.
          (setq ch (propertize "\t" 'display "^I")))
      ;; This doesn't DTRT.  Maybe it's better to insert "^J" and not
      ;; worry about the buffer contents not being correct.
;;;       (if (eq ch ?\n)
;;;     (setq ch (propertize "\n" 'display "^J")))
      (indent-to (+ (* (% i 16) 3) 6))
      (insert ch)
      (setq i (1+ i))))
  (insert "\n"))

(defun list-iso-charset-chars (charset)
  (let ((dim (charset-dimension charset))
        (chars (charset-chars charset))
        (plane (charset-iso-graphic-plane charset))
        min max)
    (insert (format "Characters in the coded character set %s.\n" charset))

    (cond ((eq charset 'eight-bit-control)
           (setq min 128 max 159))
          ((eq charset 'eight-bit-graphic)
           (setq min 160 max 255))
          (t
           (if (= chars 94)
               (setq min 33 max 126)
             (setq min 32 max 127))
           (or (= plane 0)
               (setq min (+ min 128) max (+ max 128)))))

    (if (= dim 1)
        (list-block-of-chars charset 0 min max)
      (let ((i min))
        (while (<= i max)
          (list-block-of-chars charset i min max)
          (setq i (1+ i)))))))

(defun list-non-iso-charset-chars (charset)
  "List all characters in non-built-in coded character set CHARSET."
  (let* ((slot (assq charset non-iso-charset-alist))
         (charsets (nth 1 slot))
         (translate-method (nth 2 slot))
         (ranges (nth 3 slot))
         range)
    (or slot
        (error "Unknown character set: %s" charset))
    (insert (format "Characters in the coded character set %s.\n" charset))
    (if charsets
        (insert "They are mapped to: "
                (mapconcat #'symbol-name charsets ", ")
                "\n"))
    (while ranges
      (setq range (pop ranges))
      (if (integerp (car range))
          ;; The form of RANGES is (FROM1 TO1 FROM2 TO2 ...).
          (if (and (not (functionp translate-method))
                   (< (car (last range)) 256))
              ;; Do it all in one block to avoid the listing being
              ;; broken up at gaps in the range.  Don't do that for
              ;; function translate-method, since not all codes in
              ;; that range may be valid.
              (list-block-of-chars translate-method
                                   0 (car range) (car (last range)))
            (while range
              (list-block-of-chars translate-method
                                   0 (car range) (nth 1 range))
              (setq range (nthcdr 2 range))))
        ;; The form of RANGES is ((FROM1-1 TO1-1 ...) . (FROM2-1 TO2-1 ...)).
        (let ((row-range (car range))
              row row-max
              col-range col col-max)
          (while row-range
            (setq row (car row-range) row-max (nth 1 row-range)
                  row-range (nthcdr 2 row-range))
            (while (<= row row-max)
              (setq col-range (cdr range))
              (while col-range
                (setq col (car col-range) col-max (nth 1 col-range)
                      col-range (nthcdr 2 col-range))
                (list-block-of-chars translate-method row col col-max))
              (setq row (1+ row)))))))))


;;;###autoload
(defun list-charset-chars (charset)
  "Display a list of characters in the specified character set.
This can list both Emacs `official' (ISO standard) charsets and the
characters encoded by various Emacs coding systems which correspond to
PC `codepages' and other coded character sets.  See `non-iso-charset-alist'."
  (interactive (list (read-charset "Character set: ")))
  (with-output-to-temp-buffer "*Character List*"
    (with-current-buffer standard-output
      (setq mode-line-format (copy-sequence mode-line-format))
      (let ((slot (memq 'mode-line-buffer-identification mode-line-format)))
        (if slot
            (setcdr slot
                    (cons (format " (%s)" charset)
                          (cdr slot)))))
      (setq indent-tabs-mode nil)
      (set-buffer-multibyte t)
      (cond ((charsetp charset)
             (list-iso-charset-chars charset))
            ((assq charset non-iso-charset-alist)
             (list-non-iso-charset-chars charset))
            (t
             (error "Invalid character set %s" charset))))))


;;;###autoload
(defun describe-character-set (charset)
  "Display information about built-in character set CHARSET."
  (interactive (list (let ((non-iso-charset-alist nil))
                       (read-charset "Charset: "))))
  (or (charsetp charset)
      (error "Invalid charset: %S" charset))
  (let ((info (charset-info charset)))
    (help-setup-xref (list #'describe-character-set charset) (interactive-p))
    (with-output-to-temp-buffer (help-buffer)
      (with-current-buffer standard-output
        (insert "Character set: " (symbol-name charset)
                (format " (ID:%d)\n\n" (aref info 0)))
        (insert (aref info 13) "\n\n")  ; description
        (insert "Number of contained characters: "
                (if (= (aref info 2) 1)
                    (format "%d\n" (aref info 3))
                  (format "%dx%d\n" (aref info 3) (aref info 3))))
        (insert "Final char of ISO2022 designation sequence: ")
        (if (>= (aref info 8) 0)
            (insert (format "`%c'\n" (aref info 8)))
          (insert "not assigned\n"))
        (insert (format "Width (how many columns on screen): %d\n"
                        (aref info 4)))
        (insert (format "Internal multibyte sequence: %s\n"
                        (charset-multibyte-form-string charset)))
        (let ((coding (plist-get (aref info 14) 'preferred-coding-system)))
          (when coding
            (insert (format "Preferred coding system: %s\n" coding))
            (search-backward (symbol-name coding))
            (help-xref-button 0 'help-coding-system coding)))))))

;;; CODING-SYSTEM

;; Print information of designation of each graphic register in FLAGS
;; in human readable format.  See the documentation of
;; `make-coding-system' for the meaning of FLAGS.
(defun print-designation (flags)
  (let ((graphic-register 0)
        charset)
    (while (< graphic-register 4)
      (setq charset (aref flags graphic-register))
      (princ (format
              "  G%d -- %s\n"
              graphic-register
              (cond ((null charset)
                     "never used")
                    ((eq charset t)
                     "no initial designation, and used by any charsets")
                    ((symbolp charset)
                     (format "%s:%s"
                             charset (charset-description charset)))
                    ((listp charset)
                     (if (charsetp (car charset))
                         (format "%s:%s, and also used by the following:"
                                 (car charset)
                                 (charset-description (car charset)))
                       "no initial designation, and used by the following:"))
                    (t
                     "invalid designation information"))))
      (when (listp charset)
        (setq charset (cdr charset))
        (while charset
          (cond ((eq (car charset) t)
                 (princ "\tany other charsets\n"))
                ((charsetp (car charset))
                 (princ (format "\t%s:%s\n"
                                (car charset)
                                (charset-description (car charset)))))
                (t
                 "invalid designation information"))
          (setq charset (cdr charset))))
      (setq graphic-register (1+ graphic-register)))))

;;;###autoload
(defun describe-coding-system (coding-system)
  "Display information about CODING-SYSTEM."
  (interactive "zDescribe coding system (default current choices): ")
  (if (null coding-system)
      (describe-current-coding-system)
    (help-setup-xref (list #'describe-coding-system coding-system)
                     (interactive-p))
    (with-output-to-temp-buffer (help-buffer)
      (print-coding-system-briefly coding-system 'doc-string)
      (princ "\n")
      (let ((vars (coding-system-get coding-system 'dependency)))
        (when vars
          (princ "See also the documentation of these customizable variables
which alter the behavior of this coding system.\n")
          (dolist (v vars)
            (princ "  `")
            (princ v)
            (princ "'\n"))
          (princ "\n")))

      (princ "Type: ")
      (let ((type (coding-system-type coding-system))
            (flags (coding-system-flags coding-system)))
        (princ type)
        (cond ((eq type nil)
               (princ " (do no conversion)"))
              ((eq type t)
               (princ " (do automatic conversion)"))
              ((eq type 0)
               (princ " (Emacs internal multibyte form)"))
              ((eq type 1)
               (princ " (Shift-JIS, MS-KANJI)"))
              ((eq type 2)
               (princ " (variant of ISO-2022)\n")
               (princ "Initial designations:\n")
               (print-designation flags)
               (princ "Other Form: \n  ")
               (princ (if (aref flags 4) "short-form" "long-form"))
               (if (aref flags 5) (princ ", ASCII@EOL"))
               (if (aref flags 6) (princ ", ASCII@CNTL"))
               (princ (if (aref flags 7) ", 7-bit" ", 8-bit"))
               (if (aref flags 8) (princ ", use-locking-shift"))
               (if (aref flags 9) (princ ", use-single-shift"))
               (if (aref flags 10) (princ ", use-roman"))
               (if (aref flags 11) (princ ", use-old-jis"))
               (if (aref flags 12) (princ ", no-ISO6429"))
               (if (aref flags 13) (princ ", init-bol"))
               (if (aref flags 14) (princ ", designation-bol"))
               (if (aref flags 15) (princ ", convert-unsafe"))
               (if (aref flags 16) (princ ", accept-latin-extra-code"))
               (princ "."))
              ((eq type 3)
               (princ " (Big5)"))
              ((eq type 4)
               (princ " (do conversion by CCL program)"))
              ((eq type 5)
               (princ " (text with random binary characters)"))
              (t (princ ": invalid coding-system."))))
      (princ "\nEOL type: ")
      (let ((eol-type (coding-system-eol-type coding-system)))
        (cond ((vectorp eol-type)
               (princ "Automatic selection from:\n\t")
               (princ eol-type)
               (princ "\n"))
              ((or (null eol-type) (eq eol-type 0)) (princ "LF\n"))
              ((eq eol-type 1) (princ "CRLF\n"))
              ((eq eol-type 2) (princ "CR\n"))
              (t (princ "invalid\n"))))
      (let ((postread (coding-system-get coding-system 'post-read-conversion)))
        (when postread
          (princ "After decoding text normally,")
          (princ " perform post-conversion using the function: ")
          (princ "\n  ")
          (princ postread)
          (princ "\n")))
      (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
        (when prewrite
          (princ "Before encoding text normally,")
          (princ " perform pre-conversion using the function: ")
          (princ "\n  ")
          (princ prewrite)
          (princ "\n")))
      (with-current-buffer standard-output
        (let ((charsets (coding-system-get coding-system 'safe-charsets)))
          (when (and (not (memq (coding-system-base coding-system)
                                '(raw-text emacs-mule)))
                     charsets)
            (if (eq charsets t)
                (insert "This coding system can encode all charsets except for
eight-bit-control and eight-bit-graphic.\n")
              (insert "This coding system encodes the following charsets:\n ")
              (while charsets
                (insert " " (symbol-name (car charsets)))
                (search-backward (symbol-name (car charsets)))
                (help-xref-button 0 'help-character-set (car charsets))
                (goto-char (point-max))
                (setq charsets (cdr charsets))))))))))


;;;###autoload
(defun describe-current-coding-system-briefly ()
  "Display coding systems currently used in a brief format in echo area.

The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
where mnemonics of the following coding systems come in this order
in place of `..':
  `buffer-file-coding-system' (of the current buffer)
  eol-type of `buffer-file-coding-system' (of the current buffer)
  Value returned by `keyboard-coding-system'
  eol-type of `keyboard-coding-system'
  Value returned by `terminal-coding-system'.
  eol-type of `terminal-coding-system'
  `process-coding-system' for read (of the current buffer, if any)
  eol-type of `process-coding-system' for read (of the current buffer, if any)
  `process-coding-system' for write (of the current buffer, if any)
  eol-type of `process-coding-system' for write (of the current buffer, if any)
  `default-buffer-file-coding-system'
  eol-type of `default-buffer-file-coding-system'
  `default-process-coding-system' for read
  eol-type of `default-process-coding-system' for read
  `default-process-coding-system' for write
  eol-type of `default-process-coding-system'"
  (interactive)
  (let* ((proc (get-buffer-process (current-buffer)))
         (process-coding-systems (if proc (process-coding-system proc))))
    (message
     "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]"
     (coding-system-mnemonic buffer-file-coding-system)
     (coding-system-eol-type-mnemonic buffer-file-coding-system)
     (coding-system-mnemonic (keyboard-coding-system))
     (coding-system-eol-type-mnemonic (keyboard-coding-system))
     (coding-system-mnemonic (terminal-coding-system))
     (coding-system-eol-type-mnemonic (terminal-coding-system))
     (coding-system-mnemonic (car process-coding-systems))
     (coding-system-eol-type-mnemonic (car process-coding-systems))
     (coding-system-mnemonic (cdr process-coding-systems))
     (coding-system-eol-type-mnemonic (cdr process-coding-systems))
     (coding-system-mnemonic default-buffer-file-coding-system)
     (coding-system-eol-type-mnemonic default-buffer-file-coding-system)
     (coding-system-mnemonic (car default-process-coding-system))
     (coding-system-eol-type-mnemonic (car default-process-coding-system))
     (coding-system-mnemonic (cdr default-process-coding-system))
     (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
     )))

;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
;; If DOC-STRING is non-nil, print also the docstring of CODING-SYSTEM.
;; If DOC-STRING is `tightly', don't print an empty line before the
;; docstring, and print only the first line of the docstring.

(defun print-coding-system-briefly (coding-system &optional doc-string)
  (if (not coding-system)
      (princ "nil\n")
    (princ (format "%c -- %s"
                   (coding-system-mnemonic coding-system)
                   coding-system))
    (let ((aliases (coding-system-get coding-system 'alias-coding-systems)))
      (cond ((eq coding-system (car aliases))
             (if (cdr aliases)
                 (princ (format " %S" (cons 'alias: (cdr aliases))))))
            ((memq coding-system aliases)
             (princ (format " (alias of %s)" (car aliases))))
            (t
             (let ((eol-type (coding-system-eol-type coding-system))
                   (base-eol-type (coding-system-eol-type (car aliases))))
               (if (and (integerp eol-type)
                        (vectorp base-eol-type)
                        (not (eq coding-system (aref base-eol-type eol-type))))
                   (princ (format " (alias of %s)"
                                  (aref base-eol-type eol-type))))))))
    (princ "\n")
    (or (eq doc-string 'tightly)
        (princ "\n"))
    (if doc-string
        (let ((doc (or (coding-system-doc-string coding-system) "")))
          (when (eq doc-string 'tightly)
            (if (string-match "\n" doc)
                (setq doc (substring doc 0 (match-beginning 0))))
            (setq doc (concat "  " doc)))
          (princ (format "%s\n" doc))))))

;;;###autoload
(defun describe-current-coding-system ()
  "Display coding systems currently used, in detail."
  (interactive)
  (with-output-to-temp-buffer "*Help*"
    (let* ((proc (get-buffer-process (current-buffer)))
           (process-coding-systems (if proc (process-coding-system proc))))
      (princ "Coding system for saving this buffer:\n  ")
      (if (local-variable-p 'buffer-file-coding-system)
          (print-coding-system-briefly buffer-file-coding-system)
        (princ "Not set locally, use the default.\n"))
      (princ "Default coding system (for new files):\n  ")
    &nb