Commit | Line | Data |
---|---|---|
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> | |
57d79b99 | 6 | ;; Maintainer: FSF |
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. |
65 | PROPERTIES should be a list of overlay or text properties. | |
7fb0741b | 66 | The `category', `face' and `font-lock-face' properties are made |
57d79b99 | 67 | into 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. | |
113 | POS is taken to be in BUFFER or in current buffer if nil. | |
4adb7c09 RS |
114 | Interactively, describe them for the character after point. |
115 | If optional second argument OUTPUT-BUFFER is non-nil, | |
116 | insert the output into that buffer, and don't initialize or clear it | |
117 | otherwise." | |
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 | 209 | This is the UnicodeData.txt file from the Unicode Consortium, used for |
2a4960f9 | 210 | diagnostics. If it is non-nil `describe-char' will print data |
49c2a2dc SM |
211 | looked up from it. This facility is mostly of use to people doing |
212 | multilingual development. | |
4adb7c09 | 213 | |
2acb13b1 JB |
214 | This is a fairly large file, not typically present on GNU systems. |
215 | At 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 | 224 | Each element is a list of a property description and the property value. |
f1f194de KH |
225 | The list is null if CHAR isn't found in `describe-char-unicodedata-file'. |
226 | This 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. |
382 | POS is taken to be in BUFFER, or the current buffer if BUFFER is nil. | |
383 | The information is displayed in buffer `*Help*'. | |
384 | ||
385 | The position information includes POS; the total size of BUFFER; the | |
386 | region limits, if narrowed; the column number; and the horizontal | |
387 | scroll amount, if the buffer is horizontally scrolled. | |
388 | ||
389 | The character information includes the character code; charset and | |
390 | code points in it; syntax; category; how the character is encoded in | |
391 | BUFFER and in BUFFER's file; character composition information (if | |
392 | relevant); the font and font glyphs used to display the character; | |
393 | the character's canonical name and other properties defined by the | |
394 | Unicode Data Base; and widgets, buttons, overlays, and text properties | |
395 | relevant 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 |