HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
remove `declare' macro
[bpt/emacs.git] / lisp / descr-text.el
CommitLineData
40f7e0e8 1;;; descr-text.el --- describe text mode -*- lexical-binding:t -*-
2a1e884e 2
ba318903 3;; Copyright (C) 1994-1996, 2001-2014 Free Software Foundation, Inc.
2a1e884e
RS		 4
5;; Author: Boris Goldowsky <boris@gnu.org>
34dc21db 6;; Maintainer: emacs-devel@gnu.org
2d65673f 7;; Keywords: faces, i18n, Unicode, multilingual
2a1e884e
RS		 8
9;; This file is part of GNU Emacs.
10
eb3fa2cf 11;; GNU Emacs is free software: you can redistribute it and/or modify
2a1e884e 12;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM		 13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
2a1e884e
RS		 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
eb3fa2cf 22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
2a1e884e
RS		 23
24;;; Commentary:
25
40f7e0e8 26;; Describe-Text Mode.
2a1e884e
RS		 27
28;;; Code:
29
e5a5c80c 30(eval-when-compile (require 'quail))
56f14120 31(require 'help-mode)
2a1e884e
RS		 32
33;;; Describe-Text Utilities.
34
35(defun describe-text-widget (widget)
36 "Insert text to describe WIDGET in the current buffer."
57d79b99
NR		 37 (insert-text-button
38 (symbol-name (if (symbolp widget) widget (car widget)))
40f7e0e8 39 'action (lambda (&rest _ignore) (widget-browse widget))
e5a5c80c 40 'help-echo "mouse-2, RET: browse this widget")
57d79b99 41 (insert " ")
e5a5c80c
NR		 42 (insert-text-button
43 "(widget)Top" 'type 'help-info 'help-args '("(widget)Top")))
2a1e884e
RS		 44
45(defun describe-text-sexp (sexp)
46 "Insert a short description of SEXP in the current buffer."
47 (let ((pp (condition-case signal
48 (pp-to-string sexp)
49 (error (prin1-to-string signal)))))
70583cb5 50 (when (string-match-p "\n\\'" pp)
2a1e884e 51 (setq pp (substring pp 0 (1- (length pp)))))
70583cb5
JB		 52
53 (if (and (not (string-match-p "\n" pp))
54 (<= (length pp) (- (window-width) (current-column))))
57d79b99
NR		 55 (insert pp)
56 (insert-text-button
40f7e0e8
SM		 57 "[Show]" 'action (lambda (&rest _ignore)
58 (with-output-to-temp-buffer
59 "*Pp Eval Output*"
60 (princ pp)))
57d79b99 61 'help-echo "mouse-2, RET: pretty print value in another buffer"))))
2a1e884e 62
4adb7c09 63(defun describe-property-list (properties)
2a1e884e
RS		 64 "Insert a description of PROPERTIES in the current buffer.
65PROPERTIES should be a list of overlay or text properties.
7fb0741b 66The `category', `face' and `font-lock-face' properties are made
57d79b99 67into help buttons that call `describe-text-category' or
7fb0741b 68`describe-face' when pushed."
e2fa2f6e 69 ;; Sort the properties by the size of their value.
8b18fb8f 70 (dolist (elt (sort (let (ret)
e2fa2f6e 71 (while properties
8b18fb8f 72 (push (list (pop properties) (pop properties)) ret))
e2fa2f6e 73 ret)
d502fc06
RS		 74 (lambda (a b) (string< (prin1-to-string (nth 0 a) t)
75 (prin1-to-string (nth 0 b) t)))))
e2fa2f6e
CW		 76 (let ((key (nth 0 elt))
77 (value (nth 1 elt)))
57d79b99 78 (insert (propertize (format " %-20s " key)
e5a5c80c 79 'face 'help-argument-name))
2a1e884e 80 (cond ((eq key 'category)
e5a5c80c
NR		 81 (insert-text-button
82 (symbol-name value)
40f7e0e8
SM		 83 'action (lambda (&rest _ignore)
84 (describe-text-category value))
e7621494 85 'follow-link t
e5a5c80c 86 'help-echo "mouse-2, RET: describe this category"))
8b18fb8f 87 ((memq key '(face font-lock-face mouse-face))
2fd54bf8
JL		 88 (insert-text-button
89 (format "%S" value)
90 'type 'help-face 'help-args (list value)))
f13cc97d 91 ((widgetp value)
2a1e884e
RS		 92 (describe-text-widget value))
93 (t
8b18fb8f 94 (describe-text-sexp value))))
57d79b99 95 (insert "\n")))
2a1e884e
RS		 96\f
97;;; Describe-Text Commands.
98
99(defun describe-text-category (category)
100 "Describe a text property category."
e5a5c80c 101 (interactive "SCategory: ")
32226619
JB		 102 (help-setup-xref (list #'describe-text-category category)
103 (called-interactively-p 'interactive))
449c27f0
SM		 104 (with-help-window (help-buffer)
105 (with-current-buffer standard-output
57d79b99 106 (insert "Category " (format "%S" category) ":\n\n")
4adb7c09 107 (describe-property-list (symbol-plist category))
2a1e884e
RS		 108 (goto-char (point-min)))))
109
110;;;###autoload
449c27f0
SM		 111(defun describe-text-properties (pos &optional output-buffer buffer)
112 "Describe widgets, buttons, overlays, and text properties at POS.
113POS is taken to be in BUFFER or in current buffer if nil.
4adb7c09
RS		 114Interactively, describe them for the character after point.
115If optional second argument OUTPUT-BUFFER is non-nil,
116insert the output into that buffer, and don't initialize or clear it
117otherwise."
2a1e884e 118 (interactive "d")
449c27f0
SM		 119 (let ((src-buf (current-buffer)))
120 (if buffer (set-buffer buffer) (setq buffer (current-buffer)))
4adb7c09
RS		 121 (if (>= pos (point-max))
122 (error "No character follows specified position"))
123 (if output-buffer
124 (describe-text-properties-1 pos output-buffer)
125 (if (not (or (text-properties-at pos) (overlays-at pos)))
126 (message "This is plain text.")
449c27f0 127 (with-temp-buffer
4adb7c09 128 (setq output-buffer (current-buffer))
57d79b99 129 (insert "Text content at position " (format "%d" pos) ":\n\n")
449c27f0
SM		 130 (set-buffer buffer)
131 (describe-text-properties-1 pos output-buffer)
132 (set-buffer src-buf)
133 (help-setup-xref (list 'describe-text-properties pos nil buffer)
134 (called-interactively-p 'interactive))
135 (with-help-window (help-buffer)
136 (with-current-buffer standard-output
137 (buffer-swap-text output-buffer)
138 (goto-char (point-min)))))))))
4adb7c09
RS		 139
140(defun describe-text-properties-1 (pos output-buffer)
2a1e884e 141 (let* ((properties (text-properties-at pos))
a05731a0 142 (overlays (overlays-in pos (1+ pos)))
2a1e884e
RS		 143 (wid-field (get-char-property pos 'field))
144 (wid-button (get-char-property pos 'button))
145 (wid-doc (get-char-property pos 'widget-doc))
146 ;; If button.el is not loaded, we have no buttons in the text.
147 (button (and (fboundp 'button-at) (button-at pos)))
148 (button-type (and button (button-type button)))
149 (button-label (and button (button-label button)))
150 (widget (or wid-field wid-button wid-doc)))
4adb7c09
RS		 151 (with-current-buffer output-buffer
152 ;; Widgets
153 (when (widgetp widget)
154 (newline)
57d79b99
NR		 155 (insert (cond (wid-field "This is an editable text area")
156 (wid-button "This is an active area")
157 (wid-doc "This is documentation text")))
158 (insert " of a ")
4adb7c09 159 (describe-text-widget widget)
57d79b99 160 (insert ".\n\n"))
4adb7c09
RS		 161 ;; Buttons
162 (when (and button (not (widgetp wid-button)))
163 (newline)
2fd54bf8
JL		 164 (insert "Here is a `" (format "%S" button-type)
165 "' button labeled `" button-label "'.\n\n"))
4adb7c09
RS		 166 ;; Overlays
167 (when overlays
168 (newline)
169 (if (eq (length overlays) 1)
57d79b99
NR		 170 (insert "There is an overlay here:\n")
171 (insert "There are " (format "%d" (length overlays))
4adb7c09
RS		 172 " overlays here:\n"))
173 (dolist (overlay overlays)
57d79b99 174 (insert " From " (format "%d" (overlay-start overlay))
4adb7c09
RS		 175 " to " (format "%d" (overlay-end overlay)) "\n")
176 (describe-property-list (overlay-properties overlay)))
57d79b99 177 (insert "\n"))
4adb7c09
RS		 178 ;; Text properties
179 (when properties
180 (newline)
57d79b99 181 (insert "There are text properties here:\n")
4adb7c09 182 (describe-property-list properties)))))
d6c135fb 183\f
950b5859 184(defcustom describe-char-unidata-list
0e0f6cbd 185 '(name old-name general-category decomposition)
f1f194de
KH		 186 "List of Unicode-based character property names shown by `describe-char'."
187 :group 'mule
8589dc17 188 :version "23.1"
3253c7c6
SM		 189 :type '(choice (const :tag "All properties" t)
190 (set
08e968f3 191 (const :tag "Unicode name" name)
0e0f6cbd 192 (const :tag "Unicode old name" old-name)
3253c7c6
SM		 193 (const :tag "Unicode general category " general-category)
194 (const :tag "Unicode canonical combining class"
195 canonical-combining-class)
196 (const :tag "Unicode bidi class" bidi-class)
197 (const :tag "Unicode decomposition mapping" decomposition)
198 (const :tag "Unicode decimal digit value" decimal-digit-value)
199 (const :tag "Unicode digit value" digit-value)
200 (const :tag "Unicode numeric value" numeric-value)
201 (const :tag "Unicode mirrored" mirrored)
3253c7c6
SM		 202 (const :tag "Unicode ISO 10646 comment" iso-10646-comment)
203 (const :tag "Unicode simple uppercase mapping" uppercase)
204 (const :tag "Unicode simple lowercase mapping" lowercase)
205 (const :tag "Unicode simple titlecase mapping" titlecase))))
f1f194de 206
49c2a2dc
SM		 207(defcustom describe-char-unicodedata-file nil
208 "Location of Unicode data file.
2acb13b1 209This is the UnicodeData.txt file from the Unicode Consortium, used for
2a4960f9 210diagnostics. If it is non-nil `describe-char' will print data
49c2a2dc
SM		 211looked up from it. This facility is mostly of use to people doing
212multilingual development.
4adb7c09 213
2acb13b1
JB		 214This is a fairly large file, not typically present on GNU systems.
215At the time of writing it is at the URL
57d79b99 216`http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'."
49c2a2dc 217 :group 'mule
bf247b6e 218 :version "22.1"
49c2a2dc
SM		 219 :type '(choice (const :tag "None" nil)
220 file))
831ccfa6 221
49c2a2dc 222(defun describe-char-unicode-data (char)
fe7a3057 223 "Return a list of Unicode data for Unicode CHAR.
49c2a2dc 224Each element is a list of a property description and the property value.
f1f194de
KH		 225The list is null if CHAR isn't found in `describe-char-unicodedata-file'.
226This function is semi-obsolete. Use `get-char-code-property'."
49c2a2dc
SM		 227 (when describe-char-unicodedata-file
228 (unless (file-exists-p describe-char-unicodedata-file)
229 (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
def7167b
JB		 230 (with-current-buffer (get-buffer-create " *Unicode Data*")
231 (when (zerop (buffer-size))
232 ;; Don't use -literally in case of DOS line endings.
233 (insert-file-contents describe-char-unicodedata-file))
49c2a2dc
SM		 234 (goto-char (point-min))
235 (let ((hex (format "%04X" char))
236 found first last)
237 (if (re-search-forward (concat "^" hex) nil t)
238 (setq found t)
239 ;; It's not listed explicitly. Look for ranges, e.g. CJK
240 ;; ideographs, and check whether it's in one of them.
241 (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
242 (>= char (setq first
243 (string-to-number (match-string 1) 16)))
244 (progn
245 (forward-line 1)
246 (looking-at "^\\([^;]+\\);[^;]+Last>;")
247 (> char
248 (setq last
249 (string-to-number (match-string 1) 16))))))
250 (if (and (>= char first)
251 (<= char last))
252 (setq found t)))
253 (if found
254 (let ((fields (mapcar (lambda (elt)
255 (if (> (length elt) 0)
256 elt))
257 (cdr (split-string
258 (buffer-substring
259 (line-beginning-position)
260 (line-end-position))
261 ";")))))
262 ;; The length depends on whether the last field was empty.
263 (unless (or (= 13 (length fields))
264 (= 14 (length fields)))
265 (error "Invalid contents in %s" describe-char-unicodedata-file))
266 ;; The field names and values lists are slightly
267 ;; modified from Mule-UCS unidata.el.
268 (list
269 (list "Name" (let ((name (nth 0 fields)))
270 ;; Check for <..., First>, <..., Last>
271 (if (string-match "\\`\\(<[^,]+\\)," name)
272 (concat (match-string 1 name) ">")
273 name)))
274 (list "Category"
f1f194de
KH		 275 (let ((val (nth 1 fields)))
276 (or (char-code-property-description
277 'general-category (intern val))
278 val)))
49c2a2dc 279 (list "Combining class"
f1f194de
KH		 280 (let ((val (nth 1 fields)))
281 (or (char-code-property-description
282 'canonical-combining-class (intern val))
283 val)))
49c2a2dc 284 (list "Bidi category"
f1f194de
KH		 285 (let ((val (nth 1 fields)))
286 (or (char-code-property-description
287 'bidi-class (intern val))
288 val)))
49c2a2dc
SM		 289 (list
290 "Decomposition"
291 (if (nth 4 fields)
292 (let* ((parts (split-string (nth 4 fields)))
293 (info (car parts)))
294 (if (string-match "\\`<\\(.+\\)>\\'" info)
295 (setq info (match-string 1 info))
296 (setq info nil))
297 (if info (setq parts (cdr parts)))
49c2a2dc
SM		 298 (setq parts (mapconcat
299 (lambda (arg)
f1f194de 300 (string (string-to-number arg 16)))
49c2a2dc 301 parts " "))
74739ffd 302 (concat info (if info " ") parts))))
49c2a2dc
SM		 303 (list "Decimal digit value"
304 (nth 5 fields))
305 (list "Digit value"
306 (nth 6 fields))
307 (list "Numeric value"
308 (nth 7 fields))
309 (list "Mirrored"
310 (if (equal "Y" (nth 8 fields))
311 "yes"))
312 (list "Old name" (nth 9 fields))
313 (list "ISO 10646 comment" (nth 10 fields))
314 (list "Uppercase" (and (nth 11 fields)
f1f194de
KH		 315 (string (string-to-number
316 (nth 11 fields) 16))))
49c2a2dc 317 (list "Lowercase" (and (nth 12 fields)
f1f194de
KH		 318 (string (string-to-number
319 (nth 12 fields) 16))))
49c2a2dc 320 (list "Titlecase" (and (nth 13 fields)
f1f194de
KH		 321 (string (string-to-number
322 (nth 13 fields) 16)))))))))))
7fb0741b 323
aa360da1
GM		 324;; Not defined on builds without X, but behind display-graphic-p.
325(declare-function internal-char-font "fontset.c" (position &optional ch))
326
7fb0741b
KH		 327;; Return information about how CHAR is displayed at the buffer
328;; position POS. If the selected frame is on a graphic display,
7a674474
KH		 329;; return a string "FONT-DRIVER:FONT-NAME (GLYPH-CODE)" where:
330;; FONT-DRIVER is the font-driver name,
331;; FONT-NAME is the font name,
332;; GLYPH-CODE is a hexadigit string representing the glyph-ID.
333;; Otherwise, return a string describing the terminal codes for the
334;; character.
7fb0741b
KH		 335(defun describe-char-display (pos char)
336 (if (display-graphic-p (selected-frame))
e463f071 337 (let ((char-font-info (internal-char-font pos char)))
a6bbf9f4 338 (if char-font-info
7a674474 339 (let ((type (font-get (car char-font-info) :type))
c57b496b 340 (name (font-xlfd-name (car char-font-info)))
7a674474
KH		 341 (code (cdr char-font-info)))
342 (if (integerp code)
343 (format "%s:%s (#x%02X)" type name code)
344 (format "%s:%s (#x%04X%04X)"
345 type name (car code) (cdr code))))))
dfc7a783 346 (let* ((charset (get-text-property pos 'charset))
0ba13131 347 (coding (or (terminal-coding-system) 'us-ascii))
dfc7a783 348 (encoded (encode-coding-char char coding charset)))
7fb0741b 349 (if encoded
96065fce 350 (encoded-string-description encoded coding)))))
7fb0741b 351
d6c135fb 352\f
7a674474
KH		 353;; Return a string of CH with composition for padding on both sides.
354;; It is displayed without overlapping with the left/right columns.
355(defsubst describe-char-padded-string (ch)
2147c6ab
EZ		 356 (if (and (display-multi-font-p)
357 (internal-char-font nil ch))
b2f0be0f
KH		 358 (compose-string (string ch) 0 1 (format "\t%c\t" ch))
359 (string ch)))
7a674474 360
c80e3b4a 361;; Return a nicely formatted list of categories; extended category
d703f938
JB		 362;; description is added to the category name as a tooltip
363(defsubst describe-char-categories (category-set)
364 (let ((mnemonics (category-set-mnemonics category-set)))
365 (unless (eq mnemonics "")
366 (list (mapconcat
06b60517
JB		 367 (lambda (x)
368 (let* ((c (category-docstring x))
df9a7357 369 (doc (if (string-match "\\`\\(.*?\\)\n" c)
06b60517 370 (propertize (match-string 1 c)
df9a7357
JB		 371 'help-echo
372 (substring c (1+ (match-end 1))))
06b60517
JB		 373 c)))
374 (format "%c:%s" x doc)))
d703f938
JB		 375 mnemonics ", ")))))
376
d7fe6352
JB		 377(declare-function quail-find-key "quail" (char))
378
4adb7c09 379;;;###autoload
449c27f0 380(defun describe-char (pos &optional buffer)
7c188927
DA		 381 "Describe position POS (interactively, point) and the char after POS.
382POS is taken to be in BUFFER, or the current buffer if BUFFER is nil.
383The information is displayed in buffer `*Help*'.
384
385The position information includes POS; the total size of BUFFER; the
386region limits, if narrowed; the column number; and the horizontal
387scroll amount, if the buffer is horizontally scrolled.
388
389The character information includes the character code; charset and
390code points in it; syntax; category; how the character is encoded in
391BUFFER and in BUFFER's file; character composition information (if
392relevant); the font and font glyphs used to display the character;
393the character's canonical name and other properties defined by the
394Unicode Data Base; and widgets, buttons, overlays, and text properties
395relevant to POS."
4adb7c09 396 (interactive "d")
449c27f0
SM		 397 (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
398 (let ((src-buf (current-buffer)))
399 (set-buffer buffer)
400 (if (>= pos (point-max))
401 (error "No character follows specified position"))
402 (let* ((char (char-after pos))
403 (eight-bit-p (and (not enable-multibyte-characters) (>= char 128)))
404 (charset (if eight-bit-p 'eight-bit
405 (or (get-text-property pos 'charset)
406 (char-charset char))))
407 (composition (find-composition pos nil nil t))
408 (component-chars nil)
409 (display-table (or (window-display-table)
410 buffer-display-table
411 standard-display-table))
412 (disp-vector (and display-table (aref display-table char)))
413 (multibyte-p enable-multibyte-characters)
06b60517 414 (overlays (mapcar (lambda (o) (overlay-properties o))
449c27f0
SM		 415 (overlays-at pos)))
416 (char-description (if (not multibyte-p)
417 (single-key-description char)
418 (if (< char 128)
419 (single-key-description char)
420 (string-to-multibyte
421 (char-to-string char)))))
422 (text-props-desc
423 (let ((tmp-buf (generate-new-buffer " *text-props*")))
424 (unwind-protect
425 (progn
426 (describe-text-properties pos tmp-buf)
427 (with-current-buffer tmp-buf (buffer-string)))
428 (kill-buffer tmp-buf))))
429 item-list max-width code)
430
431 (if multibyte-p
432 (or (setq code (encode-char char charset))
433 (setq charset (char-charset char)
434 code (encode-char char charset)))
435 (setq code char))
71cc0b74
EZ		 436 (cond
437 ;; Append a PDF character to directional embeddings and
438 ;; overrides, to prevent potential messup of the following
439 ;; text.
440 ((memq char '(?\x202a ?\x202b ?\x202d ?\x202e))
441 (setq char-description
442 (concat char-description
443 (propertize (string ?\x202c) 'invisible t))))
444 ;; Append a LRM character to any strong character to avoid
445 ;; messing up the numerical codepoint.
446 ((memq (get-char-code-property char 'bidi-class) '(R AL))
447 (setq char-description
448 (concat char-description
449 (propertize (string ?\x200e) 'invisible t)))))
449c27f0
SM		 450 (when composition
451 ;; When the composition is trivial (i.e. composed only with the
452 ;; current character itself without any alternate characters),
453 ;; we don't show the composition information. Otherwise, store
78edd3b7 454 ;; two descriptive strings in the first two elements of
449c27f0
SM		 455 ;; COMPOSITION.
456 (or (catch 'tag
457 (let ((from (car composition))
458 (to (nth 1 composition))
459 (components (nth 2 composition))
460 ch)
461 (if (and (vectorp components) (vectorp (aref components 0)))
462 (let ((idx (- pos from))
463 (nglyphs (lgstring-glyph-len components))
464 (i 0) j glyph glyph-from)
465 ;; COMPONENTS is a gstring. Find a grapheme
466 ;; cluster containing the current character.
467 (while (and (< i nglyphs)
468 (setq glyph (lgstring-glyph components i))
469 (< (lglyph-to glyph) idx))
470 (setq i (1+ i)))
471 (if (or (not glyph) (= i nglyphs))
472 ;; The composition is broken.
473 (throw 'tag nil))
474 (setq glyph-from (lglyph-from glyph)
475 to (+ from (lglyph-to glyph) 1)
476 from (+ from glyph-from)
477 j i)
478 (while (and (< j nglyphs)
479 (setq glyph (lgstring-glyph components j))
480 (= (lglyph-from glyph) glyph-from))
481 (setq j (1+ j)))
482 (if (and (= to (1+ from))
483 (= i (1- j))
484 (setq glyph (lgstring-glyph components i))
485 (= char (lglyph-char glyph)))
486 ;; The composition is trivial.
487 (throw 'tag nil))
488 (nconc composition (list i (1- j))))
489 (dotimes (i (length components))
490 (if (integerp (setq ch (aref components i)))
491 (push (cons ch (describe-char-display pos ch))
492 component-chars)))
493 (setq component-chars (nreverse component-chars)))
494 (if (< from pos)
495 (if (< (1+ pos) to)
496 (setcar composition
497 (concat
498 " with the surrounding characters \""
499 (mapconcat 'describe-char-padded-string
500 (buffer-substring from pos) "")
501 "\" and \""
502 (mapconcat 'describe-char-padded-string
503 (buffer-substring (1+ pos) to) "")
504 "\""))
505 (setcar composition
506 (concat
507 " with the preceding character(s) \""
508 (mapconcat 'describe-char-padded-string
509 (buffer-substring from pos) "")
510 "\"")))
511 (if (< (1+ pos) to)
512 (setcar composition
513 (concat
514 " with the following character(s) \""
515 (mapconcat 'describe-char-padded-string
516 (buffer-substring (1+ pos) to) "")
517 "\""))
518 (setcar composition nil)))
519 (setcar (cdr composition)
520 (format "composed to form \"%s\" (see below)"
521 (buffer-substring from to)))))
522 (setq composition nil)))
523
524 (setq item-list
7c188927
DA		 525 `(("position"
526 ,(let* ((beg (point-min))
527 (end (point-max))
528 (total (buffer-size))
529 (percent (if (> total 50000) ; Avoid overflow multiplying by 100
530 (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1))
531 (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1))))
532 (hscroll (if (= (window-hscroll) 0)
533 ""
534 (format ", Hscroll: %d" (window-hscroll))))
535 (col (current-column)))
536 (if (or (/= beg 1) (/= end (1+ total)))
537 (format "%d of %d (%d%%), restriction: <%d-%d>, column: %d%s"
b19dd9d1 538 pos total percent beg end col hscroll)
7c188927
DA		 539 (if (= pos end)
540 (format "%d of %d (EOB), column: %d%s" pos total col hscroll)
541 (format "%d of %d (%d%%), column: %d%s"
542 pos total percent col hscroll)))))
543 ("character"
e0da685a
EZ		 544 ,(format "%s (displayed as %s) (codepoint %d, #o%o, #x%x)"
545 char-description
449c27f0
SM		 546 (apply 'propertize char-description
547 (text-properties-at pos))
548 char char char))
549 ("preferred charset"
550 ,`(insert-text-button
551 ,(symbol-name charset)
552 'type 'help-character-set 'help-args '(,charset))
553 ,(format "(%s)" (charset-description charset)))
7c188927 554 ("code point in charset"
449c27f0
SM		 555 ,(let ((str (if (integerp code)
556 (format (if (< code 256) "0x%02X" "0x%04X")
557 code)
558 (format "0x%04X%04X" (car code) (cdr code)))))
559 (if (<= (charset-dimension charset) 2)
560 `(insert-text-button
561 ,str
562 'action (lambda (&rest ignore)
563 (list-charset-chars ',charset)
564 (with-selected-window
565 (get-buffer-window "*Character List*" 0)
566 (goto-char (point-min))
567 (forward-line 2) ;Skip the header.
568 (let ((case-fold-search nil))
569 (if (search-forward
570 ,(char-to-string char) nil t)
571 (goto-char (match-beginning 0))))))
572 'follow-link t
573 'help-echo
574 "mouse-2, RET: show this character in its character set")
575 str)))
67f3e54a
YQ		 576 ,@(let ((script (aref char-script-table char)))
577 (if script
578 (list (list "script" (symbol-name script)))))
449c27f0
SM		 579 ("syntax"
580 ,(let ((syntax (syntax-after pos)))
581 (with-temp-buffer
582 (internal-describe-syntax-value syntax)
583 (buffer-string))))
584 ("category"
585 ,@(if (not eight-bit-p)
586 (let ((category-set (char-category-set char)))
587 (if category-set
588 (describe-char-categories category-set)
589 '("-- none --")))))
590 ("to input"
591 ,@(if (not eight-bit-p)
592 (let ((key-list (and (eq input-method-function
593 'quail-input-method)
594 (quail-find-key char))))
595 (if (consp key-list)
596 (list "type"
597 (concat "\""
598 (mapconcat 'identity
599 key-list "\" or \"")
600 "\"")
601 "with"
602 `(insert-text-button
603 ,current-input-method
604 'type 'help-input-method
e9f66fcb
EZ		 605 'help-args '(,current-input-method))
606 "input method")
607 (list
608 "type \"C-x 8 RET HEX-CODEPOINT\" or \"C-x 8 RET NAME\"")))))
449c27f0
SM		 609 ("buffer code"
610 ,(if multibyte-p
611 (encoded-string-description
612 (string-as-unibyte (char-to-string char)) nil)
613 (format "#x%02X" char)))
614 ("file code"
615 ,@(if multibyte-p
616 (let* ((coding buffer-file-coding-system)
617 (encoded (encode-coding-char char coding charset)))
618 (if encoded
619 (list (encoded-string-description encoded coding)
620 (format "(encoded by coding system %S)"
621 coding))
622 (list "not encodable by coding system"
623 (symbol-name coding))))
624 (list (format "#x%02X" char))))
625 ("display"
626 ,(cond
627 (disp-vector
628 (setq disp-vector (copy-sequence disp-vector))
629 (dotimes (i (length disp-vector))
630 (aset disp-vector i
631 (cons (aref disp-vector i)
632 (describe-char-display
633 pos (glyph-char (aref disp-vector i))))))
634 (format "by display table entry [%s] (see below)"
635 (mapconcat
06b60517
JB		 636 (lambda (x)
637 (format "?%c" (glyph-char (car x))))
449c27f0
SM		 638 disp-vector " ")))
639 (composition
640 (cadr composition))
641 (t
642 (let ((display (describe-char-display pos char)))
643 (if (display-graphic-p (selected-frame))
644 (if display
645 (concat "by this font (glyph code)\n " display)
646 "no font available")
647 (if display
648 (format "terminal code %s" display)
649 "not encodable for terminal"))))))
650 ,@(let ((face
651 (if (not (or disp-vector composition))
652 (cond
653 ((and show-trailing-whitespace
654 (save-excursion (goto-char pos)
655 (looking-at-p "[ \t]+$")))
656 'trailing-whitespace)
657 ((and nobreak-char-display char (eq char '#xa0))
658 'nobreak-space)
aa42ab43
JL		 659 ((and nobreak-char-display char
660 (memq char '(#xad #x2010 #x2011)))
449c27f0
SM		 661 'escape-glyph)
662 ((and (< char 32) (not (memq char '(9 10))))
663 'escape-glyph)))))
664 (if face (list (list "hardcoded face"
40f7e0e8 665 `(insert-text-button ;FIXME: Wrap in lambda!
449c27f0
SM		 666 ,(symbol-name face)
667 'type 'help-face
668 'help-args '(,face))))))
669 ,@(if (not eight-bit-p)
670 (let ((unicodedata (describe-char-unicode-data char)))
671 (if unicodedata
d148e8f9 672 (cons (list "Unicode data" "") unicodedata))))))
449c27f0
SM		 673 (setq max-width (apply 'max (mapcar (lambda (x)
674 (if (cadr x) (length (car x)) 0))
675 item-list)))
676 (set-buffer src-buf)
677 (help-setup-xref (list 'describe-char pos buffer)
678 (called-interactively-p 'interactive))
679 (with-help-window (help-buffer)
680 (with-current-buffer standard-output
681 (set-buffer-multibyte multibyte-p)
682 (let ((formatter (format "%%%ds:" max-width)))
683 (dolist (elt item-list)
684 (when (cadr elt)
685 (insert (format formatter (car elt)))
686 (dolist (clm (cdr elt))
3e861c8a
CY		 687 (cond ((eq (car-safe clm) 'insert-text-button)
688 (insert " ")
689 (eval clm))
690 ((not (zerop (length clm)))
691 (insert " " clm))))
449c27f0
SM		 692 (insert "\n"))))
693
694 (when overlays
695 (save-excursion
696 (goto-char (point-min))
9229c658 697 (re-search-forward "(displayed as ")
449c27f0 698 (let ((end (+ (point) (length char-description))))
06b60517
JB		 699 (mapc (lambda (props)
700 (let ((o (make-overlay (point) end)))
701 (while props
702 (overlay-put o (car props) (nth 1 props))
703 (setq props (cddr props)))))
449c27f0
SM		 704 overlays))))
705
706 (when disp-vector
707 (insert
708 "\nThe display table entry is displayed by ")
709 (if (display-graphic-p (selected-frame))
710 (progn
711 (insert "these fonts (glyph codes):\n")
712 (dotimes (i (length disp-vector))
713 (insert (glyph-char (car (aref disp-vector i))) ?:
714 (propertize " " 'display '(space :align-to 5))
715 (or (cdr (aref disp-vector i)) "-- no font --")
716 "\n")
717 (let ((face (glyph-face (car (aref disp-vector i)))))
718 (when face
719 (insert (propertize " " 'display '(space :align-to 5))
720 "face: ")
721 (insert (concat "`" (symbol-name face) "'"))
722 (insert "\n")))))
723 (insert "these terminal codes:\n")
724 (dotimes (i (length disp-vector))
725 (insert (car (aref disp-vector i))
726 (propertize " " 'display '(space :align-to 5))
727 (or (cdr (aref disp-vector i)) "-- not encodable --")
728 "\n"))))
729
730 (when composition
731 (insert "\nComposed")
732 (if (car composition)
733 (insert (car composition)))
734 (if (and (vectorp (nth 2 composition))
735 (vectorp (aref (nth 2 composition) 0)))
736 (let* ((gstring (nth 2 composition))
737 (font (lgstring-font gstring))
738 (from (nth 3 composition))
739 (to (nth 4 composition))
740 glyph)
741 (if (fontp font)
742 (progn
743 (insert " using this font:\n "
744 (symbol-name (font-get font :type))
745 ?:
746 (aref (query-font font) 0)
747 "\nby these glyphs:\n")
748 (while (and (<= from to)
749 (setq glyph (lgstring-glyph gstring from)))
750 (insert (format " %S\n" glyph))
751 (setq from (1+ from))))
752 (insert " by these characters:\n")
753 (while (and (<= from to)
754 (setq glyph (lgstring-glyph gstring from)))
b01682fb 755 (insert (format " %c (#x%x)\n"
449c27f0
SM		 756 (lglyph-char glyph) (lglyph-char glyph)))
757 (setq from (1+ from)))))
758 (insert " by the rule:\n\t(")
759 (let ((first t))
760 (mapc (lambda (x)
761 (if first (setq first nil)
762 (insert " "))
763 (if (consp x) (insert (format "%S" x))
764 (if (= x ?\t) (insert (single-key-description x))
765 (insert ??)
766 (insert (describe-char-padded-string x)))))
767 (nth 2 composition)))
768 (insert ")\nThe component character(s) are displayed by ")
769 (if (display-graphic-p (selected-frame))
770 (progn
771 (insert "these fonts (glyph codes):")
772 (dolist (elt component-chars)
773 (if (/= (car elt) ?\t)
774 (insert "\n "
775 (describe-char-padded-string (car elt))
776 ?:
777 (propertize " "
778 'display '(space :align-to 5))
779 (or (cdr elt) "-- no font --")))))
780 (insert "these terminal codes:")
781 (dolist (elt component-chars)
782 (insert "\n " (car elt) ":"
783 (propertize " " 'display '(space :align-to 4))
784 (or (cdr elt) "-- not encodable --"))))
785 (insert "\nSee the variable `reference-point-alist' for "
786 "the meaning of the rule.\n")))
787
788 (unless eight-bit-p
789 (insert (if (not describe-char-unidata-list)
790 "\nCharacter code properties are not shown: "
791 "\nCharacter code properties: "))
792 (insert-text-button
793 "customize what to show"
06b60517 794 'action (lambda (&rest _ignore)
449c27f0
SM		 795 (customize-variable
796 'describe-char-unidata-list))
797 'follow-link t)
798 (insert "\n")
799 (dolist (elt (if (eq describe-char-unidata-list t)
800 (nreverse (mapcar 'car char-code-property-alist))
801 describe-char-unidata-list))
802 (let ((val (get-char-code-property char elt))
803 description)
804 (when val
805 (setq description (char-code-property-description elt val))
806 (insert (if description
807 (format " %s: %s (%s)\n" elt val description)
808 (format " %s: %s\n" elt val)))))))
809
810 (if text-props-desc (insert text-props-desc))
376cbacc 811 (setq buffer-read-only t))))))
4adb7c09 812
781424c2 813(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
831ccfa6 814
288395a7
CW		 815(provide 'descr-text)
816
2a1e884e 817;;; descr-text.el ends here
Unnamed repository; edit this file 'description' to name the repository.