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