(ibuffer-backward-line, ibuffer-forward-line)
[emacs.git] / lisp / button.el
blobd6f089327a2787b96a7415892a48e0e16844116d
1 ;;; button.el --- clickable buttons
2 ;;
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
4 ;;
5 ;; Author: Miles Bader <miles@gnu.org>
6 ;; Keywords: extensions
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.
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.
25 ;;; Commentary:
27 ;; This package defines functions for inserting and manipulating
28 ;; clickable buttons in Emacs buffers, such as might be used for help
29 ;; hyperlinks, etc.
31 ;; In some ways it duplicates functionality also offered by the
32 ;; `widget' package, but the button package has the advantage that it
33 ;; is (1) much faster, (2) much smaller, and (3) much, much, simpler
34 ;; (the code, that is, not the interface).
36 ;; Buttons can either use overlays, in which case the button is
37 ;; represented by the overlay itself, or text-properties, in which case
38 ;; the button is represented by a marker or buffer-position pointing
39 ;; somewhere in the button. In the latter case, no markers into the
40 ;; buffer are retained, which is important for speed if there are are
41 ;; extremely large numbers of buttons.
43 ;; Using `define-button-type' to define default properties for buttons
44 ;; is not necessary, but it is is encouraged, since doing so makes the
45 ;; resulting code clearer and more efficient.
48 ;;; Code:
51 ;; Globals
53 (defface button '((((type pc) (class color))
54 (:foreground "lightblue"))
55 (t :underline t))
56 "Default face used for buttons."
57 :group 'faces)
59 ;;;###autoload
60 (defvar button-map
61 (let ((map (make-sparse-keymap)))
62 (define-key map "\r" 'push-button)
63 (define-key map [mouse-2] 'push-button)
64 map)
65 "Keymap used by buttons.")
67 ;;;###autoload
68 (defvar button-buffer-map
69 (let ((map (make-sparse-keymap)))
70 (define-key map [?\t] 'forward-button)
71 (define-key map [backtab] 'backward-button)
72 map)
73 "Keymap useful for buffers containing buttons.
74 Mode-specific keymaps may want to use this as their parent keymap.")
76 ;; Default properties for buttons
77 (put 'default-button 'face 'button)
78 (put 'default-button 'mouse-face 'highlight)
79 (put 'default-button 'keymap button-map)
80 (put 'default-button 'type 'button)
81 (put 'default-button 'action 'ignore)
82 (put 'default-button 'help-echo "mouse-2, RET: Push this button")
83 ;; Make overlay buttons go away if their underlying text is deleted.
84 (put 'default-button 'evaporate t)
85 ;; Prevent insertions adjacent to the text-property buttons from
86 ;; inheriting its properties.
87 (put 'default-button 'rear-nonsticky t)
88 ;; Text property buttons don't have a `button' property of their own, so
89 ;; they inherit this.
90 (put 'default-button 'button t)
92 ;; A `category-symbol' property for the default button type
93 (put 'button 'button-category-symbol 'default-button)
96 ;; Button types (which can be used to hold default properties for buttons)
98 ;; Because button-type properties are inherited by buttons using the
99 ;; special `category' property (implemented by both overlays and
100 ;; text-properties), we need to store them on a symbol to which the
101 ;; `category' properties can point. Instead of using the symbol that's
102 ;; the name of each button-type, however, we use a separate symbol (with
103 ;; `-button' appended, and uninterned) to store the properties. This is
104 ;; to avoid name clashes.
106 ;; [this is an internal function]
107 (defsubst button-category-symbol (type)
108 "Return the symbol used by button-type TYPE to store properties.
109 Buttons inherit them by setting their `category' property to that symbol."
110 (or (get type 'button-category-symbol)
111 (error "Unknown button type `%s'" type)))
113 ;;;###autoload
114 (defun define-button-type (name &rest properties)
115 "Define a `button type' called NAME.
116 The remaining arguments form a sequence of PROPERTY VALUE pairs,
117 specifying properties to use as defaults for buttons with this type
118 \(a button's type may be set by giving it a `type' property when
119 creating the button, using the :type keyword argument).
121 In addition, the keyword argument :supertype may be used to specify a
122 button-type from which NAME inherits its default property values
123 \(however, the inheritance happens only when NAME is defined; subsequent
124 changes to a supertype are not reflected in its subtypes)."
125 (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
126 (super-catsym
127 (button-category-symbol
128 (or (plist-get properties 'supertype)
129 (plist-get properties :supertype)
130 'button))))
131 ;; Provide a link so that it's easy to find the real symbol.
132 (put name 'button-category-symbol catsym)
133 ;; Initialize NAME's properties using the global defaults.
134 (let ((default-props (symbol-plist super-catsym)))
135 (while default-props
136 (put catsym (pop default-props) (pop default-props))))
137 ;; Add NAME as the `type' property, which will then be returned as
138 ;; the type property of individual buttons.
139 (put catsym 'type name)
140 ;; Add the properties in PROPERTIES to the real symbol.
141 (while properties
142 (let ((prop (pop properties)))
143 (when (eq prop :supertype)
144 (setq prop 'supertype))
145 (put catsym prop (pop properties))))
146 ;; Make sure there's a `supertype' property
147 (unless (get catsym 'supertype)
148 (put catsym 'supertype 'button))
149 name))
151 (defun button-type-put (type prop val)
152 "Set the button-type TYPE's PROP property to VAL."
153 (put (button-category-symbol type) prop val))
155 (defun button-type-get (type prop)
156 "Get the property of button-type TYPE named PROP."
157 (get (button-category-symbol type) prop))
159 (defun button-type-subtype-p (type supertype)
160 "Return t if button-type TYPE is a subtype of SUPERTYPE."
161 (or (eq type supertype)
162 (and type
163 (button-type-subtype-p (button-type-get type 'supertype)
164 supertype))))
167 ;; Button properties and other attributes
169 (defun button-start (button)
170 "Return the position at which BUTTON starts."
171 (if (overlayp button)
172 (overlay-start button)
173 ;; Must be a text-property button.
174 (or (previous-single-property-change (1+ button) 'button)
175 (point-min))))
177 (defun button-end (button)
178 "Return the position at which BUTTON ends."
179 (if (overlayp button)
180 (overlay-end button)
181 ;; Must be a text-property button.
182 (or (next-single-property-change button 'button)
183 (point-max))))
185 (defun button-get (button prop)
186 "Get the property of button BUTTON named PROP."
187 (if (overlayp button)
188 (overlay-get button prop)
189 ;; Must be a text-property button.
190 (get-text-property button prop)))
192 (defun button-put (button prop val)
193 "Set BUTTON's PROP property to VAL."
194 ;; Treat some properties specially.
195 (cond ((memq prop '(type :type))
196 ;; We translate a `type' property a `category' property, since
197 ;; that's what's actually used by overlays/text-properties for
198 ;; inheriting properties.
199 (setq prop 'category)
200 (setq val (button-category-symbol val)))
201 ((eq prop 'category)
202 ;; Disallow updating the `category' property directly.
203 (error "Button `category' property may not be set directly")))
204 ;; Add the property.
205 (if (overlayp button)
206 (overlay-put button prop val)
207 ;; Must be a text-property button.
208 (put-text-property
209 (or (previous-single-property-change (1+ button) 'button)
210 (point-min))
211 (or (next-single-property-change button 'button)
212 (point-max))
213 prop val)))
215 (defsubst button-activate (button &optional use-mouse-action)
216 "Call BUTTON's action property.
217 If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
218 instead of its normal action; if the button has no mouse-action,
219 the normal action is used instead."
220 (funcall (or (and use-mouse-action (button-get button 'mouse-action))
221 (button-get button 'action))
222 button))
224 (defun button-label (button)
225 "Return BUTTON's text label."
226 (buffer-substring-no-properties (button-start button) (button-end button)))
228 (defsubst button-type (button)
229 "Return BUTTON's button-type."
230 (button-get button 'type))
232 (defun button-has-type-p (button type)
233 "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes."
234 (button-type-subtype-p (button-get button 'type) type))
237 ;; Creating overlay buttons
239 ;;;###autoload
240 (defun make-button (beg end &rest properties)
241 "Make a button from BEG to END in the current buffer.
242 The remaining arguments form a sequence of PROPERTY VALUE pairs,
243 specifying properties to add to the button.
244 In addition, the keyword argument :type may be used to specify a
245 button-type from which to inherit other properties; see
246 `define-button-type'.
248 Also see `make-text-button', `insert-button'."
249 (let ((overlay (make-overlay beg end nil t nil)))
250 (while properties
251 (button-put overlay (pop properties) (pop properties)))
252 ;; Put a pointer to the button in the overlay, so it's easy to get
253 ;; when we don't actually have a reference to the overlay.
254 (overlay-put overlay 'button overlay)
255 ;; If the user didn't specify a type, use the default.
256 (unless (overlay-get overlay 'category)
257 (overlay-put overlay 'category 'default-button))
258 ;; OVERLAY is the button, so return it
259 overlay))
261 ;;;###autoload
262 (defun insert-button (label &rest properties)
263 "Insert a button with the label LABEL.
264 The remaining arguments form a sequence of PROPERTY VALUE pairs,
265 specifying properties to add to the button.
266 In addition, the keyword argument :type may be used to specify a
267 button-type from which to inherit other properties; see
268 `define-button-type'.
270 Also see `insert-text-button', `make-button'."
271 (apply #'make-button
272 (prog1 (point) (insert label))
273 (point)
274 properties))
277 ;; Creating text-property buttons
279 ;;;###autoload
280 (defun make-text-button (beg end &rest properties)
281 "Make a button from BEG to END in the current buffer.
282 The remaining arguments form a sequence of PROPERTY VALUE pairs,
283 specifying properties to add to the button.
284 In addition, the keyword argument :type may be used to specify a
285 button-type from which to inherit other properties; see
286 `define-button-type'.
288 This function is like `make-button', except that the button is actually
289 part of the text instead of being a property of the buffer. Creating
290 large numbers of buttons can also be somewhat faster using
291 `make-text-button'.
293 Also see `insert-text-button'."
294 (let (prop val)
295 (while properties
296 (setq prop (pop properties))
297 (setq val (pop properties))
298 ;; Note that all the following code is basically equivalent to
299 ;; `button-put', but we can do it much more efficiently since we
300 ;; already have BEG and END.
301 (cond ((memq prop '(type :type))
302 ;; We translate a `type' property into a `category'
303 ;; property, since that's what's actually used by
304 ;; text-properties for inheritance.
305 (setq prop 'category)
306 (setq val (button-category-symbol val)))
307 ((eq prop 'category)
308 ;; Disallow setting the `category' property directly.
309 (error "Button `category' property may not be set directly")))
310 ;; Add the property.
311 (put-text-property beg end prop val)))
312 ;; Return something that can be used to get at the button.
313 beg)
315 ;;;###autoload
316 (defun insert-text-button (label &rest properties)
317 "Insert a button with the label LABEL.
318 The remaining arguments form a sequence of PROPERTY VALUE pairs,
319 specifying properties to add to the button.
320 In addition, the keyword argument :type may be used to specify a
321 button-type from which to inherit other properties; see
322 `define-button-type'.
324 This function is like `insert-button', except that the button is
325 actually part of the text instead of being a property of the buffer.
326 Creating large numbers of buttons can also be somewhat faster using
327 `insert-text-button'.
329 Also see `make-text-button'."
330 (apply #'make-text-button
331 (prog1 (point) (insert label))
332 (point)
333 properties))
336 ;; Finding buttons in a buffer
338 (defun button-at (pos)
339 "Return the button at position POS in the current buffer, or nil."
340 (let ((button (get-char-property pos 'button)))
341 (if (or (overlayp button) (null button))
342 button
343 ;; Must be a text-property button; return a marker pointing to it.
344 (copy-marker pos t))))
346 (defun next-button (pos &optional count-current)
347 "Return the next button after position POS in the current buffer.
348 If COUNT-CURRENT is non-nil, count any button at POS in the search,
349 instead of starting at the next button."
350 (unless count-current
351 ;; Search for the next button boundary.
352 (setq pos (next-single-char-property-change pos 'button)))
353 (and (< pos (point-max))
354 (or (button-at pos)
355 ;; We must have originally been on a button, and are now in
356 ;; the inter-button space. Recurse to find a button.
357 (next-button pos))))
359 (defun previous-button (pos &optional count-current)
360 "Return the Nth button before position POS in the current buffer.
361 If COUNT-CURRENT is non-nil, count any button at POS in the search,
362 instead of starting at the next button."
363 (unless count-current
364 (setq pos (previous-single-char-property-change pos 'button)))
365 (and (> pos (point-min))
366 (or (button-at (1- pos))
367 ;; We must have originally been on a button, and are now in
368 ;; the inter-button space. Recurse to find a button.
369 (previous-button pos))))
372 ;; User commands
374 (defun push-button (&optional pos use-mouse-action)
375 "Perform the action specified by a button at location POS.
376 POS may be either a buffer position or a mouse-event.
377 If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
378 instead of its normal action; if the button has no mouse-action,
379 the normal action is used instead.
380 POS defaults to point, except when `push-button' is invoked
381 interactively as the result of a mouse-event, in which case, the
382 mouse event is used.
383 If there's no button at POS, do nothing and return nil, otherwise
384 return t."
385 (interactive
386 (list (if (integerp last-command-event) (point) last-command-event)))
387 (if (and (not (integerp pos)) (eventp pos))
388 ;; POS is a mouse event; switch to the proper window/buffer
389 (let ((posn (event-start pos)))
390 (with-current-buffer (window-buffer (posn-window posn))
391 (push-button (posn-point posn) t)))
392 ;; POS is just normal position
393 (let ((button (button-at (or pos (point)))))
394 (if (not button)
396 (button-activate button use-mouse-action)
397 t))))
399 (defun forward-button (n &optional wrap display-message)
400 "Move to the Nth next button, or Nth previous button if N is negative.
401 If N is 0, move to the start of any button at point.
402 If WRAP is non-nil, moving past either end of the buffer continues from the
403 other end.
404 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
405 Any button with a non-nil `skip' property is skipped over.
406 Returns the button found."
407 (interactive "p\nd\nd")
408 (let (button)
409 (if (zerop n)
410 ;; Move to start of current button
411 (if (setq button (button-at (point)))
412 (goto-char (button-start button)))
413 ;; Move to Nth next button
414 (let ((iterator (if (> n 0) #'next-button #'previous-button))
415 (wrap-start (if (> n 0) (point-min) (point-max))))
416 (setq n (abs n))
417 (setq button t) ; just to start the loop
418 (while (and (> n 0) button)
419 (setq button (funcall iterator (point)))
420 (when (and (not button) wrap)
421 (setq button (funcall iterator wrap-start t)))
422 (when button
423 (goto-char (button-start button))
424 (unless (button-get button 'skip)
425 (setq n (1- n)))))))
426 (if (null button)
427 (error (if wrap "No buttons!" "No more buttons"))
428 (let ((msg (and display-message (button-get button 'help-echo))))
429 (when msg
430 (message "%s" msg)))
431 button)))
433 (defun backward-button (n &optional wrap display-message)
434 "Move to the Nth previous button, or Nth next button if N is negative.
435 If N is 0, move to the start of any button at point.
436 If WRAP is non-nil, moving past either end of the buffer continues from the
437 other end.
438 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
439 Any button with a non-nil `skip' property is skipped over.
440 Returns the button found."
441 (interactive "p\nd\nd")
442 (forward-button (- n) wrap display-message))
445 (provide 'button)
447 ;;; button.el ends here