lisp/button.el

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