-;; mule-diag.el -- show diagnosis of multilingual environment (MULE)
+;;; mule-diag.el --- Show diagnosis of multilingual environment (MULE)
-;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
+;; Licensed to the Free Software Foundation.
;; Keywords: multilingual, charset, coding system, fontset, diagnosis
;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; General utility function
;; Print all arguments with single space separator in one line.
(defun print-list (&rest args)
(while (cdr args)
- (if (car args)
- (progn (princ (car args)) (princ " ")))
+ (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
+ (function (lambda (x y) (< (charset-id x) (charset-id y)))))))
+
;;; CHARSET
;;;###autoload
-(defun list-character-sets ()
- "Display a list of all charsets."
- (interactive)
+(defun list-character-sets (&optional arg)
+ "Display a list of all character sets.
+
+The ID column contains a charset identification number for internal Emacs use.
+The B column contains a number of bytes occupied in a buffer
+ by any character in this character set.
+The W column contains a number of columns occupied on the screen
+ by any character in this character set.
+
+With prefix arg, the output format gets more cryptic,
+but still shows the full information."
+ (interactive "P")
+ (sort-charset-list)
(with-output-to-temp-buffer "*Help*"
- (print-character-sets)))
+ (save-excursion
+ (set-buffer standard-output)
+ (list-character-sets-1 arg)
+ (help-mode)
+ (setq truncate-lines t))))
-(defvar charset-other-info-func nil)
-
-(defun print-character-sets ()
- "Print information on all charsets in a machine readable format."
- (princ "\
+(defun list-character-sets-1 (arg)
+ (let ((l charset-list)
+ charset)
+ (if (null arg)
+ (progn
+ (insert "ID Name B W Description\n")
+ (insert "-- ---- - - -----------\n")
+ (while l
+ (setq charset (car l) l (cdr l))
+ (insert (format "%03d %s" (charset-id charset) charset))
+ (indent-to 28)
+ (insert (format "%d %d %s\n"
+ (charset-bytes charset)
+ (charset-width charset)
+ (charset-description charset)))))
+ (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-SYMBOL-NAME,
## CHARSET-ID,
+## CHARSET-SYMBOL-NAME,
## DIMENSION (1 or 2)
## CHARS (94 or 96)
## BYTES (of multibyte form: 1, 2, 3, or 4),
## ISO-GRAPHIC-PLANE (ISO-2022's graphic plane, 0:GL, 1:GR)
## DESCRIPTION (describing string of the charset)
")
- (let ((charsets charset-list)
- charset)
- (while charsets
- (setq charset (car charsets))
- (princ (format "%s:%03d:%d:%d:%d:%d:%d:%d:%d:%s\n"
- charset
- (charset-id 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)))
- (setq charsets (cdr charsets)))))
-
+ (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)))))))
\f
;;; CODING-SYSTEM
"no initial designation, and used by the followings:"))
(t
"invalid designation information"))))
- (if (listp charset)
- (progn
- (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)))))
+ (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 of CODING-SYSTEM."
- (interactive "zCoding-system: ")
- (check-coding-system coding-system)
- (with-output-to-temp-buffer "*Help*"
- (let ((coding-vector (coding-system-vector coding-system)))
- (princ "Coding-system ")
- (princ coding-system)
- (princ " [")
- (princ (char-to-string (coding-vector-mnemonic coding-vector)))
- (princ "]: \n")
- (princ " ")
- (princ (coding-vector-docstring coding-vector))
- (princ "\nType: ")
- (let ((type (coding-vector-type coding-vector))
- (flags (coding-vector-flags coding-vector)))
- (princ type)
- (princ ", which means ")
- (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 "a 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 10) (princ ", use-old-jis"))
- (if (aref flags 11) (princ ", no-ISO6429"))
- (princ "."))
- ((eq type 3)
- (princ "Big5."))
- ((eq type 4)
- (princ "do conversion by CCL program."))
- (t (princ "invalid coding-system."))))
- (princ "\nEOL-Type: ")
- (let ((eol-type (coding-system-eoltype coding-system)))
- (cond ((vectorp eol-type)
- (princ "Automatic selection from ")
- (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"))))
- )))
+ "Display information about CODING-SYSTEM."
+ (interactive "zDescribe coding system (default, current choices): ")
+ (if (null coding-system)
+ (describe-current-coding-system)
+ (with-output-to-temp-buffer "*Help*"
+ (print-coding-system-briefly coding-system 'doc-string)
+ (let ((coding-spec (coding-system-spec coding-system)))
+ (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 10) (princ ", use-old-jis"))
+ (if (aref flags 11) (princ ", no-ISO6429"))
+ (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 a text normally,")
+ (princ " perform post-conversion by the function: ")
+ (princ "\n ")
+ (princ postread)
+ (princ "\n")))
+ (let ((prewrite (coding-system-get coding-system 'pre-write-conversion)))
+ (when prewrite
+ (princ "Before encoding a text normally,")
+ (princ " perform pre-conversion by the function: ")
+ (princ "\n ")
+ (princ prewrite)
+ (princ "\n")))
+ (let ((charsets (coding-system-get coding-system 'safe-charsets)))
+ (when charsets
+ (if (eq charsets t)
+ (princ "This coding system can encode charsets:\n")
+ (princ "This coding system encode the following charsets:\n")
+ (princ " ")
+ (while charsets
+ (princ " ")
+ (princ (car charsets))
+ (setq charsets (cdr charsets))))))
+ (save-excursion
+ (set-buffer standard-output)
+ (help-mode)))))
;;;###autoload
(defun describe-current-coding-system-briefly ()
- "Display coding systems currently used in a brief format in mini-buffer.
+ "Display coding systems currently used in a brief format in echo area.
-The format is \"current: [FKTPp=........] default: [FPp=......]\",
+The format is \"F[..],K[..],T[..],P>[..],P<[..], default F[..],P<[..],P<[..]\",
where mnemonics of the following coding systems come in this order
-at the place of `...':
- buffer-file-coding-system (of the current buffer)
+at the place of `..':
+ `buffer-file-coding-system` (of the current buffer)
eol-type of buffer-file-coding-system (of the current buffer)
- keyboard-coding-system
- terminal-coding-system
- process-coding-system for read (of the current buffer, if any)
+ 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)
+ `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
- default eol-type of process-coding-system for read
- default process-coding-system for write
- default eol-type of process-coding-system"
+ `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
- "current: [FKTPp=%c%c%c%c%c%c%c%c] default: [FPp=%c%c%c%c%c%c]"
+ "F[%c%c],K[%c%c],T[%c%c],P>[%c%c],P<[%c%c], default F[%c%c],P>[%c%c],P<[%c%c]"
(coding-system-mnemonic buffer-file-coding-system)
- (coding-system-eoltype-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-eoltype-mnemonic (car process-coding-systems))
+ (coding-system-eol-type-mnemonic (car process-coding-systems))
(coding-system-mnemonic (cdr process-coding-systems))
- (coding-system-eoltype-mnemonic (cdr process-coding-systems))
- (coding-system-mnemonic (default-value 'buffer-file-coding-system))
- (coding-system-eoltype-mnemonic (default-value 'buffer-file-coding-system))
+ (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-eoltype-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-eoltype-mnemonic (cdr default-process-coding-system))
+ (coding-system-eol-type-mnemonic (cdr default-process-coding-system))
)))
-;; Print symbol name and mnemonics of CODING-SYSTEM by `princ'.
-(defsubst print-coding-system-briefly (coding-system)
- (print-list ":"
- coding-system
- (format "[%c%c]"
- (coding-system-mnemonic coding-system)
- (coding-system-eoltype-mnemonic coding-system))))
+;; Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'.
+(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)))
+ (if (eq coding-system (car aliases))
+ (if (cdr aliases)
+ (princ (format " %S" (cons 'alias: (cdr aliases)))))
+ (if (memq coding-system aliases)
+ (princ (format " (alias of %s)" (car aliases))))))
+ (princ "\n")
+ (if (and doc-string
+ (setq doc-string (coding-system-doc-string coding-system)))
+ (princ (format " %s\n" doc-string)))))
;;;###autoload
(defun describe-current-coding-system ()
- "Display coding systems currently used in a detailed format."
+ "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 "Current:\n buffer-file-coding-system")
- (print-coding-system-briefly buffer-file-coding-system)
- (princ " keyboard-coding-system")
+ (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 ")
+ (print-coding-system-briefly default-buffer-file-coding-system)
+ (princ "Coding system for keyboard input:\n ")
(print-coding-system-briefly (keyboard-coding-system))
- (princ " terminal-coding-system")
+ (princ "Coding system for terminal output:\n ")
(print-coding-system-briefly (terminal-coding-system))
- (if process-coding-systems
- (progn (princ " process-coding-system (read)")
- (print-coding-system-briefly (car process-coding-systems))
- (princ " process-coding-system (write)")
- (print-coding-system-briefly (cdr process-coding-systems))))
- (princ "Default:\n buffer-file-coding-system")
- (print-coding-system-briefly (default-value 'buffer-file-coding-system))
- (princ " process-coding-system (read)")
+ (when (get-buffer-process (current-buffer))
+ (princ "Coding systems for process I/O:\n")
+ (princ " encoding input to the process: ")
+ (print-coding-system-briefly (cdr process-coding-systems))
+ (princ " decoding output from the process: ")
+ (print-coding-system-briefly (car process-coding-systems)))
+ (princ "Defaults for subprocess I/O:\n")
+ (princ " decoding: ")
(print-coding-system-briefly (car default-process-coding-system))
- (princ " process-coding-system (write)")
- (print-coding-system-briefly (cdr default-process-coding-system))
- (princ "coding-system-alist:\n")
- (pp coding-system-alist))
- (let ((l coding-category-list))
- (princ "\nCoding categories (in the order of priority):\n")
- (while l
- (princ (format "%s -> %s\n" (car l) (symbol-value (car l))))
- (setq l (cdr l))))))
+ (princ " encoding: ")
+ (print-coding-system-briefly (cdr default-process-coding-system)))
+
+ (save-excursion
+ (set-buffer standard-output)
+
+ (princ "\nPriority order for recognizing coding systems when reading files:\n")
+ (let ((l coding-category-list)
+ (i 1)
+ (coding-list nil)
+ coding aliases)
+ (while l
+ (setq coding (symbol-value (car l)))
+ ;; Do not list up the same coding system twice.
+ (when (and coding (not (memq coding coding-list)))
+ (setq coding-list (cons coding coding-list))
+ (princ (format " %d. %s " i coding))
+ (setq aliases (coding-system-get coding 'alias-coding-systems))
+ (if (eq coding (car aliases))
+ (if (cdr aliases)
+ (princ (cons 'alias: (cdr aliases))))
+ (if (memq coding aliases)
+ (princ (list 'alias 'of (car aliases)))))
+ (terpri)
+ (setq i (1+ i)))
+ (setq l (cdr l))))
+
+ (princ "\n Other coding systems cannot be distinguished automatically
+ from these, and therefore cannot be recognized automatically
+ with the present coding system priorities.\n\n")
+
+ (let ((categories '(coding-category-iso-7 coding-category-iso-7-else))
+ coding-system codings)
+ (while categories
+ (setq coding-system (symbol-value (car categories)))
+ (mapcar
+ (function
+ (lambda (x)
+ (if (and (not (eq x coding-system))
+ (coding-system-get x 'no-initial-designation)
+ (let ((flags (coding-system-flags x)))
+ (not (or (aref flags 10) (aref flags 11)))))
+ (setq codings (cons x codings)))))
+ (get (car categories) 'coding-systems))
+ (if codings
+ (let ((max-col (frame-width))
+ pos)
+ (princ (format " The followings are decoded correctly but recognized as %s:\n " coding-system))
+ (while codings
+ (setq pos (point))
+ (insert (format " %s" (car codings)))
+ (when (> (current-column) max-col)
+ (goto-char pos)
+ (insert "\n ")
+ (goto-char (point-max)))
+ (setq codings (cdr codings)))
+ (insert "\n\n")))
+ (setq categories (cdr categories))))
+
+ (princ "Particular coding systems specified for certain file names:\n")
+ (terpri)
+ (princ " OPERATION\tTARGET PATTERN\t\tCODING SYSTEM(s)\n")
+ (princ " ---------\t--------------\t\t----------------\n")
+ (let ((func (lambda (operation alist)
+ (princ " ")
+ (princ operation)
+ (if (not alist)
+ (princ "\tnothing specified\n")
+ (while alist
+ (indent-to 16)
+ (prin1 (car (car alist)))
+ (if (>= (current-column) 40)
+ (newline))
+ (indent-to 40)
+ (princ (cdr (car alist)))
+ (princ "\n")
+ (setq alist (cdr alist)))))))
+ (funcall func "File I/O" file-coding-system-alist)
+ (funcall func "Process I/O" process-coding-system-alist)
+ (funcall func "Network I/O" network-coding-system-alist))
+ (help-mode))))
;; Print detailed information on CODING-SYSTEM.
(defun print-coding-system (coding-system)
(let ((type (coding-system-type coding-system))
- (eol-type (coding-system-eoltype coding-system))
- (flags (coding-system-flags coding-system)))
- (princ (format "%s:%s:%c:%d:"
- coding-system
- type
- (coding-system-mnemonic coding-system)
- (if (integerp eol-type) eol-type 3)))
- (cond ((eq type 2) ; ISO-2022
- (let ((idx 0)
- charset)
- (while (< idx 4)
- (setq charset (aref flags idx))
- (cond ((null charset)
- (princ -1))
- ((eq charset t)
- (princ -2))
- ((charsetp charset)
- (princ charset))
- ((listp charset)
- (princ "(")
- (princ (car charset))
- (setq charset (cdr charset))
- (while charset
- (princ ",")
+ (eol-type (coding-system-eol-type coding-system))
+ (flags (coding-system-flags coding-system))
+ (aliases (coding-system-get coding-system 'alias-coding-systems)))
+ (if (not (eq (car aliases) coding-system))
+ (princ (format "%s (alias of %s)\n" coding-system (car aliases)))
+ (princ coding-system)
+ (setq aliases (cdr aliases))
+ (while aliases
+ (princ ",")
+ (princ (car aliases))
+ (setq aliases (cdr aliases)))
+ (princ (format ":%s:%c:%d:"
+ type
+ (coding-system-mnemonic coding-system)
+ (if (integerp eol-type) eol-type 3)))
+ (cond ((eq type 2) ; ISO-2022
+ (let ((idx 0)
+ charset)
+ (while (< idx 4)
+ (setq charset (aref flags idx))
+ (cond ((null charset)
+ (princ -1))
+ ((eq charset t)
+ (princ -2))
+ ((charsetp charset)
+ (princ charset))
+ ((listp charset)
+ (princ "(")
(princ (car charset))
- (setq charset (cdr charset)))
- (princ ")")))
- (princ ",")
- (setq idx (1+ idx)))
- (while (< idx 12)
- (princ (if (aref flags idx) 1 0))
+ (setq charset (cdr charset))
+ (while charset
+ (princ ",")
+ (princ (car charset))
+ (setq charset (cdr charset)))
+ (princ ")")))
+ (princ ",")
+ (setq idx (1+ idx)))
+ (while (< idx 12)
+ (princ (if (aref flags idx) 1 0))
+ (princ ",")
+ (setq idx (1+ idx)))
+ (princ (if (aref flags idx) 1 0))))
+ ((eq type 4) ; CCL
+ (let (i len)
+ (if (symbolp (car flags))
+ (princ (format " %s" (car flags)))
+ (setq i 0 len (length (car flags)))
+ (while (< i len)
+ (princ (format " %x" (aref (car flags) i)))
+ (setq i (1+ i))))
(princ ",")
- (setq idx (1+ idx)))
- (princ (if (aref flags idx) 1 0))))
- ((eq type 4) ; CCL
- (let (i len)
- (setq i 0 len (length (car flags)))
- (while (< i len)
- (princ (format " %x" (aref (car flags) i)))
- (setq i (1+ i)))
- (princ ",")
- (setq i 0 len (length (cdr flags)))
- (while (< i len)
- (princ (format " %x" (aref (cdr flags) i)))
- (setq i (1+ i)))))
- (t (princ 0)))
- (princ ":")
- (princ (coding-system-docstring coding-system))
- (princ "\n")))
-
-(defun list-coding-systems ()
- "Print information on all coding systems in a machine readable format."
+ (if (symbolp (cdr flags))
+ (princ (format "%s" (cdr flags)))
+ (setq i 0 len (length (cdr flags)))
+ (while (< i len)
+ (princ (format " %x" (aref (cdr flags) i)))
+ (setq i (1+ i))))))
+ (t (princ 0)))
+ (princ ":")
+ (princ (coding-system-doc-string coding-system))
+ (princ "\n"))))
+
+;;;###autoload
+(defun list-coding-systems (&optional arg)
+ "Display a list of all coding systems.
+This shows the mnemonic letter, name, and description of each coding system.
+
+With prefix arg, the output format gets more cryptic,
+but still contains full information about each coding system."
+ (interactive "P")
(with-output-to-temp-buffer "*Help*"
+ (list-coding-systems-1 arg)))
+
+(defun list-coding-systems-1 (arg)
+ (if (null arg)
+ (princ "\
+###############################################
+# List of coding systems in the following format:
+# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
+# DOC-STRING
+")
(princ "\
#########################
## LIST OF CODING SYSTEMS
## Each line corresponds to one coding system
## Format of a line is:
-## NAME:TYPE:MNEMONIC:EOL:FLAGS:DOCSTRING,
+## NAME[,ALIAS...]:TYPE:MNEMONIC:EOL:FLAGS:POST-READ-CONVERSION
+## :PRE-WRITE-CONVERSION:DOC-STRING,
## where
-## TYPE = nil (no conversion), t (auto conversion),
-## 0 (Mule internal), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
+## NAME = coding system name
+## ALIAS = alias of the coding system
+## TYPE = nil (no conversion), t (undecided or automatic detection),
+## 0 (EMACS-MULE), 1 (SJIS), 2 (ISO2022), 3 (BIG5), or 4 (CCL)
## EOL = 0 (LF), 1 (CRLF), 2 (CR), or 3 (Automatic detection)
## FLAGS =
## if TYPE = 2 then
## comma (`,') separated CCL programs for read and write
## else
## 0
+## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
##
-")
- (let ((codings (make-vector 7 nil)))
- (mapatoms
- (function
- (lambda (arg)
- (if (and arg
- (coding-system-p arg)
- (null (get arg 'pre-write-conversion))
- (null (get arg 'post-read-conversion)))
- (let* ((type (coding-system-type arg))
- (idx (if (null type) 0 (if (eq type t) 1 (+ type 2)))))
- (if (or (= idx 0)
- (vectorp (coding-system-eoltype arg)))
- (aset codings idx (cons arg (aref codings idx)))))))))
- (let ((idx 0) elt)
- (while (< idx 7)
- (setq elt (aref codings idx))
- (while elt
- (print-coding-system (car elt))
- (setq elt (cdr elt)))
- (setq idx (1+ idx)))))
+"))
+ (let ((bases (coding-system-list 'base-only))
+ coding-system)
+ (while bases
+ (setq coding-system (car bases))
+ (if (null arg)
+ (print-coding-system-briefly coding-system 'doc-string)
+ (print-coding-system coding-system))
+ (setq bases (cdr bases)))))
+
+;;;###automatic
+(defun list-coding-categories ()
+ "Display a list of all coding categories."
+ (with-output-to-temp-buffer "*Help*"
(princ "\
############################
## LIST OF CODING CATEGORIES (ordered by priority)
(let ((l coding-category-list))
(while l
(princ (format "%s:%s\n" (car l) (symbol-value (car l))))
- (setq l (cdr l))))
- ))
+ (setq l (cdr l))))))
\f
;;; FONT
;;;###autoload
(defun describe-font (fontname)
"Display information about fonts which partially match FONTNAME."
- (interactive "sFontname: ")
- (or window-system
- (error "No window system being used"))
+ (interactive "sFontname (default, current choice for ASCII chars): ")
+ (or (and window-system (boundp 'global-fontset-alist))
+ (error "No fontsets being used"))
+ (when (or (not fontname) (= (length fontname) 0))
+ (setq fontname (cdr (assq 'font (frame-parameters))))
+ (if (query-fontset fontname)
+ (setq fontname
+ (nth 2 (assq 'ascii (aref (fontset-info fontname) 2))))))
(let ((font-info (font-info fontname)))
(if (null font-info)
(message "No matching font")
(with-output-to-temp-buffer "*Help*"
(describe-font-internal font-info 'verbose)))))
-;; Print information in FONTINFO of a fontset named FONTSET.
-(defun describe-fontset-internal (fontset fontset-info)
- (print-list "Fontset:" fontset)
- (let ((size (aref fontset-info 0)))
- (print-list " size:" (format "%d" size)
- (if (= size 0) "... which means not yet used" "")))
- (print-list " height:" (format "%d" (aref fontset-info 1)))
- (print-list " fonts: (charset : font name)")
- (let* ((fonts (aref fontset-info 2))
- elt charset requested opened)
- (while fonts
- (setq elt (car fonts)
- charset (car elt)
- requested (nth 1 elt)
- opened (nth 2 elt))
- (print-list " " charset ":" requested)
- (if (stringp opened)
- (print-list " Opened as: " opened)
- (if (null opened) " -- open failed --"))
- (setq fonts (cdr fonts)))))
+;; Print information of FONTSET. If optional arg PRINT-FONTS is
+;; non-nil, print also names of all fonts in FONTSET. This function
+;; actually INSERT such information in the current buffer.
+(defun print-fontset (fontset &optional print-fonts)
+ (let* ((fontset-info (fontset-info fontset))
+ (size (aref fontset-info 0))
+ (height (aref fontset-info 1))
+ (fonts (and print-fonts (aref fontset-info 2)))
+ (xlfd-fields (x-decompose-font-name fontset))
+ style)
+ (if xlfd-fields
+ (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
+ (slant (aref xlfd-fields xlfd-regexp-slant-subnum)))
+ (if (string-match "^bold$\\|^demibold$" weight)
+ (setq style (concat weight " "))
+ (setq style "medium "))
+ (cond ((string-match "^i$" slant)
+ (setq style (concat style "italic")))
+ ((string-match "^o$" slant)
+ (setq style (concat style "slant")))
+ ((string-match "^ri$" slant)
+ (setq style (concat style "reverse italic")))
+ ((string-match "^ro$" slant)
+ (setq style (concat style "reverse slant")))))
+ (setq style " ? "))
+ (beginning-of-line)
+ (insert fontset)
+ (indent-to 58)
+ (insert (if (> size 0) (format "%2dx%d" size height) " -"))
+ (indent-to 64)
+ (insert style "\n")
+ (when print-fonts
+ (insert " O Charset / Fontname\n"
+ " - ------------------\n")
+ (sort-charset-list)
+ (let ((l charset-list)
+ charset font-info opened fontname)
+ (while l
+ (setq charset (car l) l (cdr l))
+ (setq font-info (assq charset fonts))
+ (if (null font-info)
+ (setq opened ?? fontname "not specified")
+ (if (nth 2 font-info)
+ (if (stringp (nth 2 font-info))
+ (setq opened ?o fontname (nth 2 font-info))
+ (setq opened ?- fontname (nth 1 font-info)))
+ (setq opened ?x fontname (nth 1 font-info))))
+ (insert (format " %c %s\n %s\n"
+ opened charset fontname)))))))
;;;###autoload
(defun describe-fontset (fontset)
- "Display information about FONTSET."
+ "Display information of FONTSET.
+This shows the name, size, and style of FONTSET, and the list of fonts
+contained in FONTSET.
+
+The column WDxHT contains width and height (pixels) of each fontset
+\(i.e. those of ASCII font in the fontset). The letter `-' in this
+column means that the corresponding fontset is not yet used in any
+frame.
+
+The O column for each font contains one of the following letters:
+ o -- font already opened
+ - -- font not yet opened
+ x -- font can't be opened
+ ? -- no font specified
+
+The Charset column for each font contains a name of character set
+displayed (for this fontset) using that font."
(interactive
- (if (not window-system)
- (error "No window system being used")
- (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list))))
- (list (completing-read "Fontset: " fontset-list)))))
- (setq fontset (query-fontset fontset))
- (if (null fontset)
- (error "No matching fontset")
- (let ((fontset-info (fontset-info fontset)))
- (with-output-to-temp-buffer "*Help*"
- (describe-fontset-internal fontset fontset-info)))))
+ (if (not (and window-system (boundp 'global-fontset-alist)))
+ (error "No fontsets being used")
+ (let ((fontset-list (mapcar '(lambda (x) (list x)) (fontset-list)))
+ (completion-ignore-case t))
+ (list (completing-read
+ "Fontset (default, used by the current frame): "
+ fontset-list nil t)))))
+ (if (= (length fontset) 0)
+ (setq fontset (cdr (assq 'font (frame-parameters)))))
+ (if (not (query-fontset fontset))
+ (error "Current frame is using font, not fontset"))
+ (let ((fontset-info (fontset-info fontset)))
+ (with-output-to-temp-buffer "*Help*"
+ (save-excursion
+ (set-buffer standard-output)
+ (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
+ (insert "------------\t\t\t\t\t\t ----- -----\n")
+ (print-fontset fontset t)))))
+;;;###autoload
+(defun list-fontsets (arg)
+ "Display a list of all fontsets.
+This shows the name, size, and style of each fontset.
+With prefix arg, it also list the fonts contained in each fontset;
+see the function `describe-fontset' for the format of the list."
+ (interactive "P")
+ (if (not (and window-system (boundp 'global-fontset-alist)))
+ (error "No fontsets being used")
+ (with-output-to-temp-buffer "*Help*"
+ (save-excursion
+ ;; This code is duplicated near the end of mule-diag.
+ (set-buffer standard-output)
+ (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
+ (insert "------------\t\t\t\t\t\t ----- -----\n")
+ (let ((fontsets (fontset-list)))
+ (while fontsets
+ (print-fontset (car fontsets) arg)
+ (setq fontsets (cdr fontsets))))))))
+\f
+;;;###autoload
+(defun list-input-methods ()
+ "Display information about all input methods."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (list-input-methods-1)))
+
+(defun list-input-methods-1 ()
+ (if (not input-method-alist)
+ (progn
+ (princ "
+No input method is available, perhaps because you have not yet
+installed LEIM (Libraries of Emacs Input Method).
+
+LEIM is available from the same ftp directory as Emacs. For instance,
+if there exists an archive file `emacs-20.N.tar.gz', there should also
+be a file `leim-20.N.tar.gz'. When you extract this file, LEIM files
+are put under the subdirectory `emacs-20.N/leim'. When you install
+Emacs again, you should be able to use various input methods."))
+ (princ "LANGUAGE\n NAME (`TITLE' in mode line)\n")
+ (princ " SHORT-DESCRIPTION\n------------------------------\n")
+ (setq input-method-alist
+ (sort input-method-alist
+ (function (lambda (x y) (string< (nth 1 x) (nth 1 y))))))
+ (let ((l input-method-alist)
+ language elt)
+ (while l
+ (setq elt (car l) l (cdr l))
+ (when (not (equal language (nth 1 elt)))
+ (setq language (nth 1 elt))
+ (princ language)
+ (terpri))
+ (princ (format " %s (`%s' in mode line)\n %s\n"
+ (car elt)
+ (let ((title (nth 3 elt)))
+ (if (and (consp title) (stringp (car title)))
+ (car title)
+ title))
+ (let ((description (nth 4 elt)))
+ (string-match ".*" description)
+ (match-string 0 description))))))))
\f
;;; DIAGNOSIS
-(defun insert-list (args)
- (while (cdr args)
- (insert (or (car args) "nil") " ")
- (setq args (cdr args)))
- (if args (insert (or (car args) "nil")))
- (insert "\n"))
-
-(defun insert-section (sec title)
+;; Insert a header of a section with SECTION-NUMBER and TITLE.
+(defun insert-section (section-number title)
(insert "########################################\n"
- "# Section " (format "%d" sec) ". " title "\n"
+ "# Section " (format "%d" section-number) ". " title "\n"
"########################################\n\n"))
;;;###autoload
(defun mule-diag ()
- "Show diagnosis of the running Mule."
+ "Display diagnosis of the multilingual environment (MULE).
+
+This shows various information related to the current multilingual
+environment, including lists of input methods, coding systems,
+character sets, and fontsets (if Emacs is running under a window
+system which uses fontsets)."
(interactive)
- (let ((buf (get-buffer-create "*Diagnosis*")))
+ (with-output-to-temp-buffer "*Mule-Diagnosis*"
(save-excursion
- (set-buffer buf)
- (erase-buffer)
- (insert "\t###############################\n"
- "\t### Diagnosis of your Emacs ###\n"
- "\t###############################\n\n"
+ (set-buffer standard-output)
+ (insert "###############################################\n"
+ "### Current Status of Multilingual Features ###\n"
+ "###############################################\n\n"
"CONTENTS: Section 1. General Information\n"
" Section 2. Display\n"
" Section 3. Input methods\n"
" Section 4. Coding systems\n"
- " Section 5. Charsets\n")
- (if window-system
- (insert " Section 6. Fontset list\n"))
+ " Section 5. Character sets\n")
+ (if (and window-system (boundp 'global-fontset-alist))
+ (insert " Section 6. Fontsets\n"))
(insert "\n")
(insert-section 1 "General Information")
- (insert "Version of this emacs:\n " (emacs-version) "\n"
- "Primary language:\n " primary-language "\n\n")
+ (insert "Version of this emacs:\n " (emacs-version) "\n\n")
(insert-section 2 "Display")
(if window-system
(insert "\n\n")
(insert-section 3 "Input methods")
- (insert "language\tinput-method\n"
- "--------\t------------\n")
- (let ((alist language-info-alist))
- (while alist
- (insert (car (car alist)))
- (indent-to 16)
- (let ((methods (get-language-info (car (car alist)) 'input-method)))
- (if methods
- (insert-list (mapcar 'car methods))
- (insert "none\n")))
- (setq alist (cdr alist))))
+ (list-input-methods-1)
(insert "\n")
(if default-input-method
- (insert "The input method used last time is: "
- (cdr default-input-method)
- "\n"
- " for inputting the language: "
- (car default-input-method)
- "\n")
- (insert "No input method has ever been selected.\n"))
-
- (insert "\n")
+ (insert "Default input method: " default-input-method "\n")
+ (insert "No default input method is specified\n"))
(insert-section 4 "Coding systems")
- (save-excursion (list-coding-systems))
- (insert-buffer "*Help*")
- (goto-char (point-max))
+ (list-coding-systems-1 t)
+ (princ "\
+############################
+## LIST OF CODING CATEGORIES (ordered by priority)
+## CATEGORY:CODING-SYSTEM
+##
+")
+ (let ((l coding-category-list))
+ (while l
+ (princ (format "%s:%s\n" (car l) (symbol-value (car l))))
+ (setq l (cdr l))))
(insert "\n")
- (insert-section 5 "Charsets")
- (save-excursion (list-character-sets))
- (insert-buffer "*Help*")
- (goto-char (point-max))
+ (insert-section 5 "Character sets")
+ (list-character-sets-1 t)
(insert "\n")
- (if window-system
- (let ((fontsets (fontset-list)))
- (insert-section 6 "Fontset list")
- (while fontsets
- (describe-fontset (car fontsets))
- (insert-buffer "*Help*")
- (setq fontsets (cdr fontsets)))))
-
- (set-buffer-modified-p nil)
- )
- (let ((win (display-buffer buf)))
- (set-window-point win 1)
- (set-window-start win 1))
- ))
+ (when (and window-system (boundp 'global-fontset-alist))
+ ;; This code duplicates most of list-fontsets.
+ (insert-section 6 "Fontsets")
+ (insert "Fontset-Name\t\t\t\t\t\t WDxHT Style\n")
+ (insert "------------\t\t\t\t\t\t ----- -----\n")
+ (let ((fontsets (fontset-list)))
+ (while fontsets
+ (print-fontset (car fontsets) t)
+ (setq fontsets (cdr fontsets)))))
+ (print-help-return-message))))
\f
;;; DUMP DATA FILE
;;;###autoload
(defun dump-charsets ()
- "Dump information of all charsets into the file \"charsets.dat\"."
- (list-character-sets)
- (set-buffer (get-buffer "*Help*"))
- (let (make-backup-files)
- (write-region (point-min) (point-max) "charsets.dat"))
- (kill-emacs))
+ "Dump information about all charsets into the file `CHARSETS'.
+The file is saved in the directory `data-directory'."
+ (let ((file (expand-file-name "CHARSETS" data-directory))
+ buf)
+ (or (file-writable-p file)
+ (error "Can't write to file %s" file))
+ (setq buf (find-file-noselect file))
+ (save-window-excursion
+ (save-excursion
+ (set-buffer buf)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (list-character-sets t)
+ (insert-buffer-substring "*Help*")
+ (let (make-backup-files
+ coding-system-for-write)
+ (save-buffer))))
+ (kill-buffer buf))
+ (if noninteractive
+ (kill-emacs)))
;;;###autoload
(defun dump-codings ()
- "Dump information of all coding systems into the file \"codings.dat\"."
- (list-coding-systems)
- (set-buffer (get-buffer "*Help*"))
- (let (make-backup-files)
- (write-region (point-min) (point-max) "codings.dat"))
- (kill-emacs))
-
+ "Dump information about all coding systems into the file `CODINGS'.
+The file is saved in the directory `data-directory'."
+ (let ((file (expand-file-name "CODINGS" data-directory))
+ buf)
+ (or (file-writable-p file)
+ (error "Can't write to file %s" file))
+ (setq buf (find-file-noselect file))
+ (save-window-excursion
+ (save-excursion
+ (set-buffer buf)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (list-coding-systems t)
+ (insert-buffer-substring "*Help*")
+ (list-coding-categories)
+ (insert-buffer-substring "*Help*")
+ (let (make-backup-files
+ coding-system-for-write)
+ (save-buffer))))
+ (kill-buffer buf))
+ (if noninteractive
+ (kill-emacs)))
+
+;;; mule-diag.el ends here