Commit | Line | Data |
---|---|---|
dcb90b5f | 1 | ;;; descr-text.el --- describe text mode |
2a1e884e | 2 | |
0d30b337 TTN |
3 | ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004, |
4 | ;; 2005 Free Software Foundation, Inc. | |
2a1e884e RS |
5 | |
6 | ;; Author: Boris Goldowsky <boris@gnu.org> | |
2d65673f | 7 | ;; Keywords: faces, i18n, Unicode, multilingual |
2a1e884e RS |
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 | |
086add15 LK |
23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 | ;; Boston, MA 02110-1301, USA. | |
2a1e884e RS |
25 | |
26 | ;;; Commentary: | |
27 | ||
28 | ;;; Describe-Text Mode. | |
29 | ||
30 | ;;; Code: | |
31 | ||
309473d0 | 32 | (eval-when-compile (require 'button) (require 'quail)) |
831ccfa6 | 33 | |
2a1e884e RS |
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 | ||
71296446 | 41 | (defvar describe-text-mode-map |
2a1e884e RS |
42 | (let ((map (make-sparse-keymap))) |
43 | (set-keymap-parent map widget-keymap) | |
44 | map) | |
45 | "Keymap for `describe-text-mode'.") | |
71296446 | 46 | |
2a1e884e RS |
47 | (defcustom describe-text-mode-hook nil |
48 | "List of hook functions ran by `describe-text-mode'." | |
d77a0b9b MR |
49 | :type 'hook |
50 | :group 'facemenu) | |
2a1e884e RS |
51 | |
52 | (defun describe-text-mode () | |
4adb7c09 | 53 | "Major mode for buffers created by `describe-char'. |
2a1e884e RS |
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) | |
f0397cde | 63 | (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) |
258cf562 | 64 | (run-mode-hooks 'describe-text-mode-hook)) |
2a1e884e RS |
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)) | |
71296446 | 73 | (format "%S" (if (symbolp widget) |
2a1e884e RS |
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)))) | |
2a1e884e | 99 | |
4adb7c09 | 100 | (defun describe-property-list (properties) |
2a1e884e RS |
101 | "Insert a description of PROPERTIES in the current buffer. |
102 | PROPERTIES should be a list of overlay or text properties. | |
4eb59450 JL |
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." | |
e2fa2f6e | 106 | ;; Sort the properties by the size of their value. |
8b18fb8f | 107 | (dolist (elt (sort (let (ret) |
e2fa2f6e | 108 | (while properties |
8b18fb8f | 109 | (push (list (pop properties) (pop properties)) ret)) |
e2fa2f6e | 110 | ret) |
d502fc06 RS |
111 | (lambda (a b) (string< (prin1-to-string (nth 0 a) t) |
112 | (prin1-to-string (nth 0 b) t))))) | |
e2fa2f6e CW |
113 | (let ((key (nth 0 elt)) |
114 | (value (nth 1 elt))) | |
c1a1535a | 115 | (widget-insert (propertize (format " %-20s " key) |
e2fa2f6e | 116 | 'font-lock-face 'italic)) |
2a1e884e | 117 | (cond ((eq key 'category) |
c1a1535a | 118 | (widget-create 'link |
2a1e884e RS |
119 | :notify `(lambda (&rest ignore) |
120 | (describe-text-category ',value)) | |
121 | (format "%S" value))) | |
8b18fb8f | 122 | ((memq key '(face font-lock-face mouse-face)) |
72354910 JL |
123 | (widget-create 'link |
124 | :notify `(lambda (&rest ignore) | |
125 | (describe-face ',value)) | |
126 | (format "%S" value))) | |
f13cc97d | 127 | ((widgetp value) |
2a1e884e RS |
128 | (describe-text-widget value)) |
129 | (t | |
8b18fb8f | 130 | (describe-text-sexp value)))) |
e2fa2f6e | 131 | (widget-insert "\n"))) |
2a1e884e RS |
132 | \f |
133 | ;;; Describe-Text Commands. | |
134 | ||
135 | (defun describe-text-category (category) | |
136 | "Describe a text property category." | |
137 | (interactive "S") | |
2a1e884e | 138 | (save-excursion |
ca9088e7 SM |
139 | (with-output-to-temp-buffer "*Help*" |
140 | (set-buffer standard-output) | |
2a1e884e | 141 | (widget-insert "Category " (format "%S" category) ":\n\n") |
4adb7c09 | 142 | (describe-property-list (symbol-plist category)) |
2a1e884e RS |
143 | (describe-text-mode) |
144 | (goto-char (point-min))))) | |
145 | ||
146 | ;;;###autoload | |
4adb7c09 RS |
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." | |
2a1e884e | 153 | (interactive "d") |
4adb7c09 RS |
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.") | |
0911ac26 KS |
160 | (let ((buffer (current-buffer)) |
161 | (target-buffer "*Help*")) | |
162 | (when (eq buffer (get-buffer target-buffer)) | |
163 | (setq target-buffer "*Help-2*")) | |
4adb7c09 | 164 | (save-excursion |
0911ac26 | 165 | (with-output-to-temp-buffer target-buffer |
ca9088e7 | 166 | (set-buffer standard-output) |
4adb7c09 RS |
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) | |
2a1e884e RS |
175 | (let* ((properties (text-properties-at pos)) |
176 | (overlays (overlays-at pos)) | |
2a1e884e RS |
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))) | |
4adb7c09 RS |
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) | |
71296446 | 198 | (widget-insert "Here is a " (format "%S" button-type) |
4adb7c09 RS |
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) | |
71296446 | 208 | (widget-insert " From " (format "%d" (overlay-start overlay)) |
4adb7c09 RS |
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))))) | |
d6c135fb | 217 | \f |
49c2a2dc SM |
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 | |
2a4960f9 | 221 | diagnostics. If it is non-nil `describe-char' will print data |
49c2a2dc SM |
222 | looked up from it. This facility is mostly of use to people doing |
223 | multilingual development. | |
4adb7c09 | 224 | |
49c2a2dc SM |
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 | |
bf247b6e | 229 | :version "22.1" |
49c2a2dc SM |
230 | :type '(choice (const :tag "None" nil) |
231 | file)) | |
831ccfa6 | 232 | |
49c2a2dc SM |
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). | |
831ccfa6 | 238 | |
49c2a2dc SM |
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 | ??))))))))))) | |
f15078e2 KH |
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 | ||
d6c135fb | 439 | \f |
4adb7c09 RS |
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") | |
4adb7c09 RS |
448 | (if (>= pos (point-max)) |
449 | (error "No character follows specified position")) | |
450 | (let* ((char (char-after pos)) | |
451 | (charset (char-charset char)) | |
ca9088e7 | 452 | (composition (find-composition pos nil nil t)) |
f15078e2 KH |
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))) | |
4adb7c09 | 458 | (multibyte-p enable-multibyte-characters) |
6482d093 KH |
459 | (overlays (mapcar #'(lambda (o) (overlay-properties o)) |
460 | (overlays-at pos))) | |
6398b88f AS |
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))))) | |
831ccfa6 | 467 | item-list max-width unicode) |
831ccfa6 | 468 | |
ed441285 KH |
469 | (if (or (< char 256) |
470 | (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos))) | |
471 | (get-char-property pos 'untranslated-utf-8)) | |
472 | (setq unicode (or (get-char-property pos 'untranslated-utf-8) | |
473 | (encode-char char 'ucs)))) | |
474 | (setq item-list | |
475 | `(("character" | |
9f40939d | 476 | ,(format "%s (%d, #o%o, #x%x%s)" |
6398b88f | 477 | (apply 'propertize char-description |
ed441285 KH |
478 | (text-properties-at pos)) |
479 | char char char | |
480 | (if unicode | |
481 | (format ", U+%04X" unicode) | |
482 | ""))) | |
483 | ("charset" | |
fedbc8e5 JL |
484 | ,`(widget-create 'link |
485 | :notify (lambda (&rest ignore) | |
486 | (describe-character-set ',charset)) | |
487 | ,(symbol-name charset)) | |
ed441285 KH |
488 | ,(format "(%s)" (charset-description charset))) |
489 | ("code point" | |
490 | ,(let ((split (split-char char))) | |
fedbc8e5 JL |
491 | `(widget-create |
492 | 'link | |
493 | :notify (lambda (&rest ignore) | |
494 | (list-charset-chars ',charset) | |
495 | (with-selected-window | |
cbfde7a0 | 496 | (get-buffer-window "*Character List*" 0) |
fedbc8e5 | 497 | (goto-char (point-min)) |
cbfde7a0 SM |
498 | (forward-line 2) ;Skip the header. |
499 | (let ((case-fold-search nil)) | |
500 | (search-forward ,(char-to-string char) | |
501 | nil t)))) | |
fedbc8e5 JL |
502 | ,(if (= (charset-dimension charset) 1) |
503 | (format "%d" (nth 1 split)) | |
504 | (format "%d %d" (nth 1 split) (nth 2 split)))))) | |
ed441285 | 505 | ("syntax" |
d8ac3d27 | 506 | ,(let ((syntax (syntax-after pos))) |
ed441285 KH |
507 | (with-temp-buffer |
508 | (internal-describe-syntax-value syntax) | |
509 | (buffer-string)))) | |
510 | ("category" | |
511 | ,@(let ((category-set (char-category-set char))) | |
512 | (if (not category-set) | |
513 | '("-- none --") | |
9f40939d | 514 | (mapcar #'(lambda (x) (format "%c:%s" |
ed441285 KH |
515 | x (category-docstring x))) |
516 | (category-set-mnemonics category-set))))) | |
517 | ,@(let ((props (aref char-code-property-table char)) | |
518 | ps) | |
519 | (when props | |
520 | (while props | |
521 | (push (format "%s:" (pop props)) ps) | |
522 | (push (format "%s;" (pop props)) ps)) | |
523 | (list (cons "Properties" (nreverse ps))))) | |
309473d0 | 524 | ("to input" |
22259c93 KH |
525 | ,@(let ((key-list (and (eq input-method-function |
526 | 'quail-input-method) | |
309473d0 KH |
527 | (quail-find-key char)))) |
528 | (if (consp key-list) | |
529 | (list "type" | |
530 | (mapconcat #'(lambda (x) (concat "\"" x "\"")) | |
fedbc8e5 JL |
531 | key-list " or ") |
532 | "with" | |
533 | `(widget-create | |
534 | 'link | |
535 | :notify (lambda (&rest ignore) | |
536 | (describe-input-method | |
537 | ',current-input-method)) | |
538 | ,(format "%s" current-input-method)))))) | |
ed441285 KH |
539 | ("buffer code" |
540 | ,(encoded-string-description | |
541 | (string-as-unibyte (char-to-string char)) nil)) | |
542 | ("file code" | |
543 | ,@(let* ((coding buffer-file-coding-system) | |
544 | (encoded (encode-coding-char char coding))) | |
545 | (if encoded | |
546 | (list (encoded-string-description encoded coding) | |
547 | (format "(encoded by coding system %S)" coding)) | |
548 | (list "not encodable by coding system" | |
549 | (symbol-name coding))))) | |
550 | ("display" | |
551 | ,(cond | |
552 | (disp-vector | |
553 | (setq disp-vector (copy-sequence disp-vector)) | |
554 | (dotimes (i (length disp-vector)) | |
555 | (setq char (aref disp-vector i)) | |
556 | (aset disp-vector i | |
8b18fb8f JL |
557 | (cons char (describe-char-display |
558 | pos (logand char #x7ffff))))) | |
ed441285 | 559 | (format "by display table entry [%s] (see below)" |
8b18fb8f JL |
560 | (mapconcat |
561 | #'(lambda (x) | |
fedbc8e5 | 562 | (format "?%c" (logand (car x) #x7ffff))) |
8b18fb8f | 563 | disp-vector " "))) |
ed441285 KH |
564 | (composition |
565 | (let ((from (car composition)) | |
566 | (to (nth 1 composition)) | |
567 | (next (1+ pos)) | |
568 | (components (nth 2 composition)) | |
569 | ch) | |
570 | (setcar composition | |
571 | (and (< from pos) (buffer-substring from pos))) | |
572 | (setcar (cdr composition) | |
573 | (and (< next to) (buffer-substring next to))) | |
574 | (dotimes (i (length components)) | |
575 | (if (integerp (setq ch (aref components i))) | |
576 | (push (cons ch (describe-char-display pos ch)) | |
577 | component-chars))) | |
578 | (setq component-chars (nreverse component-chars)) | |
579 | (format "composed to form \"%s\" (see below)" | |
580 | (buffer-substring from to)))) | |
581 | (t | |
582 | (let ((display (describe-char-display pos char))) | |
583 | (if (display-graphic-p (selected-frame)) | |
f15078e2 | 584 | (if display |
ed441285 KH |
585 | (concat |
586 | "by this font (glyph code)\n" | |
9f40939d | 587 | (format " %s (#x%02X)" |
ed441285 KH |
588 | (car display) (cdr display))) |
589 | "no font available") | |
590 | (if display | |
591 | (format "terminal code %s" display) | |
592 | "not encodable for terminal")))))) | |
fedbc8e5 JL |
593 | ,@(let ((face |
594 | (if (not (or disp-vector composition)) | |
595 | (cond | |
596 | ((and show-trailing-whitespace | |
597 | (save-excursion (goto-char pos) | |
598 | (looking-at "[ \t]+$"))) | |
599 | 'trailing-whitespace) | |
600 | ((and nobreak-char-display unicode (eq unicode '#xa0)) | |
601 | 'nobreak-space) | |
602 | ((and nobreak-char-display unicode (eq unicode '#xad)) | |
603 | 'escape-glyph) | |
604 | ((and (< char 32) (not (memq char '(9 10)))) | |
605 | 'escape-glyph))))) | |
606 | (if face (list (list "hardcoded face" | |
607 | `(widget-create | |
608 | 'link | |
609 | :notify (lambda (&rest ignore) | |
610 | (describe-face ',face)) | |
611 | ,(format "%s" face)))))) | |
ed441285 KH |
612 | ,@(let ((unicodedata (and unicode |
613 | (describe-char-unicode-data unicode)))) | |
614 | (if unicodedata | |
615 | (cons (list "Unicode data" " ") unicodedata))))) | |
fedbc8e5 JL |
616 | (setq max-width (apply #'max (mapcar #'(lambda (x) |
617 | (if (cadr x) (length (car x)) 0)) | |
4adb7c09 | 618 | item-list))) |
4adb7c09 | 619 | (with-output-to-temp-buffer "*Help*" |
ca9088e7 | 620 | (with-current-buffer standard-output |
4adb7c09 RS |
621 | (set-buffer-multibyte multibyte-p) |
622 | (let ((formatter (format "%%%ds:" max-width))) | |
623 | (dolist (elt item-list) | |
831ccfa6 DL |
624 | (when (cadr elt) |
625 | (insert (format formatter (car elt))) | |
626 | (dolist (clm (cdr elt)) | |
fedbc8e5 JL |
627 | (if (eq (car-safe clm) 'widget-create) |
628 | (progn (insert " ") (eval clm)) | |
629 | (when (>= (+ (current-column) | |
630 | (or (string-match "\n" clm) | |
631 | (string-width clm)) | |
632 | 1) | |
633 | (window-width)) | |
634 | (insert "\n") | |
635 | (indent-to (1+ max-width))) | |
636 | (insert " " clm))) | |
831ccfa6 | 637 | (insert "\n")))) |
f15078e2 | 638 | |
ed441285 KH |
639 | (save-excursion |
640 | (goto-char (point-min)) | |
f13cc97d | 641 | (re-search-forward "character:[ \t\n]+") |
ed441285 | 642 | (setq pos (point))) |
6398b88f AS |
643 | (let ((end (+ pos (length char-description)))) |
644 | (if overlays | |
645 | (mapc #'(lambda (props) | |
646 | (let ((o (make-overlay pos end))) | |
647 | (while props | |
648 | (overlay-put o (car props) (nth 1 props)) | |
649 | (setq props (cddr props))))) | |
650 | overlays))) | |
ed441285 | 651 | |
f15078e2 KH |
652 | (when disp-vector |
653 | (insert | |
654 | "\nThe display table entry is displayed by ") | |
655 | (if (display-graphic-p (selected-frame)) | |
656 | (progn | |
657 | (insert "these fonts (glyph codes):\n") | |
658 | (dotimes (i (length disp-vector)) | |
8b18fb8f | 659 | (insert (logand (car (aref disp-vector i)) #x7ffff) ?: |
f15078e2 KH |
660 | (propertize " " 'display '(space :align-to 5)) |
661 | (if (cdr (aref disp-vector i)) | |
9f40939d | 662 | (format "%s (#x%02X)" (cadr (aref disp-vector i)) |
f15078e2 KH |
663 | (cddr (aref disp-vector i))) |
664 | "-- no font --") | |
fedbc8e5 JL |
665 | "\n") |
666 | (when (> (car (aref disp-vector i)) #x7ffff) | |
667 | (let* ((face-id (lsh (car (aref disp-vector i)) -19)) | |
668 | (face (car (delq nil (mapcar (lambda (face) | |
669 | (and (eq (face-id face) | |
670 | face-id) face)) | |
671 | (face-list)))))) | |
672 | (when face | |
673 | (insert (propertize " " 'display '(space :align-to 5)) | |
674 | "face: ") | |
675 | (widget-create 'link | |
676 | :notify `(lambda (&rest ignore) | |
677 | (describe-face ',face)) | |
678 | (format "%S" face)) | |
679 | (insert "\n")))))) | |
f15078e2 KH |
680 | (insert "these terminal codes:\n") |
681 | (dotimes (i (length disp-vector)) | |
544cb6b0 | 682 | (insert (car (aref disp-vector i)) |
f15078e2 KH |
683 | (propertize " " 'display '(space :align-to 5)) |
684 | (or (cdr (aref disp-vector i)) "-- not encodable --") | |
685 | "\n")))) | |
686 | ||
4adb7c09 | 687 | (when composition |
f15078e2 KH |
688 | (insert "\nComposed") |
689 | (if (car composition) | |
690 | (if (cadr composition) | |
691 | (insert " with the surrounding characters \"" | |
692 | (car composition) "\" and \"" | |
693 | (cadr composition) "\"") | |
694 | (insert " with the preceding character(s) \"" | |
695 | (car composition) "\"")) | |
696 | (if (cadr composition) | |
697 | (insert " with the following character(s) \"" | |
698 | (cadr composition) "\""))) | |
699 | (insert " by the rule:\n\t(" | |
700 | (mapconcat (lambda (x) | |
701 | (format (if (consp x) "%S" "?%c") x)) | |
702 | (nth 2 composition) | |
703 | " ") | |
704 | ")") | |
705 | (insert "\nThe component character(s) are displayed by ") | |
706 | (if (display-graphic-p (selected-frame)) | |
707 | (progn | |
708 | (insert "these fonts (glyph codes):") | |
709 | (dolist (elt component-chars) | |
710 | (insert "\n " (car elt) ?: | |
711 | (propertize " " 'display '(space :align-to 5)) | |
712 | (if (cdr elt) | |
9f40939d | 713 | (format "%s (#x%02X)" (cadr elt) (cddr elt)) |
f15078e2 KH |
714 | "-- no font --")))) |
715 | (insert "these terminal codes:") | |
716 | (dolist (elt component-chars) | |
717 | (insert "\n " (car elt) ":" | |
718 | (propertize " " 'display '(space :align-to 5)) | |
719 | (or (cdr elt) "-- not encodable --")))) | |
720 | (insert "\nSee the variable `reference-point-alist' for " | |
721 | "the meaning of the rule.\n")) | |
4adb7c09 | 722 | |
6482d093 | 723 | (describe-text-properties pos (current-buffer)) |
02f32cf0 | 724 | (describe-text-mode))))) |
2a1e884e | 725 | |
831ccfa6 | 726 | (defalias 'describe-char-after 'describe-char) |
fedbc8e5 | 727 | (make-obsolete 'describe-char-after 'describe-char "22.1") |
831ccfa6 | 728 | |
288395a7 CW |
729 | (provide 'descr-text) |
730 | ||
d8ac3d27 | 731 | ;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1 |
2a1e884e | 732 | ;;; descr-text.el ends here |