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