Commit | Line | Data |
---|---|---|
dcb90b5f | 1 | ;;; descr-text.el --- describe text mode |
2a1e884e RS |
2 | |
3 | ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc. | |
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 | ||
31 | (defun describe-text-done () | |
32 | "Delete the current window or bury the current buffer." | |
33 | (interactive) | |
34 | (if (> (count-windows) 1) | |
35 | (delete-window) | |
36 | (bury-buffer))) | |
37 | ||
71296446 | 38 | (defvar describe-text-mode-map |
2a1e884e RS |
39 | (let ((map (make-sparse-keymap))) |
40 | (set-keymap-parent map widget-keymap) | |
41 | map) | |
42 | "Keymap for `describe-text-mode'.") | |
71296446 | 43 | |
2a1e884e RS |
44 | (defcustom describe-text-mode-hook nil |
45 | "List of hook functions ran by `describe-text-mode'." | |
d77a0b9b MR |
46 | :type 'hook |
47 | :group 'facemenu) | |
2a1e884e RS |
48 | |
49 | (defun describe-text-mode () | |
4adb7c09 | 50 | "Major mode for buffers created by `describe-char'. |
2a1e884e RS |
51 | |
52 | \\{describe-text-mode-map} | |
53 | Entry to this mode calls the value of `describe-text-mode-hook' | |
54 | if that value is non-nil." | |
55 | (kill-all-local-variables) | |
56 | (setq major-mode 'describe-text-mode | |
57 | mode-name "Describe-Text") | |
58 | (use-local-map describe-text-mode-map) | |
59 | (widget-setup) | |
f0397cde | 60 | (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) |
2a1e884e RS |
61 | (run-hooks 'describe-text-mode-hook)) |
62 | ||
63 | ;;; Describe-Text Utilities. | |
64 | ||
65 | (defun describe-text-widget (widget) | |
66 | "Insert text to describe WIDGET in the current buffer." | |
67 | (widget-create 'link | |
68 | :notify `(lambda (&rest ignore) | |
69 | (widget-browse ',widget)) | |
71296446 | 70 | (format "%S" (if (symbolp widget) |
2a1e884e RS |
71 | widget |
72 | (car widget)))) | |
73 | (widget-insert " ") | |
74 | (widget-create 'info-link :tag "widget" "(widget)Top")) | |
75 | ||
76 | (defun describe-text-sexp (sexp) | |
77 | "Insert a short description of SEXP in the current buffer." | |
78 | (let ((pp (condition-case signal | |
79 | (pp-to-string sexp) | |
80 | (error (prin1-to-string signal))))) | |
81 | (when (string-match "\n\\'" pp) | |
82 | (setq pp (substring pp 0 (1- (length pp))))) | |
83 | (if (cond ((string-match "\n" pp) | |
84 | nil) | |
85 | ((> (length pp) (- (window-width) (current-column))) | |
86 | nil) | |
87 | (t t)) | |
88 | (widget-insert pp) | |
89 | (widget-create 'push-button | |
90 | :tag "show" | |
91 | :action (lambda (widget &optional event) | |
92 | (with-output-to-temp-buffer | |
93 | "*Pp Eval Output*" | |
94 | (princ (widget-get widget :value)))) | |
95 | pp)))) | |
2a1e884e | 96 | |
4adb7c09 | 97 | (defun describe-property-list (properties) |
2a1e884e RS |
98 | "Insert a description of PROPERTIES in the current buffer. |
99 | PROPERTIES should be a list of overlay or text properties. | |
c1a1535a | 100 | The `category' property is made into a widget button that call |
2a1e884e | 101 | `describe-text-category' when pushed." |
e2fa2f6e CW |
102 | ;; Sort the properties by the size of their value. |
103 | (dolist (elt (sort (let ((ret nil) | |
104 | (key nil) | |
105 | (val nil) | |
106 | (len nil)) | |
107 | (while properties | |
108 | (setq key (pop properties) | |
109 | val (pop properties) | |
110 | len 0) | |
111 | (unless (or (eq key 'category) | |
112 | (widgetp val)) | |
113 | (setq val (pp-to-string val) | |
114 | len (length val))) | |
115 | (push (list key val len) ret)) | |
116 | ret) | |
117 | (lambda (a b) | |
118 | (< (nth 2 a) | |
119 | (nth 2 b))))) | |
120 | (let ((key (nth 0 elt)) | |
121 | (value (nth 1 elt))) | |
c1a1535a | 122 | (widget-insert (propertize (format " %-20s " key) |
e2fa2f6e | 123 | 'font-lock-face 'italic)) |
2a1e884e | 124 | (cond ((eq key 'category) |
c1a1535a | 125 | (widget-create 'link |
2a1e884e RS |
126 | :notify `(lambda (&rest ignore) |
127 | (describe-text-category ',value)) | |
128 | (format "%S" value))) | |
129 | ((widgetp value) | |
130 | (describe-text-widget value)) | |
131 | (t | |
e2fa2f6e CW |
132 | (widget-insert value)))) |
133 | (widget-insert "\n"))) | |
2a1e884e RS |
134 | \f |
135 | ;;; Describe-Text Commands. | |
136 | ||
137 | (defun describe-text-category (category) | |
138 | "Describe a text property category." | |
139 | (interactive "S") | |
2a1e884e | 140 | (save-excursion |
ca9088e7 SM |
141 | (with-output-to-temp-buffer "*Help*" |
142 | (set-buffer standard-output) | |
2a1e884e | 143 | (widget-insert "Category " (format "%S" category) ":\n\n") |
4adb7c09 | 144 | (describe-property-list (symbol-plist category)) |
2a1e884e RS |
145 | (describe-text-mode) |
146 | (goto-char (point-min))))) | |
147 | ||
148 | ;;;###autoload | |
4adb7c09 RS |
149 | (defun describe-text-properties (pos &optional output-buffer) |
150 | "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." | |
2a1e884e | 155 | (interactive "d") |
4adb7c09 RS |
156 | (if (>= pos (point-max)) |
157 | (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.") | |
4adb7c09 | 162 | (let ((buffer (current-buffer))) |
ca9088e7 SM |
163 | (when (eq buffer (get-buffer "*Help*")) |
164 | (error "Can't do self inspection")) | |
4adb7c09 | 165 | (save-excursion |
ca9088e7 SM |
166 | (with-output-to-temp-buffer "*Help*" |
167 | (set-buffer standard-output) | |
4adb7c09 RS |
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) | |
2a1e884e RS |
176 | (let* ((properties (text-properties-at pos)) |
177 | (overlays (overlays-at pos)) | |
178 | overlay | |
179 | (wid-field (get-char-property pos 'field)) | |
180 | (wid-button (get-char-property pos 'button)) | |
181 | (wid-doc (get-char-property pos 'widget-doc)) | |
182 | ;; If button.el is not loaded, we have no buttons in the text. | |
183 | (button (and (fboundp 'button-at) (button-at pos))) | |
184 | (button-type (and button (button-type button))) | |
185 | (button-label (and button (button-label button))) | |
186 | (widget (or wid-field wid-button wid-doc))) | |
4adb7c09 RS |
187 | (with-current-buffer output-buffer |
188 | ;; Widgets | |
189 | (when (widgetp widget) | |
190 | (newline) | |
191 | (widget-insert (cond (wid-field "This is an editable text area") | |
192 | (wid-button "This is an active area") | |
193 | (wid-doc "This is documentation text"))) | |
194 | (widget-insert " of a ") | |
195 | (describe-text-widget widget) | |
196 | (widget-insert ".\n\n")) | |
197 | ;; Buttons | |
198 | (when (and button (not (widgetp wid-button))) | |
199 | (newline) | |
71296446 | 200 | (widget-insert "Here is a " (format "%S" button-type) |
4adb7c09 RS |
201 | " button labeled `" button-label "'.\n\n")) |
202 | ;; Overlays | |
203 | (when overlays | |
204 | (newline) | |
205 | (if (eq (length overlays) 1) | |
206 | (widget-insert "There is an overlay here:\n") | |
207 | (widget-insert "There are " (format "%d" (length overlays)) | |
208 | " overlays here:\n")) | |
209 | (dolist (overlay overlays) | |
71296446 | 210 | (widget-insert " From " (format "%d" (overlay-start overlay)) |
4adb7c09 RS |
211 | " to " (format "%d" (overlay-end overlay)) "\n") |
212 | (describe-property-list (overlay-properties overlay))) | |
213 | (widget-insert "\n")) | |
214 | ;; Text properties | |
215 | (when properties | |
216 | (newline) | |
217 | (widget-insert "There are text properties here:\n") | |
218 | (describe-property-list properties))))) | |
219 | ||
220 | ;;;###autoload | |
221 | (defun describe-char (pos) | |
222 | "Describe the character after POS (interactively, the character after point). | |
223 | 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") | |
4adb7c09 RS |
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)) | |
ca9088e7 | 233 | (composition (find-composition pos nil nil t)) |
4adb7c09 RS |
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" | |
ca9088e7 | 261 | ,(let ((syntax (syntax-after pos))) |
4adb7c09 | 262 | (with-temp-buffer |
ca9088e7 | 263 | (internal-describe-syntax-value syntax) |
4adb7c09 RS |
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 | |
ca9088e7 SM |
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)))) | |
4adb7c09 RS |
295 | (if uc |
296 | (list (list "Unicode" | |
297 | (format "%04X" uc)))))) | |
298 | ,(if (display-graphic-p (selected-frame)) | |
ca9088e7 | 299 | (list "font" (or (internal-char-font pos) |
4adb7c09 RS |
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))) | |
ca9088e7 SM |
309 | (when (eq (current-buffer) (get-buffer "*Help*")) |
310 | (error "Can't do self inspection")) | |
4adb7c09 | 311 | (with-output-to-temp-buffer "*Help*" |
ca9088e7 | 312 | (with-current-buffer standard-output |
4adb7c09 RS |
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 | |
ca9088e7 SM |
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)))))) | |
71296446 | 339 | |
ca9088e7 | 340 | "' to form `" composed "'") |
4adb7c09 RS |
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)))))) | |
2a1e884e | 356 | |
288395a7 CW |
357 | (provide 'descr-text) |
358 | ||
2a1e884e | 359 | ;;; descr-text.el ends here |