button.el 16.2 KB
Newer Older
Miles Bader's avatar
Miles Bader committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
;;; button.el --- Clickable buttons
;;
;; Copyright (C) 2001 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: extensions
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; 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
;; extremely large numbers of buttons.
;;
;; 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

(defface button '((t :underline t))
  "Default face used for buttons.")

;;;###autoload
(defvar button-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\r" 'push-button)
    (define-key map [mouse-2] 'push-button)
    map)
  "Keymap used by buttons.")

;;;###autoload
(defvar button-buffer-map
  (let ((map (make-sparse-keymap)))
    (define-key map [?\t] 'forward-button)
    (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)
Miles Bader's avatar
Miles Bader committed
78
(put 'default-button 'action 'ignore)
Miles Bader's avatar
Miles Bader committed
79 80 81 82 83 84 85 86 87 88
(put 'default-button 'help-echo "mouse-2, RET: Push this button")
;; 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)
;; Text property buttons don't have a `button' property of their own, so
;; they inherit this.
(put 'default-button 'button t)

Miles Bader's avatar
Miles Bader committed
89 90 91
;; A `category-symbol' property for the default button type
(put 'button 'button-category-symbol 'default-button)

Miles Bader's avatar
Miles Bader committed
92 93 94

;; Button types (which can be used to hold default properties for buttons)

95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
;; 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
110 111 112 113 114 115
;;;###autoload
(defun define-button-type (name &rest properties)
  "Define a `button type' called NAME.
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
116
creating the button, using the :type keyword argument).
117

Miles Bader's avatar
Miles Bader committed
118 119 120 121
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)."
122
  (let* ((catsym (make-symbol (concat (symbol-name name) "-button")))
Miles Bader's avatar
Miles Bader committed
123 124 125
	 (supertype
	  (or (plist-get properties 'supertype)
	      (plist-get properties :supertype)))
126 127
	 (super-catsym
	  (if supertype (button-category-symbol supertype) 'default-button)))
Miles Bader's avatar
Miles Bader committed
128 129 130
    ;; 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.
131
    (let ((default-props (symbol-plist super-catsym)))
Miles Bader's avatar
Miles Bader committed
132 133 134 135 136 137 138
      (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
139 140 141 142
      (let ((prop (pop properties)))
	(when (eq prop :supertype)
	  (setq prop 'supertype))
	(put catsym prop (pop properties))))
Miles Bader's avatar
Miles Bader committed
143 144 145 146 147 148 149 150 151 152
    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))

153 154 155 156 157 158 159
(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
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188

;; 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
189
  (cond ((memq prop '(type :type))
Miles Bader's avatar
Miles Bader committed
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
	 ;; 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)))

209
(defsubst button-activate (button &optional use-mouse-action)
210 211 212 213 214 215 216
  "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."
  (funcall (or (and use-mouse-action (button-get button 'mouse-action))
	       (button-get button 'action))
	   button))
Miles Bader's avatar
Miles Bader committed
217 218 219 220 221

(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
222
(defsubst button-type (button)
Miles Bader's avatar
Miles Bader committed
223
  "Return BUTTON's button-type."
Miles Bader's avatar
Miles Bader committed
224 225
  (button-get button 'type))

226 227 228 229
(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
230 231 232 233 234 235 236

;; Creating overlay buttons

;;;###autoload
(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
237 238 239 240
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
241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258

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))

;;;###autoload
(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
259 260 261 262
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
263 264 265 266 267 268 269 270 271 272 273 274 275 276

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


;; Creating text-property buttons

;;;###autoload
(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
277 278 279 280
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
281 282 283 284 285 286 287 288 289 290 291 292 293 294

This function is like `make-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
`make-text-button'.

Also see `insert-text-button'."
  (let (prop val)
    (while properties
      (setq prop (pop properties))
      (setq val (pop properties))
      ;; Note that all the following code is basically equivalent to
      ;; `button-put', but we can do it much more efficiently since we
      ;; already have BEG and END.
Miles Bader's avatar
Miles Bader committed
295
      (cond ((memq prop '(type :type))
Miles Bader's avatar
Miles Bader committed
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
	     ;; We translate a `type' property into a `category'
	     ;; property, since that's what's actually used by
	     ;; text-properties for inheritance.
	     (setq prop 'category)
	     (setq val (button-category-symbol val)))
	    ((eq prop 'category)
	     ;; Disallow setting the `category' property directly.
	     (error "Button `category' property may not be set directly")))
      ;; Add the property.
      (put-text-property beg end prop val)))
  ;; Return something that can be used to get at the button.
  beg)

;;;###autoload
(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
313 314 315 316
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
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339

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))))

340 341
(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
342
If COUNT-CURRENT is non-nil, count any button at POS in the search,
343
instead of starting at the next button."
Miles Bader's avatar
Miles Bader committed
344 345 346
    (unless count-current
      ;; Search for the next button boundary.
      (setq pos (next-single-char-property-change pos 'button)))
347 348
    (and (< pos (point-max))
	 (or (button-at pos)
Miles Bader's avatar
Miles Bader committed
349 350
	     ;; We must have originally been on a button, and are now in
	     ;; the inter-button space.  Recurse to find a button.
351
	     (next-button pos))))
Miles Bader's avatar
Miles Bader committed
352

353
(defun previous-button (pos &optional count-current)
Miles Bader's avatar
Miles Bader committed
354 355
  "Return the Nth button before position POS in the current buffer.
If COUNT-CURRENT is non-nil, count any button at POS in the search,
356 357 358 359 360 361 362 363
instead of starting at the next button."
  (unless count-current
    (setq pos (previous-single-char-property-change pos 'button)))
  (and (> pos (point-min))
       (or (button-at (1- pos))
	   ;; We must have originally been on a button, and are now in
	   ;; the inter-button space.  Recurse to find a button.
	   (previous-button pos))))
Miles Bader's avatar
Miles Bader committed
364 365 366 367


;; User commands

368
(defun push-button (&optional pos use-mouse-action)
Miles Bader's avatar
Miles Bader committed
369 370
  "Perform the action specified by a button at location POS.
POS may be either a buffer position or a mouse-event.
371 372 373
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.
Miles Bader's avatar
Miles Bader committed
374 375 376 377 378 379 380 381 382 383 384
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))
385
	  (push-button (posn-point posn) t)))
Miles Bader's avatar
Miles Bader committed
386 387 388 389
    ;; POS is just normal position
    (let ((button (button-at (or pos (point)))))
      (if (not button)
	  nil
390
	(button-activate button use-mouse-action)
Miles Bader's avatar
Miles Bader committed
391 392 393 394
	t))))

(defun forward-button (n &optional wrap display-message)
  "Move to the Nth next button, or Nth previous button if N is negative.
395
If N is 0, move to the start of any button at point.
Miles Bader's avatar
Miles Bader committed
396 397 398
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.
399
Any button with a non-nil `skip' property is skipped over.
Miles Bader's avatar
Miles Bader committed
400 401
Returns the button found."
  (interactive "p\nd\nd")
402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
  (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))
	    (wrap-start (if (> n 0) (point-min) (point-max))))
	(setq n (abs n))
	(setq button t)			; just to start the loop
	(while (and (> n 0) button)
	  (setq button (funcall iterator (point)))
	  (when (and (not button) wrap)
	    (setq button (funcall iterator wrap-start t)))
	  (when button
	    (goto-char (button-start button))
	    (unless (button-get button 'skip)
	      (setq n (1- n)))))))
Miles Bader's avatar
Miles Bader committed
420 421 422 423 424 425 426 427 428
    (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.
429
If N is 0, move to the start of any button at point.
Miles Bader's avatar
Miles Bader committed
430 431 432
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.
433
Any button with a non-nil `skip' property is skipped over.
Miles Bader's avatar
Miles Bader committed
434 435 436 437 438 439 440 441
Returns the button found."
  (interactive "p\nd\nd")
  (forward-button (- n) wrap display-message))


(provide 'button)

;;; button.el ends here