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