*** empty log message ***
[emacs.git] / lisp / button.el
blob3924a9c9418aa0a6dc08bcf14d1df3dfa90def21
1 ;;; button.el --- clickable buttons
2 ;;
3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
4 ;; 2006 Free Software Foundation, Inc.
5 ;;
6 ;; Author: Miles Bader <miles@gnu.org>
7 ;; Keywords: extensions
8 ;;
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
26 ;;; Commentary:
28 ;; This package defines functions for inserting and manipulating
29 ;; clickable buttons in Emacs buffers, such as might be used for help
30 ;; hyperlinks, etc.
32 ;; In some ways it duplicates functionality also offered by the
33 ;; `widget' package, but the button package has the advantage that it
34 ;; is (1) much faster, (2) much smaller, and (3) much, much, simpler
35 ;; (the code, that is, not the interface).
37 ;; Buttons can either use overlays, in which case the button is
38 ;; represented by the overlay itself, or text-properties, in which case
39 ;; the button is represented by a marker or buffer-position pointing
40 ;; somewhere in the button. In the latter case, no markers into the
41 ;; buffer are retained, which is important for speed if there are are
42 ;; extremely large numbers of buttons.
44 ;; Using `define-button-type' to define default properties for buttons
45 ;; is not necessary, but it is is encouraged, since doing so makes the
46 ;; resulting code clearer and more efficient.
49 ;;; Code:
52 ;; Globals
54 ;; Use color for the MS-DOS port because it doesn't support underline.
55 (defface button '((((type pc) (class color))
56 (:foreground "lightblue"))
57 (t :underline t))
58 "Default face used for buttons."
59 :group 'basic-faces)
61 ;;;###autoload
62 (defvar button-map
63 (let ((map (make-sparse-keymap)))
64 (define-key map "\r" 'push-button)
65 (define-key map [mouse-2] 'push-button)
66 map)
67 "Keymap used by buttons.")
69 ;;;###autoload
70 (defvar button-buffer-map
71 (let ((map (make-sparse-keymap)))
72 (define-key map [?\t] 'forward-button)
73 (define-key map "\e\t" 'backward-button)
74 (define-key map [backtab] 'backward-button)
75 map)
76 "Keymap useful for buffers containing buttons.
77 Mode-specific keymaps may want to use this as their parent keymap.")
79 ;; Default properties for buttons
80 (put 'default-button 'face 'button)
81 (put 'default-button 'mouse-face 'highlight)
82 (put 'default-button 'keymap button-map)
83 (put 'default-button 'type 'button)
84 ;; action may be either a function to call, or a marker to go to
85 (put 'default-button 'action 'ignore)
86 (put 'default-button 'help-echo "mouse-2, RET: Push this button")
87 ;; Make overlay buttons go away if their underlying text is deleted.
88 (put 'default-button 'evaporate t)
89 ;; Prevent insertions adjacent to the text-property buttons from
90 ;; inheriting its properties.
91 (put 'default-button 'rear-nonsticky t)
92 ;; Text property buttons don't have a `button' property of their own, so
93 ;; they inherit this.
94 (put 'default-button 'button t)
96 ;; A `category-symbol' property for the default button type
97 (put 'button 'button-category-symbol 'default-button)
100 ;; Button types (which can be used to hold default properties for buttons)
102 ;; Because button-type properties are inherited by buttons using the
103 ;; special `category' property (implemented by both overlays and
104 ;; text-properties), we need to store them on a symbol to which the
105 ;; `category' properties can point. Instead of using the symbol that's
106 ;; the name of each button-type, however, we use a separate symbol (with
107 ;; `-button' appended, and uninterned) to store the properties. This is
108 ;; to avoid name clashes.
110 ;; [this is an internal function]
111 (defsubst button-category-symbol (type)
112 "Return the symbol used by button-type TYPE to store properties.
113 Buttons inherit them by setting their `category' property to that symbol."
114 (or (get type 'button-category-symbol)
115 (error "Unknown button type `%s'" type)))
117 ;;;###autoload
118 (defun define-button-type (name &rest properties)
119 "Define a `button type' called NAME.
120 The remaining arguments form a sequence of PROPERTY VALUE pairs,
121 specifying properties to use as defaults for buttons with this type
122 \(a button's type may be set by giving it a `type' property when
123 creating the button, using the :type keyword argument).
125 In addition, the keyword argument :supertype may be used to specify a
126 button-type from which NAME inherits its default property values
127 \(however, the inheritance happens only when NAME is defined; subsequent
128 changes to a supertype are not reflected in its subtypes)."
129 (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
130 (super-catsym
131 (button-category-symbol
132 (or (plist-get properties 'supertype)
133 (plist-get properties :supertype)
134 'button))))
135 ;; Provide a link so that it's easy to find the real symbol.
136 (put name 'button-category-symbol catsym)
137 ;; Initialize NAME's properties using the global defaults.
138 (let ((default-props (symbol-plist super-catsym)))
139 (while default-props
140 (put catsym (pop default-props) (pop default-props))))
141 ;; Add NAME as the `type' property, which will then be returned as
142 ;; the type property of individual buttons.
143 (put catsym 'type name)
144 ;; Add the properties in PROPERTIES to the real symbol.
145 (while properties
146 (let ((prop (pop properties)))
147 (when (eq prop :supertype)
148 (setq prop 'supertype))
149 (put catsym prop (pop properties))))
150 ;; Make sure there's a `supertype' property
151 (unless (get catsym 'supertype)
152 (put catsym 'supertype 'button))
153 name))
155 (defun button-type-put (type prop val)
156 "Set the button-type TYPE's PROP property to VAL."
157 (put (button-category-symbol type) prop val))
159 (defun button-type-get (type prop)
160 "Get the property of button-type TYPE named PROP."
161 (get (button-category-symbol type) prop))
163 (defun button-type-subtype-p (type supertype)
164 "Return t if button-type TYPE is a subtype of SUPERTYPE."
165 (or (eq type supertype)
166 (and type
167 (button-type-subtype-p (button-type-get type 'supertype)
168 supertype))))
171 ;; Button properties and other attributes
173 (defun button-start (button)
174 "Return the position at which BUTTON starts."
175 (if (overlayp button)
176 (overlay-start button)
177 ;; Must be a text-property button.
178 (or (previous-single-property-change (1+ button) 'button)
179 (point-min))))
181 (defun button-end (button)
182 "Return the position at which BUTTON ends."
183 (if (overlayp button)
184 (overlay-end button)
185 ;; Must be a text-property button.
186 (or (next-single-property-change button 'button)
187 (point-max))))
189 (defun button-get (button prop)
190 "Get the property of button BUTTON named PROP."
191 (if (overlayp button)
192 (overlay-get button prop)
193 ;; Must be a text-property button.
194 (get-text-property button prop)))
196 (defun button-put (button prop val)
197 "Set BUTTON's PROP property to VAL."
198 ;; Treat some properties specially.
199 (cond ((memq prop '(type :type))
200 ;; We translate a `type' property a `category' property, since
201 ;; that's what's actually used by overlays/text-properties for
202 ;; inheriting properties.
203 (setq prop 'category)
204 (setq val (button-category-symbol val)))
205 ((eq prop 'category)
206 ;; Disallow updating the `category' property directly.
207 (error "Button `category' property may not be set directly")))
208 ;; Add the property.
209 (if (overlayp button)
210 (overlay-put button prop val)
211 ;; Must be a text-property button.
212 (put-text-property
213 (or (previous-single-property-change (1+ button) 'button)
214 (point-min))
215 (or (next-single-property-change button 'button)
216 (point-max))
217 prop val)))
219 (defsubst button-activate (button &optional use-mouse-action)
220 "Call BUTTON's action property.
221 If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
222 instead of its normal action; if the button has no mouse-action,
223 the normal action is used instead."
224 (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
225 (button-get button 'action))))
226 (if (markerp action)
227 (save-selected-window
228 (select-window (display-buffer (marker-buffer action)))
229 (goto-char action)
230 (recenter 0))
231 (funcall action button))))
233 (defun button-label (button)
234 "Return BUTTON's text label."
235 (buffer-substring-no-properties (button-start button) (button-end button)))
237 (defsubst button-type (button)
238 "Return BUTTON's button-type."
239 (button-get button 'type))
241 (defun button-has-type-p (button type)
242 "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes."
243 (button-type-subtype-p (button-get button 'type) type))
246 ;; Creating overlay buttons
248 ;;;###autoload
249 (defun make-button (beg end &rest properties)
250 "Make a button from BEG to END in the current buffer.
251 The remaining arguments form a sequence of PROPERTY VALUE pairs,
252 specifying properties to add to the button.
253 In addition, the keyword argument :type may be used to specify a
254 button-type from which to inherit other properties; see
255 `define-button-type'.
257 Also see `make-text-button', `insert-button'."
258 (let ((overlay (make-overlay beg end nil t nil)))
259 (while properties
260 (button-put overlay (pop properties) (pop properties)))
261 ;; Put a pointer to the button in the overlay, so it's easy to get
262 ;; when we don't actually have a reference to the overlay.
263 (overlay-put overlay 'button overlay)
264 ;; If the user didn't specify a type, use the default.
265 (unless (overlay-get overlay 'category)
266 (overlay-put overlay 'category 'default-button))
267 ;; OVERLAY is the button, so return it
268 overlay))
270 ;;;###autoload
271 (defun insert-button (label &rest properties)
272 "Insert a button with the label LABEL.
273 The remaining arguments form a sequence of PROPERTY VALUE pairs,
274 specifying properties to add to the button.
275 In addition, the keyword argument :type may be used to specify a
276 button-type from which to inherit other properties; see
277 `define-button-type'.
279 Also see `insert-text-button', `make-button'."
280 (apply #'make-button
281 (prog1 (point) (insert label))
282 (point)
283 properties))
286 ;; Creating text-property buttons
288 ;;;###autoload
289 (defun make-text-button (beg end &rest properties)
290 "Make a button from BEG to END in the current buffer.
291 The remaining arguments form a sequence of PROPERTY VALUE pairs,
292 specifying properties to add to the button.
293 In addition, the keyword argument :type may be used to specify a
294 button-type from which to inherit other properties; see
295 `define-button-type'.
297 This function is like `make-button', except that the button is actually
298 part of the text instead of being a property of the buffer. Creating
299 large numbers of buttons can also be somewhat faster using
300 `make-text-button'.
302 Also see `insert-text-button'."
303 (let ((type-entry
304 (or (plist-member properties 'type)
305 (plist-member properties :type))))
306 ;; Disallow setting the `category' property directly.
307 (when (plist-get properties 'category)
308 (error "Button `category' property may not be set directly"))
309 (if (null type-entry)
310 ;; The user didn't specify a `type' property, use the default.
311 (setq properties (cons 'category (cons 'default-button properties)))
312 ;; The user did specify a `type' property. Translate it into a
313 ;; `category' property, which is what's actually used by
314 ;; text-properties for inheritance.
315 (setcar type-entry 'category)
316 (setcar (cdr type-entry)
317 (button-category-symbol (car (cdr type-entry))))))
318 ;; Now add all the text properties at once
319 (add-text-properties beg end properties)
320 ;; Return something that can be used to get at the button.
321 beg)
323 ;;;###autoload
324 (defun insert-text-button (label &rest properties)
325 "Insert a button with the label LABEL.
326 The remaining arguments form a sequence of PROPERTY VALUE pairs,
327 specifying properties to add to the button.
328 In addition, the keyword argument :type may be used to specify a
329 button-type from which to inherit other properties; see
330 `define-button-type'.
332 This function is like `insert-button', except that the button is
333 actually part of the text instead of being a property of the buffer.
334 Creating large numbers of buttons can also be somewhat faster using
335 `insert-text-button'.
337 Also see `make-text-button'."
338 (apply #'make-text-button
339 (prog1 (point) (insert label))
340 (point)
341 properties))
344 ;; Finding buttons in a buffer
346 (defun button-at (pos)
347 "Return the button at position POS in the current buffer, or nil."
348 (let ((button (get-char-property pos 'button)))
349 (if (or (overlayp button) (null button))
350 button
351 ;; Must be a text-property button; return a marker pointing to it.
352 (copy-marker pos t))))
354 (defun next-button (pos &optional count-current)
355 "Return the next button after position POS in the current buffer.
356 If COUNT-CURRENT is non-nil, count any button at POS in the search,
357 instead of starting at the next button."
358 (unless count-current
359 ;; Search for the next button boundary.
360 (setq pos (next-single-char-property-change pos 'button)))
361 (and (< pos (point-max))
362 (or (button-at pos)
363 ;; We must have originally been on a button, and are now in
364 ;; the inter-button space. Recurse to find a button.
365 (next-button pos))))
367 (defun previous-button (pos &optional count-current)
368 "Return the Nth button before position POS in the current buffer.
369 If COUNT-CURRENT is non-nil, count any button at POS in the search,
370 instead of starting at the next button."
371 (unless count-current
372 (setq pos (previous-single-char-property-change pos 'button)))
373 (and (> pos (point-min))
374 (or (button-at (1- pos))
375 ;; We must have originally been on a button, and are now in
376 ;; the inter-button space. Recurse to find a button.
377 (previous-button pos))))
380 ;; User commands
382 (defun push-button (&optional pos use-mouse-action)
383 "Perform the action specified by a button at location POS.
384 POS may be either a buffer position or a mouse-event. If
385 USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
386 instead of its normal action; if the button has no mouse-action,
387 the normal action is used instead. The action may be either a
388 function to call or a marker to display.
389 POS defaults to point, except when `push-button' is invoked
390 interactively as the result of a mouse-event, in which case, the
391 mouse event is used.
392 If there's no button at POS, do nothing and return nil, otherwise
393 return t."
394 (interactive
395 (list (if (integerp last-command-event) (point) last-command-event)))
396 (if (and (not (integerp pos)) (eventp pos))
397 ;; POS is a mouse event; switch to the proper window/buffer
398 (let ((posn (event-start pos)))
399 (with-current-buffer (window-buffer (posn-window posn))
400 (push-button (posn-point posn) t)))
401 ;; POS is just normal position
402 (let ((button (button-at (or pos (point)))))
403 (if (not button)
405 (button-activate button use-mouse-action)
406 t))))
408 (defun forward-button (n &optional wrap display-message)
409 "Move to the Nth next button, or Nth previous button if N is negative.
410 If N is 0, move to the start of any button at point.
411 If WRAP is non-nil, moving past either end of the buffer continues from the
412 other end.
413 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
414 Any button with a non-nil `skip' property is skipped over.
415 Returns the button found."
416 (interactive "p\nd\nd")
417 (let (button)
418 (if (zerop n)
419 ;; Move to start of current button
420 (if (setq button (button-at (point)))
421 (goto-char (button-start button)))
422 ;; Move to Nth next button
423 (let ((iterator (if (> n 0) #'next-button #'previous-button))
424 (wrap-start (if (> n 0) (point-min) (point-max))))
425 (setq n (abs n))
426 (setq button t) ; just to start the loop
427 (while (and (> n 0) button)
428 (setq button (funcall iterator (point)))
429 (when (and (not button) wrap)
430 (setq button (funcall iterator wrap-start t)))
431 (when button
432 (goto-char (button-start button))
433 (unless (button-get button 'skip)
434 (setq n (1- n)))))))
435 (if (null button)
436 (error (if wrap "No buttons!" "No more buttons"))
437 (let ((msg (and display-message (button-get button 'help-echo))))
438 (when msg
439 (message "%s" msg)))
440 button)))
442 (defun backward-button (n &optional wrap display-message)
443 "Move to the Nth previous button, or Nth next button if N is negative.
444 If N is 0, move to the start of any button at point.
445 If WRAP is non-nil, moving past either end of the buffer continues from the
446 other end.
447 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
448 Any button with a non-nil `skip' property is skipped over.
449 Returns the button found."
450 (interactive "p\nd\nd")
451 (forward-button (- n) wrap display-message))
454 (provide 'button)
456 ;;; arch-tag: 5f2c7627-413b-4097-b282-630f89d9c5e9
457 ;;; button.el ends here