button.el 18.4 KB
Newer Older
Pavel Janík's avatar
Pavel Janík committed
1
;;; button.el --- clickable buttons
Miles Bader's avatar
Miles Bader committed
2
;;
Glenn Morris's avatar
Glenn Morris committed
3 4
;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
;;   2010, 2011  Free Software Foundation, Inc.
Miles Bader's avatar
Miles Bader committed
5 6 7 8 9 10
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: extensions
;;
;; This file is part of GNU Emacs.
;;
11
;; GNU Emacs is free software: you can redistribute it and/or modify
Miles Bader's avatar
Miles Bader committed
12
;; it under the terms of the GNU General Public License as published by
13 14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

Miles Bader's avatar
Miles Bader committed
16 17 18 19
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
20

Miles Bader's avatar
Miles Bader committed
21
;; You should have received a copy of the GNU General Public License
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Miles Bader's avatar
Miles Bader committed
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39

;;; Commentary:
;;
;; This package defines functions for inserting and manipulating
;; clickable buttons in Emacs buffers, such as might be used for help
;; hyperlinks, etc.
;;
;; In some ways it duplicates functionality also offered by the
;; `widget' package, but the button package has the advantage that it
;; is (1) much faster, (2) much smaller, and (3) much, much, simpler
;; (the code, that is, not the interface).
;;
;; Buttons can either use overlays, in which case the button is
;; represented by the overlay itself, or text-properties, in which case
;; the button is represented by a marker or buffer-position pointing
;; somewhere in the button.  In the latter case, no markers into the
;; buffer are retained, which is important for speed if there are are
Glenn Morris's avatar
Glenn Morris committed
40 41 42
;; extremely large numbers of buttons.  Note however that if there is
;; an existing face text-property at the site of the button, the
;; button face may not be visible.  Using overlays avoids this.
Miles Bader's avatar
Miles Bader committed
43 44 45 46 47 48 49 50 51 52 53
;;
;; Using `define-button-type' to define default properties for buttons
;; is not necessary, but it is is encouraged, since doing so makes the
;; resulting code clearer and more efficient.
;;

;;; Code:


;; Globals

54
;; Use color for the MS-DOS port because it doesn't support underline.
55 56
;; FIXME if MS-DOS correctly answers the (supports) question, it need
;; no longer be a special case.
57
(defface button '((((type pc) (class color))
58
		   (:foreground "lightblue"))
59 60
		  (((supports :underline t)) :underline t)
		  (t (:foreground "lightblue")))
Markus Rost's avatar
Markus Rost committed
61
  "Default face used for buttons."
62
  :group 'basic-faces)
Miles Bader's avatar
Miles Bader committed
63 64 65

(defvar button-map
  (let ((map (make-sparse-keymap)))
Jason Rumney's avatar
Jason Rumney committed
66 67 68
    ;; The following definition needs to avoid using escape sequences that
    ;; might get converted to ^M when building loaddefs.el
    (define-key map [(control ?m)] 'push-button)
Miles Bader's avatar
Miles Bader committed
69 70 71 72 73 74 75
    (define-key map [mouse-2] 'push-button)
    map)
  "Keymap used by buttons.")

(defvar button-buffer-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\t] 'forward-button)
76
    (define-key map "\e\t" 'backward-button)
Miles Bader's avatar
Miles Bader committed
77 78 79 80 81 82 83 84 85 86
    (define-key map [backtab] 'backward-button)
    map)
  "Keymap useful for buffers containing buttons.
Mode-specific keymaps may want to use this as their parent keymap.")

;; Default properties for buttons
(put 'default-button 'face 'button)
(put 'default-button 'mouse-face 'highlight)
(put 'default-button 'keymap button-map)
(put 'default-button 'type 'button)
87
;; action may be either a function to call, or a marker to go to
Miles Bader's avatar
Miles Bader committed
88
(put 'default-button 'action 'ignore)
89
(put 'default-button 'help-echo (purecopy "mouse-2, RET: Push this button"))
Miles Bader's avatar
Miles Bader committed
90 91 92 93 94 95
;; Make overlay buttons go away if their underlying text is deleted.
(put 'default-button 'evaporate t)
;; Prevent insertions adjacent to the text-property buttons from
;; inheriting its properties.
(put 'default-button 'rear-nonsticky t)

Miles Bader's avatar
Miles Bader committed
96 97 98
;; A `category-symbol' property for the default button type
(put 'button 'button-category-symbol 'default-button)

Miles Bader's avatar
Miles Bader committed
99 100 101

;; Button types (which can be used to hold default properties for buttons)

102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
;; Because button-type properties are inherited by buttons using the
;; special `category' property (implemented by both overlays and
;; text-properties), we need to store them on a symbol to which the
;; `category' properties can point.  Instead of using the symbol that's
;; the name of each button-type, however, we use a separate symbol (with
;; `-button' appended, and uninterned) to store the properties.  This is
;; to avoid name clashes.

;; [this is an internal function]
(defsubst button-category-symbol (type)
  "Return the symbol used by button-type TYPE to store properties.
Buttons inherit them by setting their `category' property to that symbol."
  (or (get type 'button-category-symbol)
      (error "Unknown button type `%s'" type)))

Miles Bader's avatar
Miles Bader committed
117
(defun define-button-type (name &rest properties)
118
  "Define a `button type' called NAME (a symbol).
Miles Bader's avatar
Miles Bader committed
119 120 121
The remaining arguments form a sequence of PROPERTY VALUE pairs,
specifying properties to use as defaults for buttons with this type
\(a button's type may be set by giving it a `type' property when
Miles Bader's avatar
Miles Bader committed
122
creating the button, using the :type keyword argument).
123

Miles Bader's avatar
Miles Bader committed
124 125 126 127
In addition, the keyword argument :supertype may be used to specify a
button-type from which NAME inherits its default property values
\(however, the inheritance happens only when NAME is defined; subsequent
changes to a supertype are not reflected in its subtypes)."
128 129 130
  (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
	(super-catsym
	 (button-category-symbol
Miles Bader's avatar
Miles Bader committed
131
	  (or (plist-get properties 'supertype)
132 133
	      (plist-get properties :supertype)
	      'button))))
Miles Bader's avatar
Miles Bader committed
134 135 136
    ;; Provide a link so that it's easy to find the real symbol.
    (put name 'button-category-symbol catsym)
    ;; Initialize NAME's properties using the global defaults.
137
    (let ((default-props (symbol-plist super-catsym)))
Miles Bader's avatar
Miles Bader committed
138 139 140 141 142 143 144
      (while default-props
	(put catsym (pop default-props) (pop default-props))))
    ;; Add NAME as the `type' property, which will then be returned as
    ;; the type property of individual buttons.
    (put catsym 'type name)
    ;; Add the properties in PROPERTIES to the real symbol.
    (while properties
Miles Bader's avatar
Miles Bader committed
145 146 147 148
      (let ((prop (pop properties)))
	(when (eq prop :supertype)
	  (setq prop 'supertype))
	(put catsym prop (pop properties))))
149 150 151
    ;; Make sure there's a `supertype' property
    (unless (get catsym 'supertype)
      (put catsym 'supertype 'button))
Miles Bader's avatar
Miles Bader committed
152 153 154 155 156 157 158 159 160 161
    name))

(defun button-type-put (type prop val)
  "Set the button-type TYPE's PROP property to VAL."
  (put (button-category-symbol type) prop val))

(defun button-type-get (type prop)
  "Get the property of button-type TYPE named PROP."
  (get (button-category-symbol type) prop))

162 163 164 165 166 167 168
(defun button-type-subtype-p (type supertype)
  "Return t if button-type TYPE is a subtype of SUPERTYPE."
  (or (eq type supertype)
      (and type
	   (button-type-subtype-p (button-type-get type 'supertype)
				  supertype))))

Miles Bader's avatar
Miles Bader committed
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197

;; Button properties and other attributes

(defun button-start (button)
  "Return the position at which BUTTON starts."
  (if (overlayp button)
      (overlay-start button)
    ;; Must be a text-property button.
    (or (previous-single-property-change (1+ button) 'button)
	(point-min))))

(defun button-end (button)
  "Return the position at which BUTTON ends."
  (if (overlayp button)
      (overlay-end button)
    ;; Must be a text-property button.
    (or (next-single-property-change button 'button)
	(point-max))))

(defun button-get (button prop)
  "Get the property of button BUTTON named PROP."
  (if (overlayp button)
      (overlay-get button prop)
    ;; Must be a text-property button.
    (get-text-property button prop)))

(defun button-put (button prop val)
  "Set BUTTON's PROP property to VAL."
  ;; Treat some properties specially.
Miles Bader's avatar
Miles Bader committed
198
  (cond ((memq prop '(type :type))
Miles Bader's avatar
Miles Bader committed
199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217
	 ;; We translate a `type' property a `category' property, since
	 ;; that's what's actually used by overlays/text-properties for
	 ;; inheriting properties.
	 (setq prop 'category)
	 (setq val (button-category-symbol val)))
	((eq prop 'category)
	 ;; Disallow updating the `category' property directly.
	 (error "Button `category' property may not be set directly")))
  ;; Add the property.
  (if (overlayp button)
      (overlay-put button prop val)
    ;; Must be a text-property button.
    (put-text-property
     (or (previous-single-property-change (1+ button) 'button)
	 (point-min))
     (or (next-single-property-change button 'button)
	 (point-max))
     prop val)))

218
(defsubst button-activate (button &optional use-mouse-action)
219 220 221 222
  "Call BUTTON's action property.
If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
instead of its normal action; if the button has no mouse-action,
the normal action is used instead."
223 224 225 226 227 228 229 230
  (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
		    (button-get button 'action))))
    (if (markerp action)
	(save-selected-window
	  (select-window (display-buffer (marker-buffer action)))
	  (goto-char action)
	  (recenter 0))
      (funcall action button))))
Miles Bader's avatar
Miles Bader committed
231 232 233 234 235

(defun button-label (button)
  "Return BUTTON's text label."
  (buffer-substring-no-properties (button-start button) (button-end button)))

Miles Bader's avatar
Miles Bader committed
236
(defsubst button-type (button)
Miles Bader's avatar
Miles Bader committed
237
  "Return BUTTON's button-type."
Miles Bader's avatar
Miles Bader committed
238 239
  (button-get button 'type))

240 241 242 243
(defun button-has-type-p (button type)
  "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes."
  (button-type-subtype-p (button-get button 'type) type))

Miles Bader's avatar
Miles Bader committed
244 245 246 247 248 249

;; Creating overlay buttons

(defun make-button (beg end &rest properties)
  "Make a button from BEG to END in the current buffer.
The remaining arguments form a sequence of PROPERTY VALUE pairs,
Miles Bader's avatar
Miles Bader committed
250 251 252 253
specifying properties to add to the button.
In addition, the keyword argument :type may be used to specify a
button-type from which to inherit other properties; see
`define-button-type'.
Miles Bader's avatar
Miles Bader committed
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270

Also see `make-text-button', `insert-button'."
  (let ((overlay (make-overlay beg end nil t nil)))
    (while properties
      (button-put overlay (pop properties) (pop properties)))
    ;; Put a pointer to the button in the overlay, so it's easy to get
    ;; when we don't actually have a reference to the overlay.
    (overlay-put overlay 'button overlay)
    ;; If the user didn't specify a type, use the default.
    (unless (overlay-get overlay 'category)
      (overlay-put overlay 'category 'default-button))
    ;; OVERLAY is the button, so return it
    overlay))

(defun insert-button (label &rest properties)
  "Insert a button with the label LABEL.
The remaining arguments form a sequence of PROPERTY VALUE pairs,
Miles Bader's avatar
Miles Bader committed
271 272 273 274
specifying properties to add to the button.
In addition, the keyword argument :type may be used to specify a
button-type from which to inherit other properties; see
`define-button-type'.
Miles Bader's avatar
Miles Bader committed
275 276 277 278 279 280 281 282 283 284 285 286 287

Also see `insert-text-button', `make-button'."
  (apply #'make-button
	 (prog1 (point) (insert label))
	 (point)
	 properties))


;; Creating text-property buttons

(defun make-text-button (beg end &rest properties)
  "Make a button from BEG to END in the current buffer.
The remaining arguments form a sequence of PROPERTY VALUE pairs,
Miles Bader's avatar
Miles Bader committed
288 289 290 291
specifying properties to add to the button.
In addition, the keyword argument :type may be used to specify a
button-type from which to inherit other properties; see
`define-button-type'.
Miles Bader's avatar
Miles Bader committed
292 293

This function is like `make-button', except that the button is actually
Glenn Morris's avatar
Glenn Morris committed
294 295 296 297 298 299
part of the text instead of being a property of the buffer.  That is,
this function uses text properties, the other uses overlays.
Creating large numbers of buttons can also be somewhat faster
using `make-text-button'.  Note, however, that if there is an existing
face property at the site of the button, the button face may not be visible.
You may want to use `make-button' in that case.
Miles Bader's avatar
Miles Bader committed
300

301 302
BEG can also be a string, in which case it is made into a button.

Miles Bader's avatar
Miles Bader committed
303
Also see `insert-text-button'."
304 305
  (let ((object nil)
        (type-entry
306 307
	 (or (plist-member properties 'type)
	     (plist-member properties :type))))
308 309
    (when (stringp beg)
      (setq object beg beg 0 end (length object)))
310 311 312 313 314 315 316 317 318 319 320
    ;; Disallow setting the `category' property directly.
    (when (plist-get properties 'category)
      (error "Button `category' property may not be set directly"))
    (if (null type-entry)
	;; The user didn't specify a `type' property, use the default.
	(setq properties (cons 'category (cons 'default-button properties)))
      ;; The user did specify a `type' property.  Translate it into a
      ;; `category' property, which is what's actually used by
      ;; text-properties for inheritance.
      (setcar type-entry 'category)
      (setcar (cdr type-entry)
321 322 323 324 325 326 327 328 329 330
	      (button-category-symbol (car (cdr type-entry)))))
    ;; Now add all the text properties at once
    (add-text-properties beg end
                         ;; Each button should have a non-eq `button'
                         ;; property so that next-single-property-change can
                         ;; detect boundaries reliably.
                         (cons 'button (cons (list t) properties))
                         object)
    ;; Return something that can be used to get at the button.
    beg))
Miles Bader's avatar
Miles Bader committed
331 332 333 334

(defun insert-text-button (label &rest properties)
  "Insert a button with the label LABEL.
The remaining arguments form a sequence of PROPERTY VALUE pairs,
Miles Bader's avatar
Miles Bader committed
335 336 337 338
specifying properties to add to the button.
In addition, the keyword argument :type may be used to specify a
button-type from which to inherit other properties; see
`define-button-type'.
Miles Bader's avatar
Miles Bader committed
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361

This function is like `insert-button', except that the button is
actually part of the text instead of being a property of the buffer.
Creating large numbers of buttons can also be somewhat faster using
`insert-text-button'.

Also see `make-text-button'."
  (apply #'make-text-button
	 (prog1 (point) (insert label))
	 (point)
	 properties))


;; Finding buttons in a buffer

(defun button-at (pos)
  "Return the button at position POS in the current buffer, or nil."
  (let ((button (get-char-property pos 'button)))
    (if (or (overlayp button) (null button))
	button
      ;; Must be a text-property button; return a marker pointing to it.
      (copy-marker pos t))))

362 363
(defun next-button (pos &optional count-current)
  "Return the next button after position POS in the current buffer.
Miles Bader's avatar
Miles Bader committed
364
If COUNT-CURRENT is non-nil, count any button at POS in the search,
365
instead of starting at the next button."
Miles Bader's avatar
Miles Bader committed
366 367 368
    (unless count-current
      ;; Search for the next button boundary.
      (setq pos (next-single-char-property-change pos 'button)))
369 370
    (and (< pos (point-max))
	 (or (button-at pos)
Miles Bader's avatar
Miles Bader committed
371 372
	     ;; We must have originally been on a button, and are now in
	     ;; the inter-button space.  Recurse to find a button.
373
	     (next-button pos))))
Miles Bader's avatar
Miles Bader committed
374

375
(defun previous-button (pos &optional count-current)
376
  "Return the previous button before position POS in the current buffer.
Miles Bader's avatar
Miles Bader committed
377
If COUNT-CURRENT is non-nil, count any button at POS in the search,
378
instead of starting at the next button."
379 380 381 382 383 384 385 386 387 388 389 390
  (let ((button (button-at pos)))
    (if button
	(if count-current
	    button
	  ;; We started out on a button, so move to its start and look
	  ;; for the previous button boundary.
	  (setq pos (previous-single-char-property-change
		     (button-start button) 'button))
	  (let ((new-button (button-at pos)))
	    (if new-button
		;; We are in a button again; this can happen if there
		;; are adjacent buttons (or at bob).
Chong Yidong's avatar
Chong Yidong committed
391
		(unless (= pos (button-start button)) new-button)
392 393 394 395 396 397 398
	      ;; We are now in the space between buttons.
	      (previous-button pos))))
      ;; We started out in the space between buttons.
      (setq pos (previous-single-char-property-change pos 'button))
      (or (button-at pos)
	  (and (> pos (point-min))
	       (button-at (1- pos)))))))
Miles Bader's avatar
Miles Bader committed
399 400 401 402


;; User commands

403
(defun push-button (&optional pos use-mouse-action)
Miles Bader's avatar
Miles Bader committed
404
  "Perform the action specified by a button at location POS.
405 406
POS may be either a buffer position or a mouse-event.  If
USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
407
instead of its normal action; if the button has no mouse-action,
408 409
the normal action is used instead.  The action may be either a
function to call or a marker to display.
Miles Bader's avatar
Miles Bader committed
410 411 412 413 414 415 416 417 418 419 420
POS defaults to point, except when `push-button' is invoked
interactively as the result of a mouse-event, in which case, the
mouse event is used.
If there's no button at POS, do nothing and return nil, otherwise
return t."
  (interactive
   (list (if (integerp last-command-event) (point) last-command-event)))
  (if (and (not (integerp pos)) (eventp pos))
      ;; POS is a mouse event; switch to the proper window/buffer
      (let ((posn (event-start pos)))
	(with-current-buffer (window-buffer (posn-window posn))
421
	  (push-button (posn-point posn) t)))
Miles Bader's avatar
Miles Bader committed
422 423 424 425
    ;; POS is just normal position
    (let ((button (button-at (or pos (point)))))
      (if (not button)
	  nil
426
	(button-activate button use-mouse-action)
Miles Bader's avatar
Miles Bader committed
427 428 429 430
	t))))

(defun forward-button (n &optional wrap display-message)
  "Move to the Nth next button, or Nth previous button if N is negative.
431
If N is 0, move to the start of any button at point.
Miles Bader's avatar
Miles Bader committed
432 433 434
If WRAP is non-nil, moving past either end of the buffer continues from the
other end.
If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
435
Any button with a non-nil `skip' property is skipped over.
Miles Bader's avatar
Miles Bader committed
436 437
Returns the button found."
  (interactive "p\nd\nd")
438 439 440 441 442 443 444
  (let (button)
    (if (zerop n)
	;; Move to start of current button
	(if (setq button (button-at (point)))
	    (goto-char (button-start button)))
      ;; Move to Nth next button
      (let ((iterator (if (> n 0) #'next-button #'previous-button))
445 446
	    (wrap-start (if (> n 0) (point-min) (point-max)))
	    opoint fail)
447 448
	(setq n (abs n))
	(setq button t)			; just to start the loop
449
	(while (and (null fail) (> n 0) button)
450 451 452 453 454
	  (setq button (funcall iterator (point)))
	  (when (and (not button) wrap)
	    (setq button (funcall iterator wrap-start t)))
	  (when button
	    (goto-char (button-start button))
455 456 457 458 459 460
	    ;; Avoid looping forever (e.g., if all the buttons have
	    ;; the `skip' property).
	    (cond ((null opoint)
		   (setq opoint (point)))
		  ((= opoint (point))
		   (setq fail t)))
461 462
	    (unless (button-get button 'skip)
	      (setq n (1- n)))))))
Miles Bader's avatar
Miles Bader committed
463 464 465 466 467 468 469 470 471
    (if (null button)
	(error (if wrap "No buttons!" "No more buttons"))
      (let ((msg (and display-message (button-get button 'help-echo))))
	(when msg
	  (message "%s" msg)))
      button)))

(defun backward-button (n &optional wrap display-message)
  "Move to the Nth previous button, or Nth next button if N is negative.
472
If N is 0, move to the start of any button at point.
Miles Bader's avatar
Miles Bader committed
473 474 475
If WRAP is non-nil, moving past either end of the buffer continues from the
other end.
If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
476
Any button with a non-nil `skip' property is skipped over.
Miles Bader's avatar
Miles Bader committed
477 478 479 480 481 482 483 484
Returns the button found."
  (interactive "p\nd\nd")
  (forward-button (- n) wrap display-message))


(provide 'button)

;;; button.el ends here