lisp/descr-text.el

   1 ;;; descr-text.el --- describe text mode
   2
   3 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Boris Goldowsky <boris@gnu.org>
   7 ;; Keywords: faces, i18n, Unicode, multilingual
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Describe-Text Mode.
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'button) (require 'quail))
  33
  34 (defun describe-text-done ()
  35   "Delete the current window or bury the current buffer."
  36   (interactive)
  37   (if (> (count-windows) 1)
  38       (delete-window)
  39     (bury-buffer)))
  40
  41 (defvar describe-text-mode-map
  42   (let ((map (make-sparse-keymap)))
  43     (set-keymap-parent map widget-keymap)
  44     map)
  45   "Keymap for `describe-text-mode'.")
  46
  47 (defcustom describe-text-mode-hook nil
  48   "List of hook functions ran by `describe-text-mode'."
  49   :type 'hook
  50   :group 'facemenu)
  51
  52 (defun describe-text-mode ()
  53   "Major mode for buffers created by `describe-char'.
  54
  55 \\{describe-text-mode-map}
  56 Entry to this mode calls the value of `describe-text-mode-hook'
  57 if that value is non-nil."
  58   (kill-all-local-variables)
  59   (setq major-mode 'describe-text-mode
  60         mode-name "Describe-Text")
  61   (use-local-map describe-text-mode-map)
  62   (widget-setup)
  63   (add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
  64   (run-mode-hooks 'describe-text-mode-hook))
  65
  66 ;;; Describe-Text Utilities.
  67
  68 (defun describe-text-widget (widget)
  69   "Insert text to describe WIDGET in the current buffer."
  70   (widget-create 'link
  71                  :notify `(lambda (&rest ignore)
  72                             (widget-browse ',widget))
  73                  (format "%S" (if (symbolp widget)
  74                                   widget
  75                                 (car widget))))
  76   (widget-insert " ")
  77   (widget-create 'info-link :tag "widget" "(widget)Top"))
  78
  79 (defun describe-text-sexp (sexp)
  80   "Insert a short description of SEXP in the current buffer."
  81   (let ((pp (condition-case signal
  82                 (pp-to-string sexp)
  83               (error (prin1-to-string signal)))))
  84     (when (string-match "\n\\'" pp)
  85       (setq pp (substring pp 0 (1- (length pp)))))
  86     (if (cond ((string-match "\n" pp)
  87                nil)
  88               ((> (length pp) (- (window-width) (current-column)))
  89                nil)
  90               (t t))
  91         (widget-insert pp)
  92       (widget-create 'push-button
  93                      :tag "show"
  94                      :action (lambda (widget &optional event)
  95                                (with-output-to-temp-buffer
  96                                    "*Pp Eval Output*"
  97                                  (princ (widget-get widget :value))))
  98                      pp))))
  99
 100 (defun describe-property-list (properties)
 101   "Insert a description of PROPERTIES in the current buffer.
 102 PROPERTIES should be a list of overlay or text properties.
 103 The `category', `face' and `font-lock-face' properties are made
 104 into widget buttons that call `describe-text-category' or
 105 `describe-face' when pushed."
 106   ;; Sort the properties by the size of their value.
 107   (dolist (elt (sort (let (ret)
 108                        (while properties
 109                          (push (list (pop properties) (pop properties)) ret))
 110                        ret)
 111                      (lambda (a b) (string< (nth 0 a) (nth 0 b)))))
 112     (let ((key (nth 0 elt))
 113           (value (nth 1 elt)))
 114       (widget-insert (propertize (format "  %-20s " key)
 115                                  'font-lock-face 'italic))
 116       (cond ((eq key 'category)
 117              (widget-create 'link
 118                             :notify `(lambda (&rest ignore)
 119                                        (describe-text-category ',value))
 120                             (format "%S" value)))
 121             ((memq key '(face font-lock-face mouse-face))
 122              (widget-create 'link
 123                             :notify `(lambda (&rest ignore)
 124                                        (describe-face ',value))
 125                             (format "%S" value)))
 126             ((widgetp value)
 127              (describe-text-widget value))
 128             (t
 129              (describe-text-sexp value))))
 130     (widget-insert "\n")))
 131 \f
 132 ;;; Describe-Text Commands.
 133
 134 (defun describe-text-category (category)
 135   "Describe a text property category."
 136   (interactive "S")
 137   (save-excursion
 138     (with-output-to-temp-buffer "*Help*"
 139       (set-buffer standard-output)
 140       (widget-insert "Category " (format "%S" category) ":\n\n")
 141       (describe-property-list (symbol-plist category))
 142       (describe-text-mode)
 143       (goto-char (point-min)))))
 144
 145 ;;;###autoload
 146 (defun describe-text-properties (pos &optional output-buffer)
 147   "Describe widgets, buttons, overlays and text properties at POS.
 148 Interactively, describe them for the character after point.
 149 If optional second argument OUTPUT-BUFFER is non-nil,
 150 insert the output into that buffer, and don't initialize or clear it
 151 otherwise."
 152   (interactive "d")
 153   (if (>= pos (point-max))
 154       (error "No character follows specified position"))
 155   (if output-buffer
 156       (describe-text-properties-1 pos output-buffer)
 157     (if (not (or (text-properties-at pos) (overlays-at pos)))
 158         (message "This is plain text.")
 159       (let ((buffer (current-buffer))
 160             (target-buffer "*Help*"))
 161         (when (eq buffer (get-buffer target-buffer))
 162           (setq target-buffer "*Help-2*"))
 163         (save-excursion
 164           (with-output-to-temp-buffer target-buffer
 165             (set-buffer standard-output)
 166             (setq output-buffer (current-buffer))
 167             (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
 168             (with-current-buffer buffer
 169               (describe-text-properties-1 pos output-buffer))
 170             (describe-text-mode)
 171             (goto-char (point-min))))))))
 172
 173 (defun describe-text-properties-1 (pos output-buffer)
 174   (let* ((properties (text-properties-at pos))
 175          (overlays (overlays-at pos))
 176          (wid-field (get-char-property pos 'field))
 177          (wid-button (get-char-property pos 'button))
 178          (wid-doc (get-char-property pos 'widget-doc))
 179          ;; If button.el is not loaded, we have no buttons in the text.
 180          (button (and (fboundp 'button-at) (button-at pos)))
 181          (button-type (and button (button-type button)))
 182          (button-label (and button (button-label button)))
 183          (widget (or wid-field wid-button wid-doc)))
 184     (with-current-buffer output-buffer
 185       ;; Widgets
 186       (when (widgetp widget)
 187         (newline)
 188         (widget-insert (cond (wid-field "This is an editable text area")
 189                              (wid-button "This is an active area")
 190                              (wid-doc "This is documentation text")))
 191         (widget-insert " of a ")
 192         (describe-text-widget widget)
 193         (widget-insert ".\n\n"))
 194       ;; Buttons
 195       (when (and button (not (widgetp wid-button)))
 196         (newline)
 197         (widget-insert "Here is a " (format "%S" button-type)
 198                        " button labeled `" button-label "'.\n\n"))
 199       ;; Overlays
 200       (when overlays
 201         (newline)
 202         (if (eq (length overlays) 1)
 203             (widget-insert "There is an overlay here:\n")
 204           (widget-insert "There are " (format "%d" (length overlays))
 205                          " overlays here:\n"))
 206         (dolist (overlay overlays)
 207           (widget-insert " From " (format "%d" (overlay-start overlay))
 208                          " to " (format "%d" (overlay-end overlay)) "\n")
 209           (describe-property-list (overlay-properties overlay)))
 210         (widget-insert "\n"))
 211       ;; Text properties
 212       (when properties
 213         (newline)
 214         (widget-insert "There are text properties here:\n")
 215         (describe-property-list properties)))))
 216 \f
 217 (defcustom describe-char-unicodedata-file nil
 218   "Location of Unicode data file.
 219 This is the UnicodeData.txt file from the Unicode consortium, used for
 220 diagnostics.  If it is non-nil `describe-char' will print data
 221 looked up from it.  This facility is mostly of use to people doing
 222 multilingual development.
 223
 224 This is a fairly large file, not typically present on GNU systems.  At
 225 the time of writing it is at
 226 <URL:http://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
 227   :group 'mule
 228   :version "22.1"
 229   :type '(choice (const :tag "None" nil)
 230                  file))
 231
 232 ;; We could convert the unidata file into a Lispy form once-for-all
 233 ;; and distribute it for loading on demand.  It might be made more
 234 ;; space-efficient by splitting strings word-wise and replacing them
 235 ;; with lists of symbols interned in a private obarray, e.g.
 236 ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
 237
 238 ;; Fixme: Check whether this needs updating for Unicode 4.
 239 (defun describe-char-unicode-data (char)
 240   "Return a list of Unicode data for unicode CHAR.
 241 Each element is a list of a property description and the property value.
 242 The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
 243   (when describe-char-unicodedata-file
 244     (unless (file-exists-p describe-char-unicodedata-file)
 245       (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
 246     (with-current-buffer
 247         ;; Find file in fundamental mode to avoid, e.g. flyspell turned
 248         ;; on for .txt.  Don't use RAWFILE arg in case of DOS line endings.
 249         (let ((auto-mode-alist))
 250           (find-file-noselect describe-char-unicodedata-file))
 251       (goto-char (point-min))
 252       (let ((hex (format "%04X" char))
 253             found first last)
 254         (if (re-search-forward (concat "^" hex) nil t)
 255             (setq found t)
 256           ;; It's not listed explicitly.  Look for ranges, e.g. CJK
 257           ;; ideographs, and check whether it's in one of them.
 258           (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
 259                       (>= char (setq first
 260                                      (string-to-number (match-string 1) 16)))
 261                       (progn
 262                         (forward-line 1)
 263                         (looking-at "^\\([^;]+\\);[^;]+Last>;")
 264                         (> char
 265                            (setq last
 266                                  (string-to-number (match-string 1) 16))))))
 267           (if (and (>= char first)
 268                    (<= char last))
 269               (setq found t)))
 270         (if found
 271             (let ((fields (mapcar (lambda (elt)
 272                                     (if (> (length elt) 0)
 273                                         elt))
 274                                   (cdr (split-string
 275                                         (buffer-substring
 276                                          (line-beginning-position)
 277                                          (line-end-position))
 278                                         ";")))))
 279               ;; The length depends on whether the last field was empty.
 280               (unless (or (= 13 (length fields))
 281                           (= 14 (length fields)))
 282                 (error "Invalid contents in %s" describe-char-unicodedata-file))
 283               ;; The field names and values lists are slightly
 284               ;; modified from Mule-UCS unidata.el.
 285               (list
 286                (list "Name" (let ((name (nth 0 fields)))
 287                               ;; Check for <..., First>, <..., Last>
 288                               (if (string-match "\\`\\(<[^,]+\\)," name)
 289                                   (concat (match-string 1 name) ">")
 290                                 name)))
 291                (list "Category"
 292                      (cdr (assoc
 293                            (nth 1 fields)
 294                            '(("Lu" . "uppercase letter")
 295                              ("Ll" . "lowercase letter")
 296                              ("Lt" . "titlecase letter")
 297                              ("Mn" . "non-spacing mark")
 298                              ("Mc" . "spacing-combining mark")
 299                              ("Me" . "enclosing mark")
 300                              ("Nd" . "decimal digit")
 301                              ("Nl" . "letter number")
 302                              ("No" . "other number")
 303                              ("Zs" . "space separator")
 304                              ("Zl" . "line separator")
 305                              ("Zp" . "paragraph separator")
 306                              ("Cc" . "other control")
 307                              ("Cf" . "other format")
 308                              ("Cs" . "surrogate")
 309                              ("Co" . "private use")
 310                              ("Cn" . "not assigned")
 311                              ("Lm" . "modifier letter")
 312                              ("Lo" . "other letter")
 313                              ("Pc" . "connector punctuation")
 314                              ("Pd" . "dash punctuation")
 315                              ("Ps" . "open punctuation")
 316                              ("Pe" . "close punctuation")
 317                              ("Pi" . "initial-quotation punctuation")
 318                              ("Pf" . "final-quotation punctuation")
 319                              ("Po" . "other punctuation")
 320                              ("Sm" . "math symbol")
 321                              ("Sc" . "currency symbol")
 322                              ("Sk" . "modifier symbol")
 323                              ("So" . "other symbol")))))
 324                (list "Combining class"
 325                      (cdr (assoc
 326                            (string-to-number (nth 2 fields))
 327                            '((0 . "Spacing")
 328                              (1 . "Overlays and interior")
 329                              (7 . "Nuktas")
 330                              (8 . "Hiragana/Katakana voicing marks")
 331                              (9 . "Viramas")
 332                              (10 . "Start of fixed position classes")
 333                              (199 . "End of fixed position classes")
 334                              (200 . "Below left attached")
 335                              (202 . "Below attached")
 336                              (204 . "Below right attached")
 337                              (208 . "Left attached (reordrant around \
 338 single base character)")
 339                              (210 . "Right attached")
 340                              (212 . "Above left attached")
 341                              (214 . "Above attached")
 342                              (216 . "Above right attached")
 343                              (218 . "Below left")
 344                              (220 . "Below")
 345                              (222 . "Below right")
 346                              (224 . "Left (reordrant around single base \
 347 character)")
 348                              (226 . "Right")
 349                              (228 . "Above left")
 350                              (230 . "Above")
 351                              (232 . "Above right")
 352                              (233 . "Double below")
 353                              (234 . "Double above")
 354                              (240 . "Below (iota subscript)")))))
 355                (list "Bidi category"
 356                      (cdr (assoc
 357                            (nth 3 fields)
 358                            '(("L" . "Left-to-Right")
 359                              ("LRE" . "Left-to-Right Embedding")
 360                              ("LRO" . "Left-to-Right Override")
 361                              ("R" . "Right-to-Left")
 362                              ("AL" . "Right-to-Left Arabic")
 363                              ("RLE" . "Right-to-Left Embedding")
 364                              ("RLO" . "Right-to-Left Override")
 365                              ("PDF" . "Pop Directional Format")
 366                              ("EN" . "European Number")
 367                              ("ES" . "European Number Separator")
 368                              ("ET" . "European Number Terminator")
 369                              ("AN" . "Arabic Number")
 370                              ("CS" . "Common Number Separator")
 371                              ("NSM" . "Non-Spacing Mark")
 372                              ("BN" . "Boundary Neutral")
 373                              ("B" . "Paragraph Separator")
 374                              ("S" . "Segment Separator")
 375                              ("WS" . "Whitespace")
 376                              ("ON" . "Other Neutrals")))))
 377                (list
 378                 "Decomposition"
 379                 (if (nth 4 fields)
 380                     (let* ((parts (split-string (nth 4 fields)))
 381                            (info (car parts)))
 382                       (if (string-match "\\`<\\(.+\\)>\\'" info)
 383                           (setq info (match-string 1 info))
 384                         (setq info nil))
 385                       (if info (setq parts (cdr parts)))
 386                       ;; Maybe printing ? for unrepresentable unicodes
 387                       ;; here and below should be changed?
 388                       (setq parts (mapconcat
 389                                    (lambda (arg)
 390                                      (string (or (decode-char
 391                                                   'ucs
 392                                                   (string-to-number arg 16))
 393                                                  ??)))
 394                                    parts " "))
 395                       (concat info parts))))
 396                (list "Decimal digit value"
 397                      (nth 5 fields))
 398                (list "Digit value"
 399                      (nth 6 fields))
 400                (list "Numeric value"
 401                      (nth 7 fields))
 402                (list "Mirrored"
 403                      (if (equal "Y" (nth 8 fields))
 404                          "yes"))
 405                (list "Old name" (nth 9 fields))
 406                (list "ISO 10646 comment" (nth 10 fields))
 407                (list "Uppercase" (and (nth 11 fields)
 408                                       (string (or (decode-char
 409                                                    'ucs
 410                                                    (string-to-number
 411                                                     (nth 11 fields) 16))
 412                                                   ??))))
 413                (list "Lowercase" (and (nth 12 fields)
 414                                       (string (or (decode-char
 415                                                    'ucs
 416                                                    (string-to-number
 417                                                     (nth 12 fields) 16))
 418                                                   ??))))
 419                (list "Titlecase" (and (nth 13 fields)
 420                                       (string (or (decode-char
 421                                                    'ucs
 422                                                    (string-to-number
 423                                                     (nth 13 fields) 16))
 424                                                   ??)))))))))))
 425
 426 ;; Return information about how CHAR is displayed at the buffer
 427 ;; position POS.  If the selected frame is on a graphic display,
 428 ;; return a cons (FONTNAME . GLYPH-CODE).  Otherwise, return a string
 429 ;; describing the terminal codes for the character.
 430 (defun describe-char-display (pos char)
 431   (if (display-graphic-p (selected-frame))
 432       (internal-char-font pos char)
 433     (let* ((coding (terminal-coding-system))
 434            (encoded (encode-coding-char char coding)))
 435       (if encoded
 436           (encoded-string-description encoded coding)))))
 437
 438 \f
 439 ;;;###autoload
 440 (defun describe-char (pos)
 441   "Describe the character after POS (interactively, the character after point).
 442 The information includes character code, charset and code points in it,
 443 syntax, category, how the character is encoded in a file,
 444 character composition information (if relevant),
 445 as well as widgets, buttons, overlays, and text properties."
 446   (interactive "d")
 447   (if (>= pos (point-max))
 448       (error "No character follows specified position"))
 449   (let* ((char (char-after pos))
 450          (charset (char-charset char))
 451          (composition (find-composition pos nil nil t))
 452          (component-chars nil)
 453          (display-table (or (window-display-table)
 454                             buffer-display-table
 455                             standard-display-table))
 456          (disp-vector (and display-table (aref display-table char)))
 457          (multibyte-p enable-multibyte-characters)
 458          (overlays (mapcar #'(lambda (o) (overlay-properties o))
 459                            (overlays-at pos)))
 460          item-list max-width unicode)
 461
 462     (if (or (< char 256)
 463             (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
 464             (get-char-property pos 'untranslated-utf-8))
 465         (setq unicode (or (get-char-property pos 'untranslated-utf-8)
 466                           (encode-char char 'ucs))))
 467     (setq item-list
 468           `(("character"
 469             ,(format "%s (0%o, %d, 0x%x%s)"
 470                      (apply 'propertize (if (not multibyte-p)
 471                                             (single-key-description char)
 472                                           (if (< char 128)
 473                                               (single-key-description char)
 474                                             (string-to-multibyte
 475                                              (char-to-string char))))
 476                             (text-properties-at pos))
 477                      char char char
 478                      (if unicode
 479                          (format ", U+%04X" unicode)
 480                        "")))
 481             ("charset"
 482              ,`(widget-create 'link
 483                               :notify (lambda (&rest ignore)
 484                                         (describe-character-set ',charset))
 485                               ,(symbol-name charset))
 486              ,(format "(%s)" (charset-description charset)))
 487             ("code point"
 488              ,(let ((split (split-char char)))
 489                 `(widget-create
 490                   'link
 491                   :notify (lambda (&rest ignore)
 492                             (list-charset-chars ',charset)
 493                             (with-selected-window
 494                                 (get-buffer-window "*Character List*" 0)
 495                               (goto-char (point-min))
 496                               (forward-line 2) ;Skip the header.
 497                               (let ((case-fold-search nil))
 498                                 (search-forward ,(char-to-string char)
 499                                                 nil t))))
 500                   ,(if (= (charset-dimension charset) 1)
 501                        (format "%d" (nth 1 split))
 502                      (format "%d %d" (nth 1 split) (nth 2 split))))))
 503             ("syntax"
 504              ,(let ((syntax (syntax-after pos)))
 505                 (with-temp-buffer
 506                   (internal-describe-syntax-value syntax)
 507                   (buffer-string))))
 508             ("category"
 509              ,@(let ((category-set (char-category-set char)))
 510                  (if (not category-set)
 511                      '("-- none --")
 512                    (mapcar #'(lambda (x) (format "%c:%s  "
 513                                                  x (category-docstring x)))
 514                            (category-set-mnemonics category-set)))))
 515             ,@(let ((props (aref char-code-property-table char))
 516                     ps)
 517                 (when props
 518                   (while props
 519                     (push (format "%s:" (pop props)) ps)
 520                     (push (format "%s;" (pop props)) ps))
 521                   (list (cons "Properties" (nreverse ps)))))
 522             ("to input"
 523              ,@(let ((key-list (and (eq input-method-function
 524                                         'quail-input-method)
 525                                     (quail-find-key char))))
 526                  (if (consp key-list)
 527                      (list "type"
 528                            (mapconcat #'(lambda (x) (concat "\"" x "\""))
 529                                       key-list " or ")
 530                            "with"
 531                            `(widget-create
 532                              'link
 533                              :notify (lambda (&rest ignore)
 534                                        (describe-input-method
 535                                         ',current-input-method))
 536                              ,(format "%s" current-input-method))))))
 537             ("buffer code"
 538              ,(encoded-string-description
 539                (string-as-unibyte (char-to-string char)) nil))
 540             ("file code"
 541              ,@(let* ((coding buffer-file-coding-system)
 542                       (encoded (encode-coding-char char coding)))
 543                  (if encoded
 544                      (list (encoded-string-description encoded coding)
 545                            (format "(encoded by coding system %S)" coding))
 546                    (list "not encodable by coding system"
 547                          (symbol-name coding)))))
 548             ("display"
 549              ,(cond
 550                (disp-vector
 551                 (setq disp-vector (copy-sequence disp-vector))
 552                 (dotimes (i (length disp-vector))
 553                   (setq char (aref disp-vector i))
 554                   (aset disp-vector i
 555                         (cons char (describe-char-display
 556                                     pos (logand char #x7ffff)))))
 557                 (format "by display table entry [%s] (see below)"
 558                         (mapconcat
 559                          #'(lambda (x)
 560                              (format "?%c" (logand (car x) #x7ffff)))
 561                          disp-vector " ")))
 562                (composition
 563                 (let ((from (car composition))
 564                       (to (nth 1 composition))
 565                       (next (1+ pos))
 566                       (components (nth 2 composition))
 567                       ch)
 568                   (setcar composition
 569                           (and (< from pos) (buffer-substring from pos)))
 570                   (setcar (cdr composition)
 571                           (and (< next to) (buffer-substring next to)))
 572                   (dotimes (i (length components))
 573                     (if (integerp (setq ch (aref components i)))
 574                         (push (cons ch (describe-char-display pos ch))
 575                               component-chars)))
 576                   (setq component-chars (nreverse component-chars))
 577                   (format "composed to form \"%s\" (see below)"
 578                           (buffer-substring from to))))
 579                (t
 580                 (let ((display (describe-char-display pos char)))
 581                   (if (display-graphic-p (selected-frame))
 582                       (if display
 583                           (concat
 584                            "by this font (glyph code)\n"
 585                            (format "     %s (0x%02X)"
 586                                    (car display) (cdr display)))
 587                         "no font available")
 588                     (if display
 589                         (format "terminal code %s" display)
 590                       "not encodable for terminal"))))))
 591             ,@(let ((face
 592                      (if (not (or disp-vector composition))
 593                          (cond
 594                           ((and show-trailing-whitespace
 595                                 (save-excursion (goto-char pos)
 596                                                 (looking-at "[ \t]+$")))
 597                            'trailing-whitespace)
 598                           ((and nobreak-char-display unicode (eq unicode '#xa0))
 599                            'nobreak-space)
 600                           ((and nobreak-char-display unicode (eq unicode '#xad))
 601                            'escape-glyph)
 602                           ((and (< char 32) (not (memq char '(9 10))))
 603                            'escape-glyph)))))
 604                 (if face (list (list "hardcoded face"
 605                                      `(widget-create
 606                                        'link
 607                                        :notify (lambda (&rest ignore)
 608                                                  (describe-face ',face))
 609                                        ,(format "%s" face))))))
 610             ,@(let ((unicodedata (and unicode
 611                                       (describe-char-unicode-data unicode))))
 612                 (if unicodedata
 613                     (cons (list "Unicode data" " ") unicodedata)))))
 614     (setq max-width (apply #'max (mapcar #'(lambda (x)
 615                                              (if (cadr x) (length (car x)) 0))
 616                                          item-list)))
 617     (with-output-to-temp-buffer "*Help*"
 618       (with-current-buffer standard-output
 619         (set-buffer-multibyte multibyte-p)
 620         (let ((formatter (format "%%%ds:" max-width)))
 621           (dolist (elt item-list)
 622             (when (cadr elt)
 623               (insert (format formatter (car elt)))
 624               (dolist (clm (cdr elt))
 625                 (if (eq (car-safe clm) 'widget-create)
 626                     (progn (insert " ") (eval clm))
 627                   (when (>= (+ (current-column)
 628                                (or (string-match "\n" clm)
 629                                    (string-width clm))
 630                                1)
 631                             (window-width))
 632                     (insert "\n")
 633                     (indent-to (1+ max-width)))
 634                   (insert " " clm)))
 635               (insert "\n"))))
 636
 637         (save-excursion
 638           (goto-char (point-min))
 639           (re-search-forward "character:[ \t\n]+")
 640           (setq pos (point)))
 641         (if overlays
 642             (mapc #'(lambda (props)
 643                       (let ((o (make-overlay pos (1+ pos))))
 644                         (while props
 645                           (overlay-put o (car props) (nth 1 props))
 646                           (setq props (cddr props)))))
 647                   overlays))
 648
 649         (when disp-vector
 650           (insert
 651            "\nThe display table entry is displayed by ")
 652           (if (display-graphic-p (selected-frame))
 653               (progn
 654                 (insert "these fonts (glyph codes):\n")
 655                 (dotimes (i (length disp-vector))
 656                   (insert (logand (car (aref disp-vector i)) #x7ffff) ?:
 657                           (propertize " " 'display '(space :align-to 5))
 658                           (if (cdr (aref disp-vector i))
 659                               (format "%s (0x%02X)" (cadr (aref disp-vector i))
 660                                       (cddr (aref disp-vector i)))
 661                             "-- no font --")
 662                           "\n")
 663                   (when (> (car (aref disp-vector i)) #x7ffff)
 664                     (let* ((face-id (lsh (car (aref disp-vector i)) -19))
 665                            (face (car (delq nil (mapcar (lambda (face)
 666                                                           (and (eq (face-id face)
 667                                                                    face-id) face))
 668                                                         (face-list))))))
 669                       (when face
 670                         (insert (propertize " " 'display '(space :align-to 5))
 671                                 "face: ")
 672                         (widget-create 'link
 673                                        :notify `(lambda (&rest ignore)
 674                                                   (describe-face ',face))
 675                                        (format "%S" face))
 676                         (insert "\n"))))))
 677             (insert "these terminal codes:\n")
 678             (dotimes (i (length disp-vector))
 679               (insert (car (aref disp-vector i))
 680                       (propertize " " 'display '(space :align-to 5))
 681                       (or (cdr (aref disp-vector i)) "-- not encodable --")
 682                       "\n"))))
 683
 684         (when composition
 685           (insert "\nComposed")
 686           (if (car composition)
 687               (if (cadr composition)
 688                   (insert " with the surrounding characters \""
 689                           (car composition) "\" and \""
 690                           (cadr composition) "\"")
 691                 (insert " with the preceding character(s) \""
 692                         (car composition) "\""))
 693             (if (cadr composition)
 694                 (insert " with the following character(s) \""
 695                         (cadr composition) "\"")))
 696           (insert " by the rule:\n\t("
 697                   (mapconcat (lambda (x)
 698                                (format (if (consp x) "%S" "?%c") x))
 699                              (nth 2 composition)
 700                              " ")
 701                   ")")
 702           (insert  "\nThe component character(s) are displayed by ")
 703           (if (display-graphic-p (selected-frame))
 704               (progn
 705                 (insert "these fonts (glyph codes):")
 706                 (dolist (elt component-chars)
 707                   (insert "\n " (car elt) ?:
 708                           (propertize " " 'display '(space :align-to 5))
 709                           (if (cdr elt)
 710                               (format "%s (0x%02X)" (cadr elt) (cddr elt))
 711                             "-- no font --"))))
 712             (insert "these terminal codes:")
 713             (dolist (elt component-chars)
 714               (insert "\n  " (car elt) ":"
 715                       (propertize " " 'display '(space :align-to 5))
 716                       (or (cdr elt) "-- not encodable --"))))
 717           (insert "\nSee the variable `reference-point-alist' for "
 718                   "the meaning of the rule.\n"))
 719
 720         (describe-text-properties pos (current-buffer))
 721         (describe-text-mode)))))
 722
 723 (defalias 'describe-char-after 'describe-char)
 724 (make-obsolete 'describe-char-after 'describe-char "22.1")
 725
 726 (provide 'descr-text)
 727
 728 ;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1
 729 ;;; descr-text.el ends here