;;; mule-diag.el --- show diagnosis of multilingual environment (Mule)
;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
-;; Licensed to the Free Software Foundation.
+;; Licensed to the Free Software Foundation.
;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
-;; Copyright (C) 2001, 2002
+;; Copyright (C) 2003
;; National Institute of Advanced Industrial Science and Technology (AIST)
;; Registration Number H13PRO009
'help-function #'list-charset-chars
'help-echo "mouse-2, RET: show table of characters for this character set")
-
;;;###autoload
(defun list-character-sets (arg)
"Display a list of all character sets.
but still shows the full information."
(interactive "P")
(help-setup-xref (list #'list-character-sets arg) (interactive-p))
- (with-output-to-temp-buffer (help-buffer)
+ (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 "
(goto-char (point-min))
(re-search-forward "[0-9][0-9][0-9]")
(beginning-of-line)
- (delete-region (point) (point-max))
- (list-character-sets-1 sort-key)))))
+ (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 list-character-sets-1 (sort-key)
"Insert a list of character sets sorted by SORT-KEY.
'help-args (list (car elt)))
(goto-char (point-max))
(insert "\t")
- ;; (indent-to 40)
- ;; (insert (nth 2 elt)) ; MULTIBYTE-FORM
(indent-to 48)
(insert (format "%d %3d " (nth 1 elt) (nth 2 elt)) ; DIMENSION and CHARS
(if (< (nth 3 elt) 0)
(if (> (length charset) 0)
(intern charset))))
+;; Vector of 16 space-only strings. Nth string has display property
+;; '(space :align-to COL) when COL is the column number to align the
+;; Nth character in a row. Used by `list-block-of-chars'.
+
+(defconst stretches-for-character-list
+ (let ((stretches (make-vector 16 nil)))
+ (dotimes (i 16)
+ (aset stretches i
+ (propertize " " 'display `(space :align-to ,(+ 6 (* i 4))))))
+ stretches)
+ "For internal use only.")
;; 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 ")
+ (insert-char ?- (+ 5 (* 4 16)))
+ (insert "\n ")
(setq i 0)
(while (< i 16)
- (insert (format "%3X" i))
+ (insert (format "%4X" 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)
- (or (decode-char charset (+ (* row 256) i))
- 32)) ; gap in mapping
- ((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)
+ (insert (format "\n%4Xx" (/ (+ (* row 256) i) 16))))
+ (setq ch (if (< i min)
+ 32
+ (or (decode-char charset (+ (* row 256) i))
+ 32))) ; gap in mapping
+ ;; Don't insert a control code.
+ (if (or (< ch 32) (= ch 127))
+ (setq ch (single-key-description ch))
+ (if (and (>= ch 128) (< ch 160))
+ (setq ch (format "%02Xh" ch))))
+ (insert (aref stretches-for-character-list (% i 16)) ch)
(setq i (1+ i))))
(insert "\n"))
(defun list-charset-chars (charset)
"Display a list of characters in character set CHARSET."
(interactive (list (read-charset "Character set: ")))
- (with-output-to-temp-buffer "*Help*"
+ (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)
(unless (charsetp charset)
(if (nth 2 elt)
(insert (funcall (nth 2 elt) val)))
(insert ?\n)))))))
-
-;;;###autoload
-(defun describe-char-after (&optional pos)
- "Display information about the character at POS in the current buffer.
-POS defaults to point.
-The information includes character code, charset and code points in it,
-syntax, category, how the character is encoded in a file,
-which font is being used for displaying the character."
- (interactive)
- (or pos
- (setq pos (point)))
- (if (>= pos (point-max))
- (error "No character at point"))
- (let* ((char (char-after pos))
- (charset (char-charset char))
- (props (text-properties-at pos))
- (composition (find-composition (point) nil nil t))
- (composed (if composition (buffer-substring (car composition)
- (nth 1 composition))))
- (multibyte-p enable-multibyte-characters)
- item-list max-width)
- (if (not (characterp char))
- (setq item-list
- `(("character"
- ,(format "%s (0%o, %d, 0x%x) -- invalid character code"
- (char-to-string char) char char char))))
- (setq item-list
- `(("character"
- ,(format "%s (0%o, %d, 0x%x%s)"
- (if (< char 256)
- (single-key-description char)
- (char-to-string char))
- char char char
- (if (encode-char char 'ucs)
- (format ", U+%04X" (encode-char char 'ucs))
- "")))
- ("preferred charset"
- ,(symbol-name charset)
- ,(format "(%s)" (charset-description charset)))
- ("code point"
- ,(let ((split (split-char char)))
- (mapconcat #'number-to-string (cdr split) " ")))
- ("syntax"
- ,(let* ((old-table (syntax-table))
- (table (get-char-property (point) 'syntax-table)))
- (if (consp table)
- (nth 1 (assq (car table)
- (mapcar #'cdr syntax-code-table)))
- (unwind-protect
- (progn
- (if (syntax-table-p table)
- (set-syntax-table table))
- (nth 2 (assq (char-syntax char) syntax-code-table)))
- (set-syntax-table old-table)))))
- ("category"
- ,@(let ((category-set (char-category-set char)))
- (if (not category-set)
- '("-- none --")
- (mapcar #'(lambda (x) (format "%c:%s "
- x (category-docstring x)))
- (category-set-mnemonics category-set)))))
- ,@(let ((props (aref char-code-property-table char))
- ps)
- (when props
- (while props
- (push (format "%s:" (pop props)) ps)
- (push (format "%s;" (pop props)) ps))
- (list (cons "Properties" (nreverse ps)))))
- ("buffer code"
- ,(encoded-string-description
- (string-as-unibyte (char-to-string char)) nil))
- ("file code"
- ,@(let* ((coding buffer-file-coding-system)
- (encoded (encode-coding-char char coding)))
- (if encoded
- (list (encoded-string-description encoded coding)
- (format "(encoded by coding system %S)" coding))
- (list "not encodable by coding system"
- (symbol-name coding)))))
- ,(if (display-graphic-p (selected-frame))
- (list "font" (or (internal-char-font (point))
- "-- none --"))
- (list "terminal code"
- (let* ((coding (terminal-coding-system))
- (encoded (encode-coding-char char coding)))
- (if encoded
- (encoded-string-description encoded coding)
- "not encodable"))))
- ,@(let ((unicodedata (if (encode-char char 'ucs)
- (unicode-data char))))
- (if unicodedata
- (cons (list "Unicode data" " ") unicodedata))))))
- (setq max-width (apply #'max (mapcar #'(lambda (x)
- (if (cadr x)
- (length (car x))
- 0))
- item-list)))
- (with-output-to-temp-buffer "*Help*"
- (save-excursion
- (set-buffer standard-output)
- (set-buffer-multibyte multibyte-p)
- (let ((formatter (format "%%%ds:" max-width)))
- (dolist (elt item-list)
- (when (cadr elt)
- (insert (format formatter (car elt)))
- (dolist (clm (cdr elt))
- (when (>= (+ (current-column)
- (or (string-match "\n" clm)
- (string-width clm)) 1)
- (frame-width))
- (insert "\n")
- (indent-to (1+ max-width)))
- (insert " " clm))
- (insert "\n"))))
- (when composition
- (insert "\nComposed with the following character(s) "
- (mapconcat (lambda (x) (format "`%c'" x))
- (substring composed 1)
- ", ")
- " to form `" composed "'")
- (if (nth 3 composition)
- (insert ".\n")
- (insert "\nby the rule ("
- (mapconcat (lambda (x)
- (format (if (consp x) "%S" "?%c") x))
- (nth 2 composition)
- " ")
- ").\n"
- "See the variable `reference-point-alist' for "
- "the meaning of the rule.\n")))
- (if props
- (insert "\nText properties\n"))
- (while props
- (insert (format " %s: %s" (car props) (cadr props)))
- (setq props (cddr props)))
- ))))
-
\f
;;; CODING-SYSTEM
(interactive-p))
(with-output-to-temp-buffer (help-buffer)
(print-coding-system-briefly coding-system 'doc-string)
- (let* ((type (coding-system-type coding-system))
- ;; Fixme: use this
- (extra-spec (coding-system-plist coding-system)))
+ (let ((type (coding-system-type coding-system))
+ ;; Fixme: use this
+ (extra-spec (coding-system-plist coding-system)))
(princ "Type: ")
(princ type)
(cond ((eq type 'undecided)
)))
(defun print-coding-system-briefly (coding-system &optional doc-string)
- "Print symbol name and mnemonic letter of CODING-SYSTEM with `princ'."
+ "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."
(if (not coding-system)
(princ "nil\n")
(princ (format "%c -- %s"
(coding-system-mnemonic coding-system)
coding-system))
(let ((aliases (coding-system-aliases coding-system)))
- (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\n")
- (if (and doc-string
- (setq doc-string (coding-system-doc-string coding-system)))
- (princ (format "%s\n" doc-string)))))
+ (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 ()
(while categories
(setq coding-system (symbol-value (car categories)))
(mapcar
- (function
- (lambda (x)
- (if (and (not (eq x coding-system))
+ (lambda (x)
+ (if (and (not (eq x coding-system))
(let ((flags (coding-system-get :flags)))
(not (or (memq 'use-roman flags)
(memq 'use-oldjis flags)))))
- (setq codings (cons x codings)))))
+ (setq codings (cons x codings))))
(get (car categories) 'coding-systems))
(if codings
(let ((max-col (frame-width))
###############################################
# List of coding systems in the following format:
# MNEMONIC-LETTER -- CODING-SYSTEM-NAME
-# DOC-STRING
+# DOC-STRING
")
(princ "\
#########################
## POST-READ-CONVERSION, PRE-WRITE-CONVERSION = function name to be called
##
"))
- (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)))))
+ (dolist (coding-system (sort-coding-systems (coding-system-list 'base-only)))
+ (if (null arg)
+ (print-coding-system-briefly coding-system 'tightly)
+ (print-coding-system coding-system))))
;; Fixme: delete?
;;;###autoload
(defun print-fontset (fontset &optional print-opened)
"Print information about FONTSET.
+If FONTSET is nil, print information about the default fontset.
If optional arg PRINT-OPENED is non-nil, also print names of all opened
fonts for FONTSET. This function actually inserts the information in
the current buffer."
+ (or fontset
+ (setq fontset (query-fontset "fontset-default")))
(beginning-of-line)
(insert "Fontset: " fontset "\n")
(insert (propertize "CHAR RANGE" 'face 'underline)
(if (not (and window-system (fboundp 'fontset-list)))
(error "No fontsets being used")
(let ((fontset-list (nconc
- (mapcar 'list (fontset-list))
- (mapcar (lambda (x) (list (cdr x)))
- fontset-alias-alist)))
+ (fontset-list)
+ (mapcar 'cdr fontset-alias-alist)))
(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 (setq fontset (query-fontset fontset)))
- (error "Current frame is using font, not fontset"))
+ (setq fontset (frame-parameter nil 'font)))
+ (setq fontset (query-fontset fontset))
(help-setup-xref (list #'describe-fontset fontset) (interactive-p))
(with-output-to-temp-buffer (help-buffer)
(with-current-buffer standard-output
;; This code is duplicated near the end of mule-diag.
(let ((fontsets
(sort (fontset-list)
- (function (lambda (x y)
- (string< (fontset-plain-name x)
- (fontset-plain-name y)))))))
+ (lambda (x y)
+ (string< (fontset-plain-name x)
+ (fontset-plain-name y))))))
(while fontsets
(if arg
(print-fontset (car fontsets) nil)
(defun list-input-methods ()
"Display information about all input methods."
(interactive)
- (with-output-to-temp-buffer "*Help*"
+ (help-setup-xref '(list-input-methods) (interactive-p))
+ (with-output-to-temp-buffer (help-buffer)
(list-input-methods-1)
(with-current-buffer standard-output
(save-excursion
"^ \\([^ ]+\\) (`.*' in mode line)$" nil t)
(help-xref-button 1 #'help-input-method
(match-string 1)
- "mouse-2: describe this method")))
- (help-setup-xref '(list-input-methods) (interactive-p)))))
+ "mouse-2: describe this method"))))))
(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 Methods).
-
-LEIM is available from the same ftp directory as Emacs. For instance,
-if there exists an archive file `emacs-M.N.tar.gz', there should also
-be a file `leim-M.N.tar.gz'. When you extract this file, LEIM files
-are put under the subdirectory `emacs-M.N/leim'. When you install
-Emacs again, you should be able to use various input methods."))
+No input method is available, perhaps because you have not
+installed LEIM (Libraries of Emacs 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))))))
+ (lambda (x y) (string< (nth 1 x) (nth 1 y)))))
(let ((l input-method-alist)
language elt)
(while l
(setq fontsets (cdr fontsets)))))
(print-help-return-message))))
+;;;###autoload
(defcustom unicodedata-file nil
"Location of UnicodeData file.
This is the UnicodeData.txt file from the Unicode consortium, used for
;; space-efficient by splitting strings word-wise and replacing them
;; with lists of symbols interned in a private obarray, e.g.
;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
+
+;;;###autoload
(defun unicode-data (char)
"Return a list of Unicode data for unicode CHAR.
Each element is a list of a property description and the property value.
(string (string-to-number
(nth 13 fields) 16)))))))))))
+(provide 'mule-diag)
+
;; Local Variables:
;; coding: utf-8
;; End: