35 |
(delete-window) |
(delete-window) |
36 |
(bury-buffer))) |
(bury-buffer))) |
37 |
|
|
38 |
(defvar describe-text-mode-map |
(defvar describe-text-mode-map |
39 |
(let ((map (make-sparse-keymap))) |
(let ((map (make-sparse-keymap))) |
40 |
(set-keymap-parent map widget-keymap) |
(set-keymap-parent map widget-keymap) |
41 |
map) |
map) |
42 |
"Keymap for `describe-text-mode'.") |
"Keymap for `describe-text-mode'.") |
43 |
|
|
44 |
(defcustom describe-text-mode-hook nil |
(defcustom describe-text-mode-hook nil |
45 |
"List of hook functions ran by `describe-text-mode'." |
"List of hook functions ran by `describe-text-mode'." |
46 |
:type 'hook) |
:type 'hook |
47 |
|
:group 'facemenu) |
48 |
|
|
49 |
(defun describe-text-mode () |
(defun describe-text-mode () |
50 |
"Major mode for buffers created by `describe-text-at'. |
"Major mode for buffers created by `describe-char'. |
51 |
|
|
52 |
\\{describe-text-mode-map} |
\\{describe-text-mode-map} |
53 |
Entry to this mode calls the value of `describe-text-mode-hook' |
Entry to this mode calls the value of `describe-text-mode-hook' |
57 |
mode-name "Describe-Text") |
mode-name "Describe-Text") |
58 |
(use-local-map describe-text-mode-map) |
(use-local-map describe-text-mode-map) |
59 |
(widget-setup) |
(widget-setup) |
60 |
|
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t) |
61 |
(run-hooks 'describe-text-mode-hook)) |
(run-hooks 'describe-text-mode-hook)) |
62 |
|
|
63 |
;;; Describe-Text Utilities. |
;;; Describe-Text Utilities. |
67 |
(widget-create 'link |
(widget-create 'link |
68 |
:notify `(lambda (&rest ignore) |
:notify `(lambda (&rest ignore) |
69 |
(widget-browse ',widget)) |
(widget-browse ',widget)) |
70 |
(format "%S" (if (symbolp widget) |
(format "%S" (if (symbolp widget) |
71 |
widget |
widget |
72 |
(car widget)))) |
(car widget)))) |
73 |
(widget-insert " ") |
(widget-insert " ") |
94 |
(princ (widget-get widget :value)))) |
(princ (widget-get widget :value)))) |
95 |
pp)))) |
pp)))) |
96 |
|
|
97 |
(defun describe-text-properties (properties) |
(defun describe-property-list (properties) |
98 |
"Insert a description of PROPERTIES in the current buffer. |
"Insert a description of PROPERTIES in the current buffer. |
99 |
PROPERTIES should be a list of overlay or text properties. |
PROPERTIES should be a list of overlay or text properties. |
100 |
The `category' property is made into a widget button that call |
The `category' property is made into a widget button that call |
101 |
`describe-text-category' when pushed." |
`describe-text-category' when pushed." |
102 |
;; Sort the properties by the size of their value. |
;; Sort the properties by the size of their value. |
103 |
(dolist (elt (sort (let ((ret nil) |
(dolist (elt (sort (let ((ret nil) |
119 |
(nth 2 b))))) |
(nth 2 b))))) |
120 |
(let ((key (nth 0 elt)) |
(let ((key (nth 0 elt)) |
121 |
(value (nth 1 elt))) |
(value (nth 1 elt))) |
122 |
(widget-insert (propertize (format " %-20s" key) |
(widget-insert (propertize (format " %-20s " key) |
123 |
'font-lock-face 'italic)) |
'font-lock-face 'italic)) |
124 |
(cond ((eq key 'category) |
(cond ((eq key 'category) |
125 |
(widget-create 'link |
(widget-create 'link |
126 |
:notify `(lambda (&rest ignore) |
:notify `(lambda (&rest ignore) |
127 |
(describe-text-category ',value)) |
(describe-text-category ',value)) |
128 |
(format "%S" value))) |
(format "%S" value))) |
137 |
(defun describe-text-category (category) |
(defun describe-text-category (category) |
138 |
"Describe a text property category." |
"Describe a text property category." |
139 |
(interactive "S") |
(interactive "S") |
|
(when (get-buffer "*Text Category*") |
|
|
(kill-buffer "*Text Category*")) |
|
140 |
(save-excursion |
(save-excursion |
141 |
(with-output-to-temp-buffer "*Text Category*" |
(with-output-to-temp-buffer "*Help*" |
142 |
(set-buffer "*Text Category*") |
(set-buffer standard-output) |
143 |
(widget-insert "Category " (format "%S" category) ":\n\n") |
(widget-insert "Category " (format "%S" category) ":\n\n") |
144 |
(describe-text-properties (symbol-plist category)) |
(describe-property-list (symbol-plist category)) |
145 |
(describe-text-mode) |
(describe-text-mode) |
146 |
(goto-char (point-min))))) |
(goto-char (point-min))))) |
147 |
|
|
148 |
;;;###autoload |
;;;###autoload |
149 |
(defun describe-text-at (pos) |
(defun describe-text-properties (pos &optional output-buffer) |
150 |
"Describe widgets, buttons, overlays and text properties at POS." |
"Describe widgets, buttons, overlays and text properties at POS. |
151 |
|
Interactively, describe them for the character after point. |
152 |
|
If optional second argument OUTPUT-BUFFER is non-nil, |
153 |
|
insert the output into that buffer, and don't initialize or clear it |
154 |
|
otherwise." |
155 |
(interactive "d") |
(interactive "d") |
156 |
(when (eq (current-buffer) (get-buffer "*Text Description*")) |
(if (>= pos (point-max)) |
157 |
(error "Can't do self inspection")) |
(error "No character follows specified position")) |
158 |
|
(if output-buffer |
159 |
|
(describe-text-properties-1 pos output-buffer) |
160 |
|
(if (not (or (text-properties-at pos) (overlays-at pos))) |
161 |
|
(message "This is plain text.") |
162 |
|
(let ((buffer (current-buffer))) |
163 |
|
(when (eq buffer (get-buffer "*Help*")) |
164 |
|
(error "Can't do self inspection")) |
165 |
|
(save-excursion |
166 |
|
(with-output-to-temp-buffer "*Help*" |
167 |
|
(set-buffer standard-output) |
168 |
|
(setq output-buffer (current-buffer)) |
169 |
|
(widget-insert "Text content at position " (format "%d" pos) ":\n\n") |
170 |
|
(with-current-buffer buffer |
171 |
|
(describe-text-properties-1 pos output-buffer)) |
172 |
|
(describe-text-mode) |
173 |
|
(goto-char (point-min)))))))) |
174 |
|
|
175 |
|
(defun describe-text-properties-1 (pos output-buffer) |
176 |
(let* ((properties (text-properties-at pos)) |
(let* ((properties (text-properties-at pos)) |
177 |
(overlays (overlays-at pos)) |
(overlays (overlays-at pos)) |
178 |
overlay |
overlay |
184 |
(button-type (and button (button-type button))) |
(button-type (and button (button-type button))) |
185 |
(button-label (and button (button-label button))) |
(button-label (and button (button-label button))) |
186 |
(widget (or wid-field wid-button wid-doc))) |
(widget (or wid-field wid-button wid-doc))) |
187 |
(if (not (or properties overlays)) |
(with-current-buffer output-buffer |
188 |
(message "This is plain text.") |
;; Widgets |
189 |
(when (get-buffer "*Text Description*") |
(when (widgetp widget) |
190 |
(kill-buffer "*Text Description*")) |
(newline) |
191 |
(save-excursion |
(widget-insert (cond (wid-field "This is an editable text area") |
192 |
(with-output-to-temp-buffer "*Text Description*" |
(wid-button "This is an active area") |
193 |
(set-buffer "*Text Description*") |
(wid-doc "This is documentation text"))) |
194 |
(widget-insert "Text content at position " (format "%d" pos) ":\n\n") |
(widget-insert " of a ") |
195 |
;; Widgets |
(describe-text-widget widget) |
196 |
(when (widgetp widget) |
(widget-insert ".\n\n")) |
197 |
(widget-insert (cond (wid-field "This is an editable text area") |
;; Buttons |
198 |
(wid-button "This is an active area") |
(when (and button (not (widgetp wid-button))) |
199 |
(wid-doc "This is documentation text"))) |
(newline) |
200 |
(widget-insert " of a ") |
(widget-insert "Here is a " (format "%S" button-type) |
201 |
(describe-text-widget widget) |
" button labeled `" button-label "'.\n\n")) |
202 |
(widget-insert ".\n\n")) |
;; Overlays |
203 |
;; Buttons |
(when overlays |
204 |
(when (and button (not (widgetp wid-button))) |
(newline) |
205 |
(widget-insert "Here is a " (format "%S" button-type) |
(if (eq (length overlays) 1) |
206 |
" button labeled `" button-label "'.\n\n")) |
(widget-insert "There is an overlay here:\n") |
207 |
;; Overlays |
(widget-insert "There are " (format "%d" (length overlays)) |
208 |
(when overlays |
" overlays here:\n")) |
209 |
(if (eq (length overlays) 1) |
(dolist (overlay overlays) |
210 |
(widget-insert "There is an overlay here:\n") |
(widget-insert " From " (format "%d" (overlay-start overlay)) |
211 |
(widget-insert "There are " (format "%d" (length overlays)) |
" to " (format "%d" (overlay-end overlay)) "\n") |
212 |
" overlays here:\n")) |
(describe-property-list (overlay-properties overlay))) |
213 |
(dolist (overlay overlays) |
(widget-insert "\n")) |
214 |
(widget-insert " From " (format "%d" (overlay-start overlay)) |
;; Text properties |
215 |
" to " (format "%d" (overlay-end overlay)) "\n") |
(when properties |
216 |
(describe-text-properties (overlay-properties overlay))) |
(newline) |
217 |
(widget-insert "\n")) |
(widget-insert "There are text properties here:\n") |
218 |
;; Text properties |
(describe-property-list properties))))) |
219 |
(when properties |
|
220 |
(widget-insert "There are text properties here:\n") |
;;;###autoload |
221 |
(describe-text-properties properties)) |
(defun describe-char (pos) |
222 |
(describe-text-mode) |
"Describe the character after POS (interactively, the character after point). |
223 |
(goto-char (point-min))))))) |
The information includes character code, charset and code points in it, |
224 |
|
syntax, category, how the character is encoded in a file, |
225 |
|
character composition information (if relevant), |
226 |
|
as well as widgets, buttons, overlays, and text properties." |
227 |
|
(interactive "d") |
228 |
|
(if (>= pos (point-max)) |
229 |
|
(error "No character follows specified position")) |
230 |
|
(let* ((char (char-after pos)) |
231 |
|
(charset (char-charset char)) |
232 |
|
(buffer (current-buffer)) |
233 |
|
(composition (find-composition pos nil nil t)) |
234 |
|
(composed (if composition (buffer-substring (car composition) |
235 |
|
(nth 1 composition)))) |
236 |
|
(multibyte-p enable-multibyte-characters) |
237 |
|
item-list max-width) |
238 |
|
(if (eq charset 'unknown) |
239 |
|
(setq item-list |
240 |
|
`(("character" |
241 |
|
,(format "%s (0%o, %d, 0x%x) -- invalid character code" |
242 |
|
(if (< char 256) |
243 |
|
(single-key-description char) |
244 |
|
(char-to-string char)) |
245 |
|
char char char)))) |
246 |
|
(setq item-list |
247 |
|
`(("character" |
248 |
|
,(format "%s (0%o, %d, 0x%x)" (if (< char 256) |
249 |
|
(single-key-description char) |
250 |
|
(char-to-string char)) |
251 |
|
char char char)) |
252 |
|
("charset" |
253 |
|
,(symbol-name charset) |
254 |
|
,(format "(%s)" (charset-description charset))) |
255 |
|
("code point" |
256 |
|
,(let ((split (split-char char))) |
257 |
|
(if (= (charset-dimension charset) 1) |
258 |
|
(format "%d" (nth 1 split)) |
259 |
|
(format "%d %d" (nth 1 split) (nth 2 split))))) |
260 |
|
("syntax" |
261 |
|
,(let ((syntax (syntax-after pos))) |
262 |
|
(with-temp-buffer |
263 |
|
(internal-describe-syntax-value syntax) |
264 |
|
(buffer-string)))) |
265 |
|
("category" |
266 |
|
,@(let ((category-set (char-category-set char))) |
267 |
|
(if (not category-set) |
268 |
|
'("-- none --") |
269 |
|
(mapcar #'(lambda (x) (format "%c:%s " |
270 |
|
x (category-docstring x))) |
271 |
|
(category-set-mnemonics category-set))))) |
272 |
|
,@(let ((props (aref char-code-property-table char)) |
273 |
|
ps) |
274 |
|
(when props |
275 |
|
(while props |
276 |
|
(push (format "%s:" (pop props)) ps) |
277 |
|
(push (format "%s;" (pop props)) ps)) |
278 |
|
(list (cons "Properties" (nreverse ps))))) |
279 |
|
("buffer code" |
280 |
|
,(encoded-string-description |
281 |
|
(string-as-unibyte (char-to-string char)) nil)) |
282 |
|
("file code" |
283 |
|
,@(let* ((coding buffer-file-coding-system) |
284 |
|
(encoded (encode-coding-char char coding))) |
285 |
|
(if encoded |
286 |
|
(list (encoded-string-description encoded coding) |
287 |
|
(format "(encoded by coding system %S)" coding)) |
288 |
|
(list "not encodable by coding system" |
289 |
|
(symbol-name coding))))) |
290 |
|
,@(if (or (memq 'mule-utf-8 |
291 |
|
(find-coding-systems-region pos (1+ pos))) |
292 |
|
(get-char-property pos 'untranslated-utf-8)) |
293 |
|
(let ((uc (or (get-char-property pos 'untranslated-utf-8) |
294 |
|
(encode-char char 'ucs)))) |
295 |
|
(if uc |
296 |
|
(list (list "Unicode" |
297 |
|
(format "%04X" uc)))))) |
298 |
|
,(if (display-graphic-p (selected-frame)) |
299 |
|
(list "font" (or (internal-char-font pos) |
300 |
|
"-- none --")) |
301 |
|
(list "terminal code" |
302 |
|
(let* ((coding (terminal-coding-system)) |
303 |
|
(encoded (encode-coding-char char coding))) |
304 |
|
(if encoded |
305 |
|
(encoded-string-description encoded coding) |
306 |
|
"not encodable"))))))) |
307 |
|
(setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x))) |
308 |
|
item-list))) |
309 |
|
(when (eq (current-buffer) (get-buffer "*Help*")) |
310 |
|
(error "Can't do self inspection")) |
311 |
|
(with-output-to-temp-buffer "*Help*" |
312 |
|
(with-current-buffer standard-output |
313 |
|
(set-buffer-multibyte multibyte-p) |
314 |
|
(let ((formatter (format "%%%ds:" max-width))) |
315 |
|
(dolist (elt item-list) |
316 |
|
(insert (format formatter (car elt))) |
317 |
|
(dolist (clm (cdr elt)) |
318 |
|
(when (>= (+ (current-column) |
319 |
|
(or (string-match "\n" clm) |
320 |
|
(string-width clm)) 1) |
321 |
|
(frame-width)) |
322 |
|
(insert "\n") |
323 |
|
(indent-to (1+ max-width))) |
324 |
|
(insert " " clm)) |
325 |
|
(insert "\n"))) |
326 |
|
(when composition |
327 |
|
(insert "\nComposed with the " |
328 |
|
(cond |
329 |
|
((eq pos (car composition)) "following ") |
330 |
|
((eq (1+ pos) (cadr composition)) "preceding ") |
331 |
|
(t "")) |
332 |
|
"character(s) `" |
333 |
|
(cond |
334 |
|
((eq pos (car composition)) (substring composed 1)) |
335 |
|
((eq (1+ pos) (cadr composition)) (substring composed 0 -1)) |
336 |
|
(t (concat (substring composed 0 (- pos (car composition))) |
337 |
|
"' and `" |
338 |
|
(substring composed (- (1+ pos) (car composition)))))) |
339 |
|
|
340 |
|
"' to form `" composed "'") |
341 |
|
(if (nth 3 composition) |
342 |
|
(insert ".\n") |
343 |
|
(insert "\nby the rule (" |
344 |
|
(mapconcat (lambda (x) |
345 |
|
(format (if (consp x) "%S" "?%c") x)) |
346 |
|
(nth 2 composition) |
347 |
|
" ") |
348 |
|
").\n" |
349 |
|
"See the variable `reference-point-alist' for " |
350 |
|
"the meaning of the rule.\n"))) |
351 |
|
|
352 |
|
(let ((output (current-buffer))) |
353 |
|
(with-current-buffer buffer |
354 |
|
(describe-text-properties pos output)) |
355 |
|
(describe-text-mode)))))) |
356 |
|
|
357 |
(provide 'descr-text) |
(provide 'descr-text) |
358 |
|
|