(describe-property-list): Sync to HEAD.

1 files changed, 127 insertions, 41 deletions

diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 47e18751c95..8ed2a2824bf 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -1,6 +1,6 @@
 ;;; descr-text.el --- describe text mode
 
-;; Copyright (c) 1994, 1995, 1996, 2001, 02, 03 Free Software Foundation, Inc.
+;; Copyright (c) 1994, 95, 96, 2001, 02, 03, 04 Free Software Foundation, Inc.
 
 ;; Author: Boris Goldowsky <boris@gnu.org>
 ;; Keywords: faces
@@ -99,8 +99,9 @@ if that value is non-nil."
 (defun describe-property-list (properties)
   "Insert a description of PROPERTIES in the current buffer.
 PROPERTIES should be a list of overlay or text properties.
-The `category' property is made into a widget button that call
-`describe-text-category' when pushed."
+The `category', `face' and `font-lock-face' properties are made
+into widget buttons that call `describe-text-category' or
+`describe-face' when pushed."
   ;; Sort the properties by the size of their value.
   (dolist (elt (sort (let ((ret nil)
 			   (key nil)
@@ -110,7 +111,7 @@ The `category' property is made into a widget button that call
 			 (setq key (pop properties)
 			       val (pop properties)
 			       len 0)
-			 (unless (or (eq key 'category)
+			 (unless (or (memq key '(category face font-lock-face))
 				     (widgetp val))
 			   (setq val (pp-to-string val)
 				 len (length val)))
@@ -128,6 +129,11 @@ The `category' property is made into a widget button that call
 			    :notify `(lambda (&rest ignore)
 				       (describe-text-category ',value))
 			    (format "%S" value)))
+            ((memq key '(face font-lock-face))
+	     (widget-create 'link
+			    :notify `(lambda (&rest ignore)
+				       (describe-face ',value))
+			    (format "%S" value)))
 	    ((widgetp value)
 	     (describe-text-widget value))
 	    (t
@@ -338,7 +344,7 @@ otherwise."
 ;;; 			   (string-to-number (nth 2 fields))
 ;;; 			   '((0 . "Spacing")
 ;;; 			     (1 . "Overlays and interior")
-;;; 			     (7 . "Nuktas") 
+;;; 			     (7 . "Nuktas")
 ;;; 			     (8 . "Hiragana/Katakana voicing marks")
 ;;; 			     (9 . "Viramas")
 ;;; 			     (10 . "Start of fixed position classes")
@@ -434,6 +440,19 @@ otherwise."
 ;;; 						   (string-to-number
 ;;; 						    (nth 13 fields) 16))
 ;;; 						  ??)))))))))))
+
+;; 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.
+(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)))
+      (if encoded
+	  (encoded-string-description encoded coding)))))
+
 
 ;;;###autoload
 (defun describe-char (pos)
@@ -449,8 +468,11 @@ as well as widgets, buttons, overlays, and text properties."
 	 (charset (get-char-property pos 'charset))
 	 (buffer (current-buffer))
 	 (composition (find-composition pos nil nil t))
-	 (composed (if composition (buffer-substring (car composition)
-						     (nth 1 composition))))
+	 (component-chars nil)
+	 (display-table (or (window-display-table)
+			    buffer-display-table
+			    standard-display-table))
+	 (disp-vector (and display-table (aref display-table char)))
 	 (multibyte-p enable-multibyte-characters)
 	 code item-list max-width)
     (or (and (charsetp charset) (encode-char char charset))
@@ -504,15 +526,46 @@ as well as widgets, buttons, overlays, and text properties."
 			     (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 pos)
-				    "-- none --"))
-		 (list "terminal code"
-		       (let* ((coding (terminal-coding-system))
-			      (encoded (encode-coding-char char coding)))
-			 (if encoded
-			     (encoded-string-description encoded coding)
-			   "not encodable"))))
+	      ("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 char))))
+		  (format "by display table entry [%s] (see below)"
+			  (mapconcat #'(lambda (x) (format "?%c" (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))))
+		 (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 (0x%02X)"
+				     (car display) (cdr display)))
+			  "no font available")
+		      (if display
+			  (format "terminal code %s" display)
+			"not encodable for terminal"))))))
 	      ,@(let ((unicodedata (unicode-data char)))
 		  (if unicodedata
 		      (cons (list "Unicode data" " ") unicodedata))))))
@@ -534,36 +587,68 @@ as well as widgets, buttons, overlays, and text properties."
 		(when (>= (+ (current-column)
 			     (or (string-match "\n" clm)
 				 (string-width clm)) 1)
-			  (frame-width))
+			  (window-width))
 		  (insert "\n")
 		  (indent-to (1+ max-width)))
 		(insert " " clm))
 	      (insert "\n"))))
+
+	(when disp-vector
+	  (insert
+	   "\nThe display table entry is displayed by ")
+	  (if (display-graphic-p (selected-frame))
+	      (progn
+		(insert "these fonts (glyph codes):\n")
+		(dotimes (i (length disp-vector))
+		  (insert (car (aref disp-vector i)) ?:
+			  (propertize " " 'display '(space :align-to 5))
+			  (if (cdr (aref disp-vector i))
+			      (format "%s (0x%02X)" (cadr (aref disp-vector i))
+				      (cddr (aref disp-vector i)))
+			    "-- no font --")
+			  "\n ")))
+	    (insert "these terminal codes:\n")
+	    (dotimes (i (length disp-vector))
+	      (insert (car (aref disp-vector i))
+		      (propertize " " 'display '(space :align-to 5))
+		      (or (cdr (aref disp-vector i)) "-- not encodable --")
+		      "\n"))))
+
 	(when composition
-	  (insert "\nComposed with the "
-		  (cond
-		   ((eq pos (car composition)) "following ")
-		   ((eq (1+ pos) (cadr composition)) "preceding ")
-		   (t ""))
-		  "character(s) `"
-		  (cond
-		   ((eq pos (car composition)) (substring composed 1))
-		   ((eq (1+ pos) (cadr composition)) (substring composed 0 -1))
-		   (t (concat (substring composed 0 (- pos (car composition)))
-			      "' and `"
-			      (substring composed (- (1+ pos) (car composition))))))
-
-		  "' 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")))
+	  (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 (0x%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"))
 
 	(let ((output (current-buffer)))
 	  (with-current-buffer buffer
@@ -575,4 +660,5 @@ as well as widgets, buttons, overlays, and text properties."
 
 (provide 'descr-text)
 
+;;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1
 ;;; descr-text.el ends here