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