1 ;;; descr-text.el --- describe text mode
3 ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.
5 ;; Author: Boris Goldowsky <boris@gnu.org>
8 ;; This file is part of GNU Emacs.
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)
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.
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.
27 ;;; Describe-Text Mode.
31 (defun describe-text-done ()
32 "Delete the current window or bury the current buffer."
34 (if (> (count-windows) 1)
38 (defvar describe-text-mode-map
39 (let ((map (make-sparse-keymap)))
40 (set-keymap-parent map widget-keymap
)
42 "Keymap for `describe-text-mode'.")
44 (defcustom describe-text-mode-hook nil
45 "List of hook functions ran by `describe-text-mode'."
48 (defun describe-text-mode ()
49 "Major mode for buffers created by `describe-text-at'.
51 \\{describe-text-mode-map}
52 Entry to this mode calls the value of `describe-text-mode-hook'
53 if that value is non-nil."
54 (kill-all-local-variables)
55 (setq major-mode
'describe-text-mode
56 mode-name
"Describe-Text")
57 (use-local-map describe-text-mode-map
)
59 (run-hooks 'describe-text-mode-hook
))
61 ;;; Describe-Text Utilities.
63 (defun describe-text-widget (widget)
64 "Insert text to describe WIDGET in the current buffer."
66 :notify
`(lambda (&rest ignore
)
67 (widget-browse ',widget
))
68 (format "%S" (if (symbolp widget
)
72 (widget-create 'info-link
:tag
"widget" "(widget)Top"))
74 (defun describe-text-sexp (sexp)
75 "Insert a short description of SEXP in the current buffer."
76 (let ((pp (condition-case signal
78 (error (prin1-to-string signal
)))))
79 (when (string-match "\n\\'" pp
)
80 (setq pp
(substring pp
0 (1- (length pp
)))))
81 (if (cond ((string-match "\n" pp
)
83 ((> (length pp
) (- (window-width) (current-column)))
87 (widget-create 'push-button
89 :action
(lambda (widget &optional event
)
90 (with-output-to-temp-buffer
92 (princ (widget-get widget
:value
))))
95 (defun describe-text-properties (properties)
96 "Insert a description of PROPERTIES in the current buffer.
97 PROPERTIES should be a list of overlay or text properties.
98 The `category' property is made into a widget button that call
99 `describe-text-category' when pushed."
100 ;; Sort the properties by the size of their value.
101 (dolist (elt (sort (let ((ret nil
)
106 (setq key
(pop properties
)
109 (unless (or (eq key
'category
)
111 (setq val
(pp-to-string val
)
113 (push (list key val len
) ret
))
118 (let ((key (nth 0 elt
))
120 (widget-insert (propertize (format " %-20s" key
)
121 'font-lock-face
'italic
))
122 (cond ((eq key
'category
)
124 :notify
`(lambda (&rest ignore
)
125 (describe-text-category ',value
))
126 (format "%S" value
)))
128 (describe-text-widget value
))
130 (widget-insert value
))))
131 (widget-insert "\n")))
133 ;;; Describe-Text Commands.
135 (defun describe-text-category (category)
136 "Describe a text property category."
138 (when (get-buffer "*Text Category*")
139 (kill-buffer "*Text Category*"))
141 (with-output-to-temp-buffer "*Text Category*"
142 (set-buffer "*Text Category*")
143 (widget-insert "Category " (format "%S" category
) ":\n\n")
144 (describe-text-properties (symbol-plist category
))
146 (goto-char (point-min)))))
149 (defun describe-text-at (pos)
150 "Describe widgets, buttons, overlays and text properties at POS."
152 (when (eq (current-buffer) (get-buffer "*Text Description*"))
153 (error "Can't do self inspection"))
154 (let* ((properties (text-properties-at pos
))
155 (overlays (overlays-at pos
))
157 (wid-field (get-char-property pos
'field
))
158 (wid-button (get-char-property pos
'button
))
159 (wid-doc (get-char-property pos
'widget-doc
))
160 ;; If button.el is not loaded, we have no buttons in the text.
161 (button (and (fboundp 'button-at
) (button-at pos
)))
162 (button-type (and button
(button-type button
)))
163 (button-label (and button
(button-label button
)))
164 (widget (or wid-field wid-button wid-doc
)))
165 (if (not (or properties overlays
))
166 (message "This is plain text.")
167 (when (get-buffer "*Text Description*")
168 (kill-buffer "*Text Description*"))
170 (with-output-to-temp-buffer "*Text Description*"
171 (set-buffer "*Text Description*")
172 (widget-insert "Text content at position " (format "%d" pos
) ":\n\n")
174 (when (widgetp widget
)
175 (widget-insert (cond (wid-field "This is an editable text area")
176 (wid-button "This is an active area")
177 (wid-doc "This is documentation text")))
178 (widget-insert " of a ")
179 (describe-text-widget widget
)
180 (widget-insert ".\n\n"))
182 (when (and button
(not (widgetp wid-button
)))
183 (widget-insert "Here is a " (format "%S" button-type
)
184 " button labeled `" button-label
"'.\n\n"))
187 (if (eq (length overlays
) 1)
188 (widget-insert "There is an overlay here:\n")
189 (widget-insert "There are " (format "%d" (length overlays
))
190 " overlays here:\n"))
191 (dolist (overlay overlays
)
192 (widget-insert " From " (format "%d" (overlay-start overlay
))
193 " to " (format "%d" (overlay-end overlay
)) "\n")
194 (describe-text-properties (overlay-properties overlay
)))
195 (widget-insert "\n"))
198 (widget-insert "There are text properties here:\n")
199 (describe-text-properties properties
))
201 (goto-char (point-min)))))))
203 (provide 'descr-text
)
205 ;;; descr-text.el ends here