X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a457417ee5ba797ab1c91d35ee957bb7a7f8d4b6..baf0cb84bf02779e1fda3e34999fef5a5a8f3bab:/lisp/descr-text.el

diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 3452874f34..b559a1391f 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -1,7 +1,7 @@
 ;;; descr-text.el --- describe text mode
 
 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
 
 ;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Maintainer: FSF
@@ -9,10 +9,10 @@
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
@@ -20,9 +20,7 @@
 ;; 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.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 
 ;;; Commentary:
 
@@ -51,19 +49,17 @@
   (let ((pp (condition-case signal
 		(pp-to-string sexp)
 	      (error (prin1-to-string signal)))))
-    (when (string-match "\n\\'" pp)
+    (when (string-match-p "\n\\'" pp)
       (setq pp (substring pp 0 (1- (length pp)))))
-    (if (cond ((string-match "\n" pp)
-	       nil)
-	      ((> (length pp) (- (window-width) (current-column)))
-	       nil)
-	      (t t))
+
+    (if (and (not (string-match-p "\n" pp))
+    	     (<= (length pp) (- (window-width) (current-column))))
 	(insert pp)
       (insert-text-button
        "[Show]" 'action `(lambda (&rest ignore)
-			(with-output-to-temp-buffer
-			    "*Pp Eval Output*"
-			  (princ ',pp)))
+			   (with-output-to-temp-buffer
+			       "*Pp Eval Output*"
+			     (princ ',pp)))
        'help-echo "mouse-2, RET: pretty print value in another buffer"))))
 
 (defun describe-property-list (properties)
@@ -88,6 +84,7 @@ into help buttons that call `describe-text-category' or
 	      (symbol-name value)
 	      'action `(lambda (&rest ignore)
 			 (describe-text-category ',value))
+	      'follow-link t
 	      'help-echo "mouse-2, RET: describe this category"))
             ((memq key '(face font-lock-face mouse-face))
 	     (insert-text-button
@@ -183,6 +180,29 @@ otherwise."
 	(insert "There are text properties here:\n")
 	(describe-property-list properties)))))
 
+(defcustom describe-char-unidata-list
+  '(name old-name general-category decomposition)
+  "List of Unicode-based character property names shown by `describe-char'."
+  :group 'mule
+  :version "23.1"
+  :type '(choice (const :tag "All properties" t)
+          (set
+           (const :tag "Unicode Name" name)
+           (const :tag "Unicode old name" old-name)
+           (const :tag "Unicode general category " general-category)
+           (const :tag "Unicode canonical combining class"
+                  canonical-combining-class)
+           (const :tag "Unicode bidi class" bidi-class)
+           (const :tag "Unicode decomposition mapping" decomposition)
+           (const :tag "Unicode decimal digit value" decimal-digit-value)
+           (const :tag "Unicode digit value" digit-value)
+           (const :tag "Unicode numeric value" numeric-value)
+           (const :tag "Unicode mirrored" mirrored)
+           (const :tag "Unicode ISO 10646 comment" iso-10646-comment)
+           (const :tag "Unicode simple uppercase mapping" uppercase)
+           (const :tag "Unicode simple lowercase mapping" lowercase)
+           (const :tag "Unicode simple titlecase mapping" titlecase))))
+
 (defcustom describe-char-unicodedata-file nil
   "Location of Unicode data file.
 This is the UnicodeData.txt file from the Unicode Consortium, used for
@@ -198,17 +218,11 @@ At the time of writing it is at the URL
   :type '(choice (const :tag "None" nil)
 		 file))
 
-;; We could convert the unidata file into a Lispy form once-for-all
-;; and distribute it for loading on demand.  It might be made more
-;; 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).
-
-;; Fixme: Check whether this needs updating for Unicode 4.
 (defun describe-char-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.
-The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
+The list is null if CHAR isn't found in `describe-char-unicodedata-file'.
+This function is semi-obsolete.  Use `get-char-code-property'."
   (when describe-char-unicodedata-file
     (unless (file-exists-p describe-char-unicodedata-file)
       (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
@@ -257,91 +271,20 @@ The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
 				  (concat (match-string 1 name) ">")
 				name)))
 	       (list "Category"
-		     (cdr (assoc
-			   (nth 1 fields)
-			   '(("Lu" . "uppercase letter")
-			     ("Ll" . "lowercase letter")
-			     ("Lt" . "titlecase letter")
-			     ("Mn" . "non-spacing mark")
-			     ("Mc" . "spacing-combining mark")
-			     ("Me" . "enclosing mark")
-			     ("Nd" . "decimal digit")
-			     ("Nl" . "letter number")
-			     ("No" . "other number")
-			     ("Zs" . "space separator")
-			     ("Zl" . "line separator")
-			     ("Zp" . "paragraph separator")
-			     ("Cc" . "other control")
-			     ("Cf" . "other format")
-			     ("Cs" . "surrogate")
-			     ("Co" . "private use")
-			     ("Cn" . "not assigned")
-			     ("Lm" . "modifier letter")
-			     ("Lo" . "other letter")
-			     ("Pc" . "connector punctuation")
-			     ("Pd" . "dash punctuation")
-			     ("Ps" . "open punctuation")
-			     ("Pe" . "close punctuation")
-			     ("Pi" . "initial-quotation punctuation")
-			     ("Pf" . "final-quotation punctuation")
-			     ("Po" . "other punctuation")
-			     ("Sm" . "math symbol")
-			     ("Sc" . "currency symbol")
-			     ("Sk" . "modifier symbol")
-			     ("So" . "other symbol")))))
+		     (let ((val (nth 1 fields)))
+		       (or (char-code-property-description
+			    'general-category (intern val))
+			   val)))
 	       (list "Combining class"
-		     (cdr (assoc
-			   (string-to-number (nth 2 fields))
-			   '((0 . "Spacing")
-			     (1 . "Overlays and interior")
-			     (7 . "Nuktas")
-			     (8 . "Hiragana/Katakana voicing marks")
-			     (9 . "Viramas")
-			     (10 . "Start of fixed position classes")
-			     (199 . "End of fixed position classes")
-			     (200 . "Below left attached")
-			     (202 . "Below attached")
-			     (204 . "Below right attached")
-			     (208 . "Left attached (reordrant around \
-single base character)")
-			     (210 . "Right attached")
-			     (212 . "Above left attached")
-			     (214 . "Above attached")
-			     (216 . "Above right attached")
-			     (218 . "Below left")
-			     (220 . "Below")
-			     (222 . "Below right")
-			     (224 . "Left (reordrant around single base \
-character)")
-			     (226 . "Right")
-			     (228 . "Above left")
-			     (230 . "Above")
-			     (232 . "Above right")
-			     (233 . "Double below")
-			     (234 . "Double above")
-			     (240 . "Below (iota subscript)")))))
+		     (let ((val (nth 1 fields)))
+		       (or (char-code-property-description
+			    'canonical-combining-class (intern val))
+			   val)))
 	       (list "Bidi category"
-		     (cdr (assoc
-			   (nth 3 fields)
-			   '(("L" . "Left-to-Right")
-			     ("LRE" . "Left-to-Right Embedding")
-			     ("LRO" . "Left-to-Right Override")
-			     ("R" . "Right-to-Left")
-			     ("AL" . "Right-to-Left Arabic")
-			     ("RLE" . "Right-to-Left Embedding")
-			     ("RLO" . "Right-to-Left Override")
-			     ("PDF" . "Pop Directional Format")
-			     ("EN" . "European Number")
-			     ("ES" . "European Number Separator")
-			     ("ET" . "European Number Terminator")
-			     ("AN" . "Arabic Number")
-			     ("CS" . "Common Number Separator")
-			     ("NSM" . "Non-Spacing Mark")
-			     ("BN" . "Boundary Neutral")
-			     ("B" . "Paragraph Separator")
-			     ("S" . "Segment Separator")
-			     ("WS" . "Whitespace")
-			     ("ON" . "Other Neutrals")))))
+		     (let ((val (nth 1 fields)))
+		       (or (char-code-property-description
+			    'bidi-class (intern val))
+			   val)))
 	       (list
 		"Decomposition"
 		(if (nth 4 fields)
@@ -351,14 +294,9 @@ character)")
 			  (setq info (match-string 1 info))
 			(setq info nil))
 		      (if info (setq parts (cdr parts)))
-		      ;; Maybe printing ? for unrepresentable unicodes
-		      ;; here and below should be changed?
 		      (setq parts (mapconcat
 				   (lambda (arg)
-				     (string (or (decode-char
-						  'ucs
-						  (string-to-number arg 16))
-						 ??)))
+				     (string (string-to-number arg 16)))
 				   parts " "))
 		      (concat info parts))))
 	       (list "Decimal digit value"
@@ -373,37 +311,64 @@ character)")
 	       (list "Old name" (nth 9 fields))
 	       (list "ISO 10646 comment" (nth 10 fields))
 	       (list "Uppercase" (and (nth 11 fields)
-				      (string (or (decode-char
-						   'ucs
-						   (string-to-number
-						    (nth 11 fields) 16))
-						  ??))))
+				      (string (string-to-number
+					       (nth 11 fields) 16))))
 	       (list "Lowercase" (and (nth 12 fields)
-				      (string (or (decode-char
-						   'ucs
-						   (string-to-number
-						    (nth 12 fields) 16))
-						  ??))))
+				      (string (string-to-number
+					       (nth 12 fields) 16))))
 	       (list "Titlecase" (and (nth 13 fields)
-				      (string (or (decode-char
-						   'ucs
-						   (string-to-number
-						    (nth 13 fields) 16))
-						  ??)))))))))))
+				      (string (string-to-number
+					       (nth 13 fields) 16)))))))))))
+
+;; Not defined on builds without X, but behind display-graphic-p.
+(declare-function internal-char-font "fontset.c" (position &optional ch))
 
 ;; Return information about how CHAR is displayed at the buffer
 ;; position POS.  If the selected frame is on a graphic display,
-;; return a cons (FONTNAME . GLYPH-CODE).  Otherwise, return a string
-;; describing the terminal codes for the character.
+;; return a string "FONT-DRIVER:FONT-NAME (GLYPH-CODE)" where:
+;;   FONT-DRIVER is the font-driver name,
+;;   FONT-NAME is the font name,
+;;   GLYPH-CODE is a hexadigit string representing the glyph-ID.
+;; Otherwise, return a string describing the terminal codes for the
+;; character.
 (defun describe-char-display (pos char)
   (if (display-graphic-p (selected-frame))
-      (internal-char-font pos char)
-    (let* ((coding (terminal-coding-system))
-	   (encoded (encode-coding-char char coding)))
+      (let ((char-font-info (internal-char-font pos char)))
+	(if char-font-info
+	    (let ((type (font-get (car char-font-info) :type))
+		  (name (font-xlfd-name (car char-font-info)))
+		  (code (cdr char-font-info)))
+	       (if (integerp code)
+		   (format "%s:%s (#x%02X)" type name code)
+		 (format "%s:%s (#x%04X%04X)"
+			 type name (car code) (cdr code))))))
+    (let* ((charset (get-text-property pos 'charset))
+	   (coding (or (terminal-coding-system) 'us-ascii))
+	   (encoded (encode-coding-char char coding charset)))
       (if encoded
 	  (encoded-string-description encoded coding)))))
 
 
+;; Return a string of CH with composition for padding on both sides.
+;; It is displayed without overlapping with the left/right columns.
+(defsubst describe-char-padded-string (ch)
+  (compose-string (string ch) 0 1 (format "\t%c\t" ch)))
+
+;; Return a nicely formated list of categories; extended category
+;; description is added to the category name as a tooltip
+(defsubst describe-char-categories (category-set)
+  (let ((mnemonics (category-set-mnemonics category-set)))
+    (unless (eq mnemonics "")
+      (list (mapconcat
+	     #'(lambda (x)
+		 (let* ((c (category-docstring x))
+			(doc (if (string-match "\\`\\(.*?\\)\n\\(.*\\)\\'" c)
+				 (propertize (match-string 1 c)
+					     'help-echo (match-string 2 c))
+			       c)))
+		   (format "%c:%s" x doc)))
+	     mnemonics ", ")))))
+
 ;;;###autoload
 (defun describe-char (pos)
   "Describe the character after POS (interactively, the character after point).
@@ -415,7 +380,9 @@ as well as widgets, buttons, overlays, and text properties."
   (if (>= pos (point-max))
       (error "No character follows specified position"))
   (let* ((char (char-after pos))
-	 (charset (char-charset char))
+	 (eight-bit-p (and (not enable-multibyte-characters) (>= char 128)))
+	 (charset (if eight-bit-p 'eight-bit
+		    (or (get-text-property pos 'charset) (char-charset char))))
 	 (composition (find-composition pos nil nil t))
 	 (component-chars nil)
 	 (display-table (or (window-display-table)
@@ -438,127 +405,180 @@ as well as widgets, buttons, overlays, and text properties."
 		  (describe-text-properties pos tmp-buf)
 		  (with-current-buffer tmp-buf (buffer-string)))
 	      (kill-buffer tmp-buf))))
-	 item-list max-width unicode)
+	 item-list max-width code)
+
+    (if multibyte-p
+	(or (setq code (encode-char char charset))
+	    (setq charset (char-charset char)
+		  code (encode-char char charset)))
+      (setq code char))
+    (when composition
+      ;; When the composition is trivial (i.e. composed only with the
+      ;; current character itself without any alternate characters),
+      ;; we don't show the composition information.  Otherwise, store
+      ;; two descriptive strings in the first two elments of
+      ;; COMPOSITION.
+      (or (catch 'tag
+	    (let ((from (car composition))
+		  (to (nth 1 composition))
+		  (next (1+ pos))
+		  (components (nth 2 composition))
+		  ch)
+	      (if (and (vectorp components) (vectorp (aref components 0)))
+		  (let ((idx (- pos from))
+			(nglyphs (lgstring-glyph-len components))
+			(i 0) j glyph glyph-from)
+		    ;; COMPONENTS is a gstring.  Find a grapheme
+		    ;; cluster containing the current character.
+		    (while (and (< i nglyphs)
+				(setq glyph (lgstring-glyph components i))
+				(< (lglyph-to glyph) idx))
+		      (setq i (1+ i)))
+		    (if (or (not glyph) (= i nglyphs))
+			;; The composition is broken.
+			(throw 'tag nil))
+		    (setq glyph-from (lglyph-from glyph)
+			  to (+ from (lglyph-to glyph) 1)
+			  from (+ from glyph-from)
+			  j i)
+		    (while (and (< j nglyphs)
+				(setq glyph (lgstring-glyph components j))
+				(= (lglyph-from glyph) glyph-from))
+		      (setq j (1+ j)))
+		    (if (and (= i (1- j))
+			     (setq glyph (lgstring-glyph components i))
+			     (= char (lglyph-char glyph)))
+			;; The composition is trivial.
+			(throw 'tag nil))
+		    (nconc composition (list i (1- j))))
+		(dotimes (i (length components))
+		  (if (integerp (setq ch (aref components i)))
+		      (push (cons ch (describe-char-display pos ch))
+			    component-chars)))
+		(setq component-chars (nreverse component-chars)))
+	      (if (< from pos)
+		  (if (< (1+ pos) to)
+		      (setcar composition
+			      (concat
+			       " with the surrounding characters \""
+			       (mapconcat 'describe-char-padded-string
+					  (buffer-substring from pos) "")
+			       "\" and \""
+			       (mapconcat 'describe-char-padded-string
+					  (buffer-substring (1+ pos) to) "")
+			       "\""))
+		    (setcar composition
+			    (concat
+			     " with the preceding character(s) \""
+			     (mapconcat 'describe-char-padded-string
+					(buffer-substring from pos) "")
+			     "\"")))
+		(if (< (1+ pos) to)
+		    (setcar composition
+			    (concat
+			     " with the following character(s) \""
+			     (mapconcat 'describe-char-padded-string
+					(buffer-substring (1+ pos) to) "")
+			     "\""))
+		  (setcar composition nil)))
+	      (setcar (cdr composition)
+		      (format "composed to form \"%s\" (see below)"
+			      (buffer-substring from to)))))
+	  (setq composition nil)))
 
-    (if (or (< char 256)
-	    (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
-	    (get-char-property pos 'untranslated-utf-8))
-	(setq unicode (or (get-char-property pos 'untranslated-utf-8)
-			  (encode-char char 'ucs))))
     (setq item-list
 	  `(("character"
-	     ,(format "%s (%d, #o%o, #x%x%s)"
+	     ,(format "%s (%d, #o%o, #x%x)"
 		      (apply 'propertize char-description
 			     (text-properties-at pos))
-		      char char char
-		      (if unicode
-			  (format ", U+%04X" unicode)
-			"")))
-	    ("charset"
+		      char char char))
+	    ("preferred charset"
 	     ,`(insert-text-button
 		,(symbol-name charset)
 		'type 'help-character-set 'help-args '(,charset))
 	     ,(format "(%s)" (charset-description charset)))
 	    ("code point"
-	     ,(let ((split (split-char char)))
-		`(insert-text-button
-		  ,(if (= (charset-dimension charset) 1)
-		       (format "#x%02X" (nth 1 split))
-		     (format "#x%02X #x%02X" (nth 1 split)
-			     (nth 2 split)))
-		  'action (lambda (&rest ignore)
-			    (list-charset-chars ',charset)
-			    (with-selected-window
-				(get-buffer-window "*Character List*" 0)
-			      (goto-char (point-min))
-			      (forward-line 2) ;Skip the header.
-			      (let ((case-fold-search nil))
-				(search-forward ,(char-to-string char)
-						nil t))))
-		  'help-echo
-		  "mouse-2, RET: show this character in its character set")))
+	     ,(let ((str (if (integerp code)
+			     (format (if (< code 256) "0x%02X" "0x%04X") code)
+			   (format "0x%04X%04X" (car code) (cdr code)))))
+		(if (<= (charset-dimension charset) 2)
+		    `(insert-text-button
+		      ,str
+		      'action (lambda (&rest ignore)
+				(list-charset-chars ',charset)
+				(with-selected-window
+				    (get-buffer-window "*Character List*" 0)
+				  (goto-char (point-min))
+				  (forward-line 2) ;Skip the header.
+				  (let ((case-fold-search nil))
+				    (if (search-forward ,(char-to-string char)
+							nil t)
+					(goto-char (match-beginning 0))))))
+		      'follow-link t
+		      'help-echo
+		      "mouse-2, RET: show this character in its character set")
+		  str)))
 	    ("syntax"
 	     ,(let ((syntax (syntax-after pos)))
 		(with-temp-buffer
 		  (internal-describe-syntax-value syntax)
 		  (buffer-string))))
 	    ("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)))))
+	     ,@(if (not eight-bit-p)
+		   (let ((category-set (char-category-set char)))
+		     (if category-set
+			 (describe-char-categories category-set)
+		       '("-- none --")))))
 	    ("to input"
-	     ,@(let ((key-list (and (eq input-method-function
-					'quail-input-method)
-				    (quail-find-key char))))
-		 (if (consp key-list)
-		     (list "type"
-			   (mapconcat #'(lambda (x) (concat "\"" x "\""))
-				      key-list " or ")
-			   "with"
-			   `(insert-text-button
-			     ,current-input-method
-			     'type 'help-input-method
-			     'help-args '(,current-input-method))))))
+	     ,@(if (not eight-bit-p)
+		   (let ((key-list (and (eq input-method-function
+					    'quail-input-method)
+					(quail-find-key char))))
+		     (if (consp key-list)
+			 (list "type"
+			       (mapconcat #'(lambda (x) (concat "\"" x "\""))
+					  key-list " or ")
+			       "with"
+			       `(insert-text-button
+				 ,current-input-method
+				 'type 'help-input-method
+				 'help-args '(,current-input-method)))))))
 	    ("buffer code"
-	     ,(encoded-string-description
-	       (string-as-unibyte (char-to-string char)) nil))
+	     ,(if multibyte-p
+		  (encoded-string-description
+		   (string-as-unibyte (char-to-string char)) nil)
+		(format "#x%02X" char)))
 	    ("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 multibyte-p
+		   (let* ((coding buffer-file-coding-system)
+			  (encoded (encode-coding-char char coding charset)))
+		     (if encoded
+			 (list (encoded-string-description encoded coding)
+			       (format "(encoded by coding system %S)" coding))
+		       (list "not encodable by coding system"
+			     (symbol-name coding))))
+		 (list (format "#x%02X" char))))
 	    ("display"
 	     ,(cond
 	       (disp-vector
 		(setq disp-vector (copy-sequence disp-vector))
 		(dotimes (i (length disp-vector))
-		  (setq char (aref disp-vector i))
 		  (aset disp-vector i
-			(cons char (describe-char-display
-				    pos (glyph-char char)))))
+			(cons (aref disp-vector i)
+			      (describe-char-display
+			       pos (glyph-char (aref disp-vector i))))))
 		(format "by display table entry [%s] (see below)"
 			(mapconcat
 			 #'(lambda (x)
 			     (format "?%c" (glyph-char (car x))))
 			 disp-vector " ")))
 	       (composition
-		(let ((from (car composition))
-		      (to (nth 1 composition))
-		      (next (1+ pos))
-		      (components (nth 2 composition))
-		      ch)
-		  (setcar composition
-			  (and (< from pos) (buffer-substring from pos)))
-		  (setcar (cdr composition)
-			  (and (< next to) (buffer-substring next to)))
-		  (dotimes (i (length components))
-		    (if (integerp (setq ch (aref components i)))
-			(push (cons ch (describe-char-display pos ch))
-			      component-chars)))
-		  (setq component-chars (nreverse component-chars))
-		  (format "composed to form \"%s\" (see below)"
-			  (buffer-substring from to))))
+		(cadr composition))
 	       (t
 		(let ((display (describe-char-display pos char)))
 		  (if (display-graphic-p (selected-frame))
 		      (if display
-			  (concat
-			   "by this font (glyph code)\n"
-			   (format "     %s (#x%02X)"
-				   (car display) (cdr display)))
+			  (concat "by this font (glyph code)\n    " display)
 			"no font available")
 		    (if display
 			(format "terminal code %s" display)
@@ -568,11 +588,11 @@ as well as widgets, buttons, overlays, and text properties."
 			 (cond
 			  ((and show-trailing-whitespace
 				(save-excursion (goto-char pos)
-						(looking-at "[ \t]+$")))
+						(looking-at-p "[ \t]+$")))
 			   'trailing-whitespace)
-			  ((and nobreak-char-display unicode (eq unicode '#xa0))
+			  ((and nobreak-char-display char (eq char '#xa0))
 			   'nobreak-space)
-			  ((and nobreak-char-display unicode (eq unicode '#xad))
+			  ((and nobreak-char-display char (eq char '#xad))
 			   'escape-glyph)
 			  ((and (< char 32) (not (memq char '(9 10))))
 			   'escape-glyph)))))
@@ -580,10 +600,10 @@ as well as widgets, buttons, overlays, and text properties."
 				     `(insert-text-button
 				       ,(symbol-name face)
 				       'type 'help-face 'help-args '(,face))))))
-	    ,@(let ((unicodedata (and unicode
-				      (describe-char-unicode-data unicode))))
-		(if unicodedata
-		    (cons (list "Unicode data" " ") unicodedata)))))
+	    ,@(if (not eight-bit-p)
+		  (let ((unicodedata (describe-char-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)))
@@ -599,7 +619,7 @@ as well as widgets, buttons, overlays, and text properties."
 		(if (eq (car-safe clm) 'insert-text-button)
 		    (progn (insert " ") (eval clm))
 		  (when (>= (+ (current-column)
-			       (or (string-match "\n" clm)
+			       (or (string-match-p "\n" clm)
 				   (string-width clm))
 			       1)
 			    (window-width))
@@ -612,7 +632,7 @@ as well as widgets, buttons, overlays, and text properties."
 	  (save-excursion
 	    (goto-char (point-min))
 	    (re-search-forward "character:[ \t\n]+")
-	    (let* ((end (+ (point) (length char-description))))
+	    (let ((end (+ (point) (length char-description))))
 	      (mapc #'(lambda (props)
 			(let ((o (make-overlay (point) end)))
 			  (while props
@@ -629,10 +649,7 @@ as well as widgets, buttons, overlays, and text properties."
 		(dotimes (i (length disp-vector))
 		  (insert (glyph-char (car (aref disp-vector i))) ?:
 			  (propertize " " 'display '(space :align-to 5))
-			  (if (cdr (aref disp-vector i))
-			      (format "%s (#x%02X)" (cadr (aref disp-vector i))
-				      (cddr (aref disp-vector i)))
-			    "-- no font --")
+			  (or (cdr (aref disp-vector i)) "-- no font --")
 			  "\n")
 		  (let ((face (glyph-face (car (aref disp-vector i)))))
 		    (when face
@@ -650,45 +667,87 @@ as well as widgets, buttons, overlays, and text properties."
 	(when composition
 	  (insert "\nComposed")
 	  (if (car composition)
-	      (if (cadr composition)
-		  (insert " with the surrounding characters \""
-			  (car composition) "\" and \""
-			  (cadr composition) "\"")
-		(insert " with the preceding character(s) \""
-			(car composition) "\""))
-	    (if (cadr composition)
-		(insert " with the following character(s) \""
-			(cadr composition) "\"")))
-	  (insert " by the rule:\n\t("
-		  (mapconcat (lambda (x)
-			       (format (if (consp x) "%S" "?%c") x))
-			     (nth 2 composition)
-			     " ")
-		  ")")
-	  (insert  "\nThe component character(s) are displayed by ")
-	  (if (display-graphic-p (selected-frame))
-	      (progn
-		(insert "these fonts (glyph codes):")
-		(dolist (elt component-chars)
-		  (insert "\n " (car elt) ?:
-			  (propertize " " 'display '(space :align-to 5))
-			  (if (cdr elt)
-			      (format "%s (#x%02X)" (cadr elt) (cddr elt))
-			    "-- no font --"))))
-	    (insert "these terminal codes:")
-	    (dolist (elt component-chars)
-	      (insert "\n  " (car elt) ":"
-		      (propertize " " 'display '(space :align-to 5))
-		      (or (cdr elt) "-- not encodable --"))))
-	  (insert "\nSee the variable `reference-point-alist' for "
-		  "the meaning of the rule.\n"))
+	      (insert (car composition)))
+	  (if (and (vectorp (nth 2 composition))
+		   (vectorp (aref (nth 2 composition) 0)))
+	      (let* ((gstring (nth 2 composition))
+		     (font (lgstring-font gstring))
+		     (from (nth 3 composition))
+		     (to (nth 4 composition))
+		     glyph)
+		(if (fontp font)
+		    (progn
+		      (insert " using this font:\n  "
+			      (symbol-name (font-get font :type))
+			      ?:
+			      (aref (query-font font) 0)
+			      "\nby these glyphs:\n")
+		      (while (and (<= from to)
+				  (setq glyph (lgstring-glyph gstring from)))
+			(insert (format "  %S\n" glyph))
+			(setq from (1+ from))))
+		  (insert " by these characters:\n")
+		  (while (and (<= from to)
+			      (setq glyph (lgstring-glyph gstring from)))
+		    (insert (format " %c (#x%d)\n"
+				    (lglyph-char glyph) (lglyph-char glyph)))
+		    (setq from (1+ from)))))
+	    (insert " by the rule:\n\t(")
+	    (let ((first t))
+	      (mapc (lambda (x)
+		      (if first (setq first nil)
+			(insert " "))
+		      (if (consp x) (insert (format "%S" x))
+			(if (= x ?\t) (insert (single-key-description x))
+			  (insert ??)
+			  (insert (describe-char-padded-string x)))))
+		    (nth 2 composition)))
+	    (insert  ")\nThe component character(s) are displayed by ")
+	    (if (display-graphic-p (selected-frame))
+		(progn
+		  (insert "these fonts (glyph codes):")
+		  (dolist (elt component-chars)
+		    (if (/= (car elt) ?\t)
+			(insert "\n "
+				(describe-char-padded-string (car elt))
+				?:
+				(propertize " " 'display '(space :align-to 5))
+				(or (cdr elt) "-- no font --")))))
+	      (insert "these terminal codes:")
+	      (dolist (elt component-chars)
+		(insert "\n  " (car elt) ":"
+			(propertize " " 'display '(space :align-to 4))
+			(or (cdr elt) "-- not encodable --"))))
+	    (insert "\nSee the variable `reference-point-alist' for "
+		    "the meaning of the rule.\n")))
+
+	(unless eight-bit-p
+	  (insert (if (not describe-char-unidata-list)
+		      "\nCharacter code properties are not shown: "
+		    "\nCharacter code properties: "))
+	  (insert-text-button
+	   "customize what to show"
+	   'action (lambda (&rest ignore)
+		     (customize-variable
+		      'describe-char-unidata-list))
+	   'follow-link t)
+	  (insert "\n")
+	  (dolist (elt (if (eq describe-char-unidata-list t)
+			   (nreverse (mapcar 'car char-code-property-alist))
+			 describe-char-unidata-list))
+	    (let ((val (get-char-code-property char elt))
+		  description)
+	      (when val
+		(setq description (char-code-property-description elt val))
+		(insert (if description
+			    (format "  %s: %s (%s)\n" elt val description)
+			  (format "  %s: %s\n" elt val)))))))
 
         (if text-props-desc (insert text-props-desc))
 	(setq help-xref-stack-item (list 'help-insert-string (buffer-string)))
 	(toggle-read-only 1)))))
 
-(defalias 'describe-char-after 'describe-char)
-(make-obsolete 'describe-char-after 'describe-char "22.1")
+(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
 
 (provide 'descr-text)