Mercurial > emacs
annotate lisp/descr-text.el @ 88346:3be7f212f8bc
*** empty log message ***
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Fri, 27 Apr 2007 21:33:38 +0000 |
parents | d7ddb3e565de |
children |
rev | line source |
---|---|
45057 | 1 ;;; descr-text.el --- describe text mode |
45022 | 2 |
88155 | 3 ;; Copyright (C) 1994, 1995, 1996, 2001, 2002, 2003, 2004, |
4 ;; 2005 Free Software Foundation, Inc. | |
45022 | 5 |
6 ;; Author: Boris Goldowsky <boris@gnu.org> | |
88155 | 7 ;; Maintainer: FSF |
8 ;; Keywords: faces, i18n, Unicode, multilingual | |
45022 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;; any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
88155 | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02110-1301, USA. | |
45022 | 26 |
27 ;;; Commentary: | |
28 | |
29 ;;; Describe-Text Mode. | |
30 | |
31 ;;; Code: | |
32 | |
88155 | 33 (eval-when-compile (require 'quail)) |
34 (require 'help-fns) | |
45022 | 35 |
36 ;;; Describe-Text Utilities. | |
37 | |
38 (defun describe-text-widget (widget) | |
39 "Insert text to describe WIDGET in the current buffer." | |
88155 | 40 (insert-text-button |
41 (symbol-name (if (symbolp widget) widget (car widget))) | |
42 'action `(lambda (&rest ignore) | |
43 (widget-browse ',widget)) | |
44 'help-echo "mouse-2, RET: browse this widget") | |
45 (insert " ") | |
46 (insert-text-button | |
47 "(widget)Top" 'type 'help-info 'help-args '("(widget)Top"))) | |
45022 | 48 |
49 (defun describe-text-sexp (sexp) | |
50 "Insert a short description of SEXP in the current buffer." | |
51 (let ((pp (condition-case signal | |
52 (pp-to-string sexp) | |
53 (error (prin1-to-string signal))))) | |
54 (when (string-match "\n\\'" pp) | |
55 (setq pp (substring pp 0 (1- (length pp))))) | |
56 (if (cond ((string-match "\n" pp) | |
57 nil) | |
58 ((> (length pp) (- (window-width) (current-column))) | |
59 nil) | |
60 (t t)) | |
88155 | 61 (insert pp) |
62 (insert-text-button | |
63 "[Show]" 'action `(lambda (&rest ignore) | |
64 (with-output-to-temp-buffer | |
65 "*Pp Eval Output*" | |
66 (princ ',pp))) | |
67 'help-echo "mouse-2, RET: pretty print value in another buffer")))) | |
45022 | 68 |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
69 (defun describe-property-list (properties) |
45022 | 70 "Insert a description of PROPERTIES in the current buffer. |
71 PROPERTIES should be a list of overlay or text properties. | |
88155 | 72 The `category', `face' and `font-lock-face' properties are made |
73 into help buttons that call `describe-text-category' or | |
74 `describe-face' when pushed." | |
45697
234b16d90545
(describe-text-properties): Sort the output by the size of the values.
Colin Walters <walters@gnu.org>
parents:
45057
diff
changeset
|
75 ;; Sort the properties by the size of their value. |
88155 | 76 (dolist (elt (sort (let (ret) |
45697
234b16d90545
(describe-text-properties): Sort the output by the size of the values.
Colin Walters <walters@gnu.org>
parents:
45057
diff
changeset
|
77 (while properties |
88155 | 78 (push (list (pop properties) (pop properties)) ret)) |
45697
234b16d90545
(describe-text-properties): Sort the output by the size of the values.
Colin Walters <walters@gnu.org>
parents:
45057
diff
changeset
|
79 ret) |
88155 | 80 (lambda (a b) (string< (prin1-to-string (nth 0 a) t) |
81 (prin1-to-string (nth 0 b) t))))) | |
45697
234b16d90545
(describe-text-properties): Sort the output by the size of the values.
Colin Walters <walters@gnu.org>
parents:
45057
diff
changeset
|
82 (let ((key (nth 0 elt)) |
234b16d90545
(describe-text-properties): Sort the output by the size of the values.
Colin Walters <walters@gnu.org>
parents:
45057
diff
changeset
|
83 (value (nth 1 elt))) |
88155 | 84 (insert (propertize (format " %-20s " key) |
85 'face 'help-argument-name)) | |
45022 | 86 (cond ((eq key 'category) |
88155 | 87 (insert-text-button |
88 (symbol-name value) | |
89 'action `(lambda (&rest ignore) | |
90 (describe-text-category ',value)) | |
91 'help-echo "mouse-2, RET: describe this category")) | |
92 ((memq key '(face font-lock-face mouse-face)) | |
93 (insert-text-button | |
94 (format "%S" value) | |
95 'type 'help-face 'help-args (list value))) | |
96 ((widgetp value) | |
45022 | 97 (describe-text-widget value)) |
98 (t | |
88155 | 99 (describe-text-sexp value)))) |
100 (insert "\n"))) | |
45022 | 101 |
102 ;;; Describe-Text Commands. | |
103 | |
104 (defun describe-text-category (category) | |
105 "Describe a text property category." | |
88155 | 106 (interactive "SCategory: ") |
107 (help-setup-xref (list #'describe-text-category category) (interactive-p)) | |
45022 | 108 (save-excursion |
47601
7d00d911e8b9
(describe-text-category): Use *Help*. Don't kill-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
47379
diff
changeset
|
109 (with-output-to-temp-buffer "*Help*" |
7d00d911e8b9
(describe-text-category): Use *Help*. Don't kill-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
47379
diff
changeset
|
110 (set-buffer standard-output) |
88155 | 111 (insert "Category " (format "%S" category) ":\n\n") |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
112 (describe-property-list (symbol-plist category)) |
45022 | 113 (goto-char (point-min))))) |
114 | |
115 ;;;###autoload | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
116 (defun describe-text-properties (pos &optional output-buffer) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
117 "Describe widgets, buttons, overlays and text properties at POS. |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
118 Interactively, describe them for the character after point. |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
119 If optional second argument OUTPUT-BUFFER is non-nil, |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
120 insert the output into that buffer, and don't initialize or clear it |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
121 otherwise." |
45022 | 122 (interactive "d") |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
123 (if (>= pos (point-max)) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
124 (error "No character follows specified position")) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
125 (if output-buffer |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
126 (describe-text-properties-1 pos output-buffer) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
127 (if (not (or (text-properties-at pos) (overlays-at pos))) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
128 (message "This is plain text.") |
88155 | 129 (let ((buffer (current-buffer)) |
130 (target-buffer "*Help*")) | |
131 (when (eq buffer (get-buffer target-buffer)) | |
132 (setq target-buffer "*Help*<2>")) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
133 (save-excursion |
88155 | 134 (with-output-to-temp-buffer target-buffer |
47601
7d00d911e8b9
(describe-text-category): Use *Help*. Don't kill-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
47379
diff
changeset
|
135 (set-buffer standard-output) |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
136 (setq output-buffer (current-buffer)) |
88155 | 137 (insert "Text content at position " (format "%d" pos) ":\n\n") |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
138 (with-current-buffer buffer |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
139 (describe-text-properties-1 pos output-buffer)) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
140 (goto-char (point-min)))))))) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
141 |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
142 (defun describe-text-properties-1 (pos output-buffer) |
45022 | 143 (let* ((properties (text-properties-at pos)) |
144 (overlays (overlays-at pos)) | |
145 (wid-field (get-char-property pos 'field)) | |
146 (wid-button (get-char-property pos 'button)) | |
147 (wid-doc (get-char-property pos 'widget-doc)) | |
148 ;; If button.el is not loaded, we have no buttons in the text. | |
149 (button (and (fboundp 'button-at) (button-at pos))) | |
150 (button-type (and button (button-type button))) | |
151 (button-label (and button (button-label button))) | |
152 (widget (or wid-field wid-button wid-doc))) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
153 (with-current-buffer output-buffer |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
154 ;; Widgets |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
155 (when (widgetp widget) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
156 (newline) |
88155 | 157 (insert (cond (wid-field "This is an editable text area") |
158 (wid-button "This is an active area") | |
159 (wid-doc "This is documentation text"))) | |
160 (insert " of a ") | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
161 (describe-text-widget widget) |
88155 | 162 (insert ".\n\n")) |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
163 ;; Buttons |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
164 (when (and button (not (widgetp wid-button))) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
165 (newline) |
88155 | 166 (insert "Here is a `" (format "%S" button-type) |
167 "' button labeled `" button-label "'.\n\n")) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
168 ;; Overlays |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
169 (when overlays |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
170 (newline) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
171 (if (eq (length overlays) 1) |
88155 | 172 (insert "There is an overlay here:\n") |
173 (insert "There are " (format "%d" (length overlays)) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
174 " overlays here:\n")) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
175 (dolist (overlay overlays) |
88155 | 176 (insert " From " (format "%d" (overlay-start overlay)) |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
177 " to " (format "%d" (overlay-end overlay)) "\n") |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
178 (describe-property-list (overlay-properties overlay))) |
88155 | 179 (insert "\n")) |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
180 ;; Text properties |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
181 (when properties |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
182 (newline) |
88155 | 183 (insert "There are text properties here:\n") |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
184 (describe-property-list properties))))) |
88155 | 185 |
186 (defcustom describe-char-unicodedata-file nil | |
187 "Location of Unicode data file. | |
188 This is the UnicodeData.txt file from the Unicode consortium, used for | |
189 diagnostics. If it is non-nil `describe-char' will print data | |
190 looked up from it. This facility is mostly of use to people doing | |
191 multilingual development. | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
192 |
88155 | 193 This is a fairly large file, not typically present on GNU systems. At |
194 the time of writing it is at the URL | |
195 `http://www.unicode.org/Public/UNIDATA/UnicodeData.txt'." | |
196 :group 'mule | |
197 :version "22.1" | |
198 :type '(choice (const :tag "None" nil) | |
199 file)) | |
200 | |
201 ;; We could convert the unidata file into a Lispy form once-for-all | |
202 ;; and distribute it for loading on demand. It might be made more | |
203 ;; space-efficient by splitting strings word-wise and replacing them | |
204 ;; with lists of symbols interned in a private obarray, e.g. | |
205 ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A). | |
206 | |
207 ;; Fixme: Check whether this needs updating for Unicode 4. | |
208 (defun describe-char-unicode-data (char) | |
209 "Return a list of Unicode data for unicode CHAR. | |
210 Each element is a list of a property description and the property value. | |
211 The list is null if CHAR isn't found in `describe-char-unicodedata-file'." | |
212 (when describe-char-unicodedata-file | |
213 (unless (file-exists-p describe-char-unicodedata-file) | |
214 (error "`unicodedata-file' %s not found" describe-char-unicodedata-file)) | |
215 (with-current-buffer | |
216 ;; Find file in fundamental mode to avoid, e.g. flyspell turned | |
217 ;; on for .txt. Don't use RAWFILE arg in case of DOS line endings. | |
218 (let ((auto-mode-alist)) | |
219 (find-file-noselect describe-char-unicodedata-file)) | |
220 (goto-char (point-min)) | |
221 (let ((hex (format "%04X" char)) | |
222 found first last) | |
223 (if (re-search-forward (concat "^" hex) nil t) | |
224 (setq found t) | |
225 ;; It's not listed explicitly. Look for ranges, e.g. CJK | |
226 ;; ideographs, and check whether it's in one of them. | |
227 (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t) | |
228 (>= char (setq first | |
229 (string-to-number (match-string 1) 16))) | |
230 (progn | |
231 (forward-line 1) | |
232 (looking-at "^\\([^;]+\\);[^;]+Last>;") | |
233 (> char | |
234 (setq last | |
235 (string-to-number (match-string 1) 16)))))) | |
236 (if (and (>= char first) | |
237 (<= char last)) | |
238 (setq found t))) | |
239 (if found | |
240 (let ((fields (mapcar (lambda (elt) | |
241 (if (> (length elt) 0) | |
242 elt)) | |
243 (cdr (split-string | |
244 (buffer-substring | |
245 (line-beginning-position) | |
246 (line-end-position)) | |
247 ";"))))) | |
248 ;; The length depends on whether the last field was empty. | |
249 (unless (or (= 13 (length fields)) | |
250 (= 14 (length fields))) | |
251 (error "Invalid contents in %s" describe-char-unicodedata-file)) | |
252 ;; The field names and values lists are slightly | |
253 ;; modified from Mule-UCS unidata.el. | |
254 (list | |
255 (list "Name" (let ((name (nth 0 fields))) | |
256 ;; Check for <..., First>, <..., Last> | |
257 (if (string-match "\\`\\(<[^,]+\\)," name) | |
258 (concat (match-string 1 name) ">") | |
259 name))) | |
260 (list "Category" | |
261 (cdr (assoc | |
262 (nth 1 fields) | |
263 '(("Lu" . "uppercase letter") | |
264 ("Ll" . "lowercase letter") | |
265 ("Lt" . "titlecase letter") | |
266 ("Mn" . "non-spacing mark") | |
267 ("Mc" . "spacing-combining mark") | |
268 ("Me" . "enclosing mark") | |
269 ("Nd" . "decimal digit") | |
270 ("Nl" . "letter number") | |
271 ("No" . "other number") | |
272 ("Zs" . "space separator") | |
273 ("Zl" . "line separator") | |
274 ("Zp" . "paragraph separator") | |
275 ("Cc" . "other control") | |
276 ("Cf" . "other format") | |
277 ("Cs" . "surrogate") | |
278 ("Co" . "private use") | |
279 ("Cn" . "not assigned") | |
280 ("Lm" . "modifier letter") | |
281 ("Lo" . "other letter") | |
282 ("Pc" . "connector punctuation") | |
283 ("Pd" . "dash punctuation") | |
284 ("Ps" . "open punctuation") | |
285 ("Pe" . "close punctuation") | |
286 ("Pi" . "initial-quotation punctuation") | |
287 ("Pf" . "final-quotation punctuation") | |
288 ("Po" . "other punctuation") | |
289 ("Sm" . "math symbol") | |
290 ("Sc" . "currency symbol") | |
291 ("Sk" . "modifier symbol") | |
292 ("So" . "other symbol"))))) | |
293 (list "Combining class" | |
294 (cdr (assoc | |
295 (string-to-number (nth 2 fields)) | |
296 '((0 . "Spacing") | |
297 (1 . "Overlays and interior") | |
298 (7 . "Nuktas") | |
299 (8 . "Hiragana/Katakana voicing marks") | |
300 (9 . "Viramas") | |
301 (10 . "Start of fixed position classes") | |
302 (199 . "End of fixed position classes") | |
303 (200 . "Below left attached") | |
304 (202 . "Below attached") | |
305 (204 . "Below right attached") | |
306 (208 . "Left attached (reordrant around \ | |
307 single base character)") | |
308 (210 . "Right attached") | |
309 (212 . "Above left attached") | |
310 (214 . "Above attached") | |
311 (216 . "Above right attached") | |
312 (218 . "Below left") | |
313 (220 . "Below") | |
314 (222 . "Below right") | |
315 (224 . "Left (reordrant around single base \ | |
316 character)") | |
317 (226 . "Right") | |
318 (228 . "Above left") | |
319 (230 . "Above") | |
320 (232 . "Above right") | |
321 (233 . "Double below") | |
322 (234 . "Double above") | |
323 (240 . "Below (iota subscript)"))))) | |
324 (list "Bidi category" | |
325 (cdr (assoc | |
326 (nth 3 fields) | |
327 '(("L" . "Left-to-Right") | |
328 ("LRE" . "Left-to-Right Embedding") | |
329 ("LRO" . "Left-to-Right Override") | |
330 ("R" . "Right-to-Left") | |
331 ("AL" . "Right-to-Left Arabic") | |
332 ("RLE" . "Right-to-Left Embedding") | |
333 ("RLO" . "Right-to-Left Override") | |
334 ("PDF" . "Pop Directional Format") | |
335 ("EN" . "European Number") | |
336 ("ES" . "European Number Separator") | |
337 ("ET" . "European Number Terminator") | |
338 ("AN" . "Arabic Number") | |
339 ("CS" . "Common Number Separator") | |
340 ("NSM" . "Non-Spacing Mark") | |
341 ("BN" . "Boundary Neutral") | |
342 ("B" . "Paragraph Separator") | |
343 ("S" . "Segment Separator") | |
344 ("WS" . "Whitespace") | |
345 ("ON" . "Other Neutrals"))))) | |
346 (list | |
347 "Decomposition" | |
348 (if (nth 4 fields) | |
349 (let* ((parts (split-string (nth 4 fields))) | |
350 (info (car parts))) | |
351 (if (string-match "\\`<\\(.+\\)>\\'" info) | |
352 (setq info (match-string 1 info)) | |
353 (setq info nil)) | |
354 (if info (setq parts (cdr parts))) | |
355 ;; Maybe printing ? for unrepresentable unicodes | |
356 ;; here and below should be changed? | |
357 (setq parts (mapconcat | |
358 (lambda (arg) | |
359 (string (or (decode-char | |
360 'ucs | |
361 (string-to-number arg 16)) | |
362 ??))) | |
363 parts " ")) | |
364 (concat info parts)))) | |
365 (list "Decimal digit value" | |
366 (nth 5 fields)) | |
367 (list "Digit value" | |
368 (nth 6 fields)) | |
369 (list "Numeric value" | |
370 (nth 7 fields)) | |
371 (list "Mirrored" | |
372 (if (equal "Y" (nth 8 fields)) | |
373 "yes")) | |
374 (list "Old name" (nth 9 fields)) | |
375 (list "ISO 10646 comment" (nth 10 fields)) | |
376 (list "Uppercase" (and (nth 11 fields) | |
377 (string (or (decode-char | |
378 'ucs | |
379 (string-to-number | |
380 (nth 11 fields) 16)) | |
381 ??)))) | |
382 (list "Lowercase" (and (nth 12 fields) | |
383 (string (or (decode-char | |
384 'ucs | |
385 (string-to-number | |
386 (nth 12 fields) 16)) | |
387 ??)))) | |
388 (list "Titlecase" (and (nth 13 fields) | |
389 (string (or (decode-char | |
390 'ucs | |
391 (string-to-number | |
392 (nth 13 fields) 16)) | |
393 ??))))))))))) | |
394 | |
395 ;; Return information about how CHAR is displayed at the buffer | |
396 ;; position POS. If the selected frame is on a graphic display, | |
397 ;; return a cons (FONTNAME . GLYPH-CODE). Otherwise, return a string | |
398 ;; describing the terminal codes for the character. | |
399 (defun describe-char-display (pos char) | |
400 (if (display-graphic-p (selected-frame)) | |
401 (internal-char-font pos char) | |
402 (let* ((coding (terminal-coding-system)) | |
403 (encoded (encode-coding-char char coding))) | |
404 (if encoded | |
405 (encoded-string-description encoded coding))))) | |
406 | |
407 | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
408 ;;;###autoload |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
409 (defun describe-char (pos) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
410 "Describe the character after POS (interactively, the character after point). |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
411 The information includes character code, charset and code points in it, |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
412 syntax, category, how the character is encoded in a file, |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
413 character composition information (if relevant), |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
414 as well as widgets, buttons, overlays, and text properties." |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
415 (interactive "d") |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
416 (if (>= pos (point-max)) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
417 (error "No character follows specified position")) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
418 (let* ((char (char-after pos)) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
419 (charset (char-charset char)) |
47601
7d00d911e8b9
(describe-text-category): Use *Help*. Don't kill-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
47379
diff
changeset
|
420 (composition (find-composition pos nil nil t)) |
88155 | 421 (component-chars nil) |
422 (display-table (or (window-display-table) | |
423 buffer-display-table | |
424 standard-display-table)) | |
425 (disp-vector (and display-table (aref display-table char))) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
426 (multibyte-p enable-multibyte-characters) |
88155 | 427 (overlays (mapcar #'(lambda (o) (overlay-properties o)) |
428 (overlays-at pos))) | |
429 (char-description (if (not multibyte-p) | |
430 (single-key-description char) | |
431 (if (< char 128) | |
432 (single-key-description char) | |
433 (string-to-multibyte | |
434 (char-to-string char))))) | |
435 (text-props-desc | |
436 (let ((tmp-buf (generate-new-buffer " *text-props*"))) | |
437 (unwind-protect | |
438 (progn | |
439 (describe-text-properties pos tmp-buf) | |
440 (with-current-buffer tmp-buf (buffer-string))) | |
441 (kill-buffer tmp-buf)))) | |
442 item-list max-width unicode) | |
443 | |
444 (if (or (< char 256) | |
445 (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos))) | |
446 (get-char-property pos 'untranslated-utf-8)) | |
447 (setq unicode (or (get-char-property pos 'untranslated-utf-8) | |
448 (encode-char char 'ucs)))) | |
449 (setq item-list | |
450 `(("character" | |
451 ,(format "%s (%d, #o%o, #x%x%s)" | |
452 (apply 'propertize char-description | |
453 (text-properties-at pos)) | |
454 char char char | |
455 (if unicode | |
456 (format ", U+%04X" unicode) | |
457 ""))) | |
458 ("charset" | |
459 ,`(insert-text-button | |
460 ,(symbol-name charset) | |
461 'type 'help-character-set 'help-args '(,charset)) | |
462 ,(format "(%s)" (charset-description charset))) | |
463 ("code point" | |
464 ,(let ((split (split-char char))) | |
465 `(insert-text-button | |
466 ,(if (= (charset-dimension charset) 1) | |
467 (format "#x%02X" (nth 1 split)) | |
468 (format "#x%02X #x%02X" (nth 1 split) | |
469 (nth 2 split))) | |
470 'action (lambda (&rest ignore) | |
471 (list-charset-chars ',charset) | |
472 (with-selected-window | |
473 (get-buffer-window "*Character List*" 0) | |
474 (goto-char (point-min)) | |
475 (forward-line 2) ;Skip the header. | |
476 (let ((case-fold-search nil)) | |
477 (search-forward ,(char-to-string char) | |
478 nil t)))) | |
479 'help-echo | |
480 "mouse-2, RET: show this character in its character set"))) | |
481 ("syntax" | |
482 ,(let ((syntax (syntax-after pos))) | |
483 (with-temp-buffer | |
484 (internal-describe-syntax-value syntax) | |
485 (buffer-string)))) | |
486 ("category" | |
487 ,@(let ((category-set (char-category-set char))) | |
488 (if (not category-set) | |
489 '("-- none --") | |
490 (mapcar #'(lambda (x) (format "%c:%s" | |
491 x (category-docstring x))) | |
492 (category-set-mnemonics category-set))))) | |
493 ,@(let ((props (aref char-code-property-table char)) | |
494 ps) | |
495 (when props | |
496 (while props | |
497 (push (format "%s:" (pop props)) ps) | |
498 (push (format "%s;" (pop props)) ps)) | |
499 (list (cons "Properties" (nreverse ps))))) | |
500 ("to input" | |
501 ,@(let ((key-list (and (eq input-method-function | |
502 'quail-input-method) | |
503 (quail-find-key char)))) | |
504 (if (consp key-list) | |
505 (list "type" | |
506 (mapconcat #'(lambda (x) (concat "\"" x "\"")) | |
507 key-list " or ") | |
508 "with" | |
509 `(insert-text-button | |
510 ,current-input-method | |
511 'type 'help-input-method | |
512 'help-args '(,current-input-method)))))) | |
513 ("buffer code" | |
514 ,(encoded-string-description | |
515 (string-as-unibyte (char-to-string char)) nil)) | |
516 ("file code" | |
517 ,@(let* ((coding buffer-file-coding-system) | |
518 (encoded (encode-coding-char char coding))) | |
519 (if encoded | |
520 (list (encoded-string-description encoded coding) | |
521 (format "(encoded by coding system %S)" coding)) | |
522 (list "not encodable by coding system" | |
523 (symbol-name coding))))) | |
524 ("display" | |
525 ,(cond | |
526 (disp-vector | |
527 (setq disp-vector (copy-sequence disp-vector)) | |
528 (dotimes (i (length disp-vector)) | |
529 (setq char (aref disp-vector i)) | |
530 (aset disp-vector i | |
531 (cons char (describe-char-display | |
532 pos (logand char #x7ffff))))) | |
533 (format "by display table entry [%s] (see below)" | |
534 (mapconcat | |
535 #'(lambda (x) | |
536 (format "?%c" (logand (car x) #x7ffff))) | |
537 disp-vector " "))) | |
538 (composition | |
539 (let ((from (car composition)) | |
540 (to (nth 1 composition)) | |
541 (next (1+ pos)) | |
542 (components (nth 2 composition)) | |
543 ch) | |
544 (setcar composition | |
545 (and (< from pos) (buffer-substring from pos))) | |
546 (setcar (cdr composition) | |
547 (and (< next to) (buffer-substring next to))) | |
548 (dotimes (i (length components)) | |
549 (if (integerp (setq ch (aref components i))) | |
550 (push (cons ch (describe-char-display pos ch)) | |
551 component-chars))) | |
552 (setq component-chars (nreverse component-chars)) | |
553 (format "composed to form \"%s\" (see below)" | |
554 (buffer-substring from to)))) | |
555 (t | |
556 (let ((display (describe-char-display pos char))) | |
557 (if (display-graphic-p (selected-frame)) | |
558 (if display | |
559 (concat | |
560 "by this font (glyph code)\n" | |
561 (format " %s (#x%02X)" | |
562 (car display) (cdr display))) | |
563 "no font available") | |
564 (if display | |
565 (format "terminal code %s" display) | |
566 "not encodable for terminal")))))) | |
567 ,@(let ((face | |
568 (if (not (or disp-vector composition)) | |
569 (cond | |
570 ((and show-trailing-whitespace | |
571 (save-excursion (goto-char pos) | |
572 (looking-at "[ \t]+$"))) | |
573 'trailing-whitespace) | |
574 ((and nobreak-char-display unicode (eq unicode '#xa0)) | |
575 'nobreak-space) | |
576 ((and nobreak-char-display unicode (eq unicode '#xad)) | |
577 'escape-glyph) | |
578 ((and (< char 32) (not (memq char '(9 10)))) | |
579 'escape-glyph))))) | |
580 (if face (list (list "hardcoded face" | |
581 `(insert-text-button | |
582 ,(symbol-name face) | |
583 'type 'help-face 'help-args '(,face)))))) | |
584 ,@(let ((unicodedata (and unicode | |
585 (describe-char-unicode-data unicode)))) | |
586 (if unicodedata | |
587 (cons (list "Unicode data" " ") unicodedata))))) | |
588 (setq max-width (apply #'max (mapcar #'(lambda (x) | |
589 (if (cadr x) (length (car x)) 0)) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
590 item-list))) |
88155 | 591 (help-setup-xref nil (interactive-p)) |
592 (with-output-to-temp-buffer (help-buffer) | |
47601
7d00d911e8b9
(describe-text-category): Use *Help*. Don't kill-buffer.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
47379
diff
changeset
|
593 (with-current-buffer standard-output |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
594 (set-buffer-multibyte multibyte-p) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
595 (let ((formatter (format "%%%ds:" max-width))) |
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
596 (dolist (elt item-list) |
88155 | 597 (when (cadr elt) |
598 (insert (format formatter (car elt))) | |
599 (dolist (clm (cdr elt)) | |
600 (if (eq (car-safe clm) 'insert-text-button) | |
601 (progn (insert " ") (eval clm)) | |
602 (when (>= (+ (current-column) | |
603 (or (string-match "\n" clm) | |
604 (string-width clm)) | |
605 1) | |
606 (window-width)) | |
607 (insert "\n") | |
608 (indent-to (1+ max-width))) | |
609 (insert " " clm))) | |
610 (insert "\n")))) | |
611 | |
612 (when overlays | |
613 (save-excursion | |
614 (goto-char (point-min)) | |
615 (re-search-forward "character:[ \t\n]+") | |
616 (let* ((end (+ (point) (length char-description)))) | |
617 (mapc #'(lambda (props) | |
618 (let ((o (make-overlay (point) end))) | |
619 (while props | |
620 (overlay-put o (car props) (nth 1 props)) | |
621 (setq props (cddr props))))) | |
622 overlays)))) | |
623 | |
624 (when disp-vector | |
625 (insert | |
626 "\nThe display table entry is displayed by ") | |
627 (if (display-graphic-p (selected-frame)) | |
628 (progn | |
629 (insert "these fonts (glyph codes):\n") | |
630 (dotimes (i (length disp-vector)) | |
631 (insert (logand (car (aref disp-vector i)) #x7ffff) ?: | |
632 (propertize " " 'display '(space :align-to 5)) | |
633 (if (cdr (aref disp-vector i)) | |
634 (format "%s (#x%02X)" (cadr (aref disp-vector i)) | |
635 (cddr (aref disp-vector i))) | |
636 "-- no font --") | |
637 "\n") | |
638 (when (> (car (aref disp-vector i)) #x7ffff) | |
639 (let* ((face-id (lsh (car (aref disp-vector i)) -19)) | |
640 (face (car (delq nil (mapcar | |
641 (lambda (face) | |
642 (and (eq (face-id face) | |
643 face-id) face)) | |
644 (face-list)))))) | |
645 (when face | |
646 (insert (propertize " " 'display '(space :align-to 5)) | |
647 "face: ") | |
648 (insert (concat "`" (symbol-name face) "'")) | |
649 (insert "\n")))))) | |
650 (insert "these terminal codes:\n") | |
651 (dotimes (i (length disp-vector)) | |
652 (insert (car (aref disp-vector i)) | |
653 (propertize " " 'display '(space :align-to 5)) | |
654 (or (cdr (aref disp-vector i)) "-- not encodable --") | |
655 "\n")))) | |
656 | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
657 (when composition |
88155 | 658 (insert "\nComposed") |
659 (if (car composition) | |
660 (if (cadr composition) | |
661 (insert " with the surrounding characters \"" | |
662 (car composition) "\" and \"" | |
663 (cadr composition) "\"") | |
664 (insert " with the preceding character(s) \"" | |
665 (car composition) "\"")) | |
666 (if (cadr composition) | |
667 (insert " with the following character(s) \"" | |
668 (cadr composition) "\""))) | |
669 (insert " by the rule:\n\t(" | |
670 (mapconcat (lambda (x) | |
671 (format (if (consp x) "%S" "?%c") x)) | |
672 (nth 2 composition) | |
673 " ") | |
674 ")") | |
675 (insert "\nThe component character(s) are displayed by ") | |
676 (if (display-graphic-p (selected-frame)) | |
677 (progn | |
678 (insert "these fonts (glyph codes):") | |
679 (dolist (elt component-chars) | |
680 (insert "\n " (car elt) ?: | |
681 (propertize " " 'display '(space :align-to 5)) | |
682 (if (cdr elt) | |
683 (format "%s (#x%02X)" (cadr elt) (cddr elt)) | |
684 "-- no font --")))) | |
685 (insert "these terminal codes:") | |
686 (dolist (elt component-chars) | |
687 (insert "\n " (car elt) ":" | |
688 (propertize " " 'display '(space :align-to 5)) | |
689 (or (cdr elt) "-- not encodable --")))) | |
690 (insert "\nSee the variable `reference-point-alist' for " | |
691 "the meaning of the rule.\n")) | |
49588
37645a051842
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49398
diff
changeset
|
692 |
88155 | 693 (if text-props-desc (insert text-props-desc)) |
694 (setq help-xref-stack-item (list 'help-insert-string (buffer-string))) | |
695 (toggle-read-only 1) | |
696 (print-help-return-message))))) | |
45868
97041c98624e
(describe-char): Moved from mule-diag.el, renamed
Richard M. Stallman <rms@gnu.org>
parents:
45700
diff
changeset
|
697 |
88155 | 698 (defalias 'describe-char-after 'describe-char) |
699 (make-obsolete 'describe-char-after 'describe-char "22.1") | |
45022 | 700 |
45700
a54155344566
(toplevel): Provide `descr-text'.
Colin Walters <walters@gnu.org>
parents:
45697
diff
changeset
|
701 (provide 'descr-text) |
a54155344566
(toplevel): Provide `descr-text'.
Colin Walters <walters@gnu.org>
parents:
45697
diff
changeset
|
702 |
88155 | 703 ;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1 |
45022 | 704 ;;; descr-text.el ends here |