lisp/button.el

   1 ;;; button.el --- clickable buttons
   2 ;;
   3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
   4 ;;   2010, 2011  Free Software Foundation, Inc.
   5 ;;
   6 ;; Author: Miles Bader <miles@gnu.org>
   7 ;; Keywords: extensions
   8 ;; Package: emacs
   9 ;;
  10 ;; This file is part of GNU Emacs.
  11 ;;
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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.  Note however that if there is
  42 ;; an existing face text-property at the site of the button, the
  43 ;; button face may not be visible.  Using overlays avoids this.
  44 ;;
  45 ;; Using `define-button-type' to define default properties for buttons
  46 ;; is not necessary, but it is is encouraged, since doing so makes the
  47 ;; resulting code clearer and more efficient.
  48 ;;
  49
  50 ;;; Code:
  51
  52 \f
  53 ;; Globals
  54
  55 ;; Use color for the MS-DOS port because it doesn't support underline.
  56 ;; FIXME if MS-DOS correctly answers the (supports) question, it need
  57 ;; no longer be a special case.
  58 (defface button '((((type pc) (class color))
  59                    (:foreground "lightblue"))
  60                   (((supports :underline t)) :underline t)
  61                   (t (:foreground "lightblue")))
  62   "Default face used for buttons."
  63   :group 'basic-faces)
  64
  65 (defvar button-map
  66   (let ((map (make-sparse-keymap)))
  67     ;; The following definition needs to avoid using escape sequences that
  68     ;; might get converted to ^M when building loaddefs.el
  69     (define-key map [(control ?m)] 'push-button)
  70     (define-key map [mouse-2] 'push-button)
  71     map)
  72   "Keymap used by buttons.")
  73
  74 (defvar button-buffer-map
  75   (let ((map (make-sparse-keymap)))
  76     (define-key map [?\t] 'forward-button)
  77     (define-key map "\e\t" 'backward-button)
  78     (define-key map [backtab] 'backward-button)
  79     map)
  80   "Keymap useful for buffers containing buttons.
  81 Mode-specific keymaps may want to use this as their parent keymap.")
  82
  83 ;; Default properties for buttons
  84 (put 'default-button 'face 'button)
  85 (put 'default-button 'mouse-face 'highlight)
  86 (put 'default-button 'keymap button-map)
  87 (put 'default-button 'type 'button)
  88 ;; action may be either a function to call, or a marker to go to
  89 (put 'default-button 'action 'ignore)
  90 (put 'default-button 'help-echo (purecopy "mouse-2, RET: Push this button"))
  91 ;; Make overlay buttons go away if their underlying text is deleted.
  92 (put 'default-button 'evaporate t)
  93 ;; Prevent insertions adjacent to the text-property buttons from
  94 ;; inheriting its properties.
  95 (put 'default-button 'rear-nonsticky t)
  96
  97 ;; A `category-symbol' property for the default button type
  98 (put 'button 'button-category-symbol 'default-button)
  99
 100 \f
 101 ;; Button types (which can be used to hold default properties for buttons)
 102
 103 ;; Because button-type properties are inherited by buttons using the
 104 ;; special `category' property (implemented by both overlays and
 105 ;; text-properties), we need to store them on a symbol to which the
 106 ;; `category' properties can point.  Instead of using the symbol that's
 107 ;; the name of each button-type, however, we use a separate symbol (with
 108 ;; `-button' appended, and uninterned) to store the properties.  This is
 109 ;; to avoid name clashes.
 110
 111 ;; [this is an internal function]
 112 (defsubst button-category-symbol (type)
 113   "Return the symbol used by button-type TYPE to store properties.
 114 Buttons inherit them by setting their `category' property to that symbol."
 115   (or (get type 'button-category-symbol)
 116       (error "Unknown button type `%s'" type)))
 117
 118 (defun define-button-type (name &rest properties)
 119   "Define a `button type' called NAME (a symbol).
 120 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 121 specifying properties to use as defaults for buttons with this type
 122 \(a button's type may be set by giving it a `type' property when
 123 creating the button, using the :type keyword argument).
 124
 125 In addition, the keyword argument :supertype may be used to specify a
 126 button-type from which NAME inherits its default property values
 127 \(however, the inheritance happens only when NAME is defined; subsequent
 128 changes to a supertype are not reflected in its subtypes)."
 129   (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
 130         (super-catsym
 131          (button-category-symbol
 132           (or (plist-get properties 'supertype)
 133               (plist-get properties :supertype)
 134               'button))))
 135     ;; Provide a link so that it's easy to find the real symbol.
 136     (put name 'button-category-symbol catsym)
 137     ;; Initialize NAME's properties using the global defaults.
 138     (let ((default-props (symbol-plist super-catsym)))
 139       (while default-props
 140         (put catsym (pop default-props) (pop default-props))))
 141     ;; Add NAME as the `type' property, which will then be returned as
 142     ;; the type property of individual buttons.
 143     (put catsym 'type name)
 144     ;; Add the properties in PROPERTIES to the real symbol.
 145     (while properties
 146       (let ((prop (pop properties)))
 147         (when (eq prop :supertype)
 148           (setq prop 'supertype))
 149         (put catsym prop (pop properties))))
 150     ;; Make sure there's a `supertype' property
 151     (unless (get catsym 'supertype)
 152       (put catsym 'supertype 'button))
 153     name))
 154
 155 (defun button-type-put (type prop val)
 156   "Set the button-type TYPE's PROP property to VAL."
 157   (put (button-category-symbol type) prop val))
 158
 159 (defun button-type-get (type prop)
 160   "Get the property of button-type TYPE named PROP."
 161   (get (button-category-symbol type) prop))
 162
 163 (defun button-type-subtype-p (type supertype)
 164   "Return t if button-type TYPE is a subtype of SUPERTYPE."
 165   (or (eq type supertype)
 166       (and type
 167            (button-type-subtype-p (button-type-get type 'supertype)
 168                                   supertype))))
 169
 170 \f
 171 ;; Button properties and other attributes
 172
 173 (defun button-start (button)
 174   "Return the position at which BUTTON starts."
 175   (if (overlayp button)
 176       (overlay-start button)
 177     ;; Must be a text-property button.
 178     (or (previous-single-property-change (1+ button) 'button)
 179         (point-min))))
 180
 181 (defun button-end (button)
 182   "Return the position at which BUTTON ends."
 183   (if (overlayp button)
 184       (overlay-end button)
 185     ;; Must be a text-property button.
 186     (or (next-single-property-change button 'button)
 187         (point-max))))
 188
 189 (defun button-get (button prop)
 190   "Get the property of button BUTTON named PROP."
 191   (if (overlayp button)
 192       (overlay-get button prop)
 193     ;; Must be a text-property button.
 194     (get-text-property button prop)))
 195
 196 (defun button-put (button prop val)
 197   "Set BUTTON's PROP property to VAL."
 198   ;; Treat some properties specially.
 199   (cond ((memq prop '(type :type))
 200          ;; We translate a `type' property a `category' property, since
 201          ;; that's what's actually used by overlays/text-properties for
 202          ;; inheriting properties.
 203          (setq prop 'category)
 204          (setq val (button-category-symbol val)))
 205         ((eq prop 'category)
 206          ;; Disallow updating the `category' property directly.
 207          (error "Button `category' property may not be set directly")))
 208   ;; Add the property.
 209   (if (overlayp button)
 210       (overlay-put button prop val)
 211     ;; Must be a text-property button.
 212     (put-text-property
 213      (or (previous-single-property-change (1+ button) 'button)
 214          (point-min))
 215      (or (next-single-property-change button 'button)
 216          (point-max))
 217      prop val)))
 218
 219 (defsubst button-activate (button &optional use-mouse-action)
 220   "Call BUTTON's action property.
 221 If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
 222 instead of its normal action; if the button has no mouse-action,
 223 the normal action is used instead."
 224   (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
 225                     (button-get button 'action))))
 226     (if (markerp action)
 227         (save-selected-window
 228           (select-window (display-buffer (marker-buffer action)))
 229           (goto-char action)
 230           (recenter 0))
 231       (funcall action button))))
 232
 233 (defun button-label (button)
 234   "Return BUTTON's text label."
 235   (buffer-substring-no-properties (button-start button) (button-end button)))
 236
 237 (defsubst button-type (button)
 238   "Return BUTTON's button-type."
 239   (button-get button 'type))
 240
 241 (defun button-has-type-p (button type)
 242   "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes."
 243   (button-type-subtype-p (button-get button 'type) type))
 244
 245 \f
 246 ;; Creating overlay buttons
 247
 248 (defun make-button (beg end &rest properties)
 249   "Make a button from BEG to END in the current buffer.
 250 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 251 specifying properties to add to the button.
 252 In addition, the keyword argument :type may be used to specify a
 253 button-type from which to inherit other properties; see
 254 `define-button-type'.
 255
 256 Also see `make-text-button', `insert-button'."
 257   (let ((overlay (make-overlay beg end nil t nil)))
 258     (while properties
 259       (button-put overlay (pop properties) (pop properties)))
 260     ;; Put a pointer to the button in the overlay, so it's easy to get
 261     ;; when we don't actually have a reference to the overlay.
 262     (overlay-put overlay 'button overlay)
 263     ;; If the user didn't specify a type, use the default.
 264     (unless (overlay-get overlay 'category)
 265       (overlay-put overlay 'category 'default-button))
 266     ;; OVERLAY is the button, so return it
 267     overlay))
 268
 269 (defun insert-button (label &rest properties)
 270   "Insert a button with the label LABEL.
 271 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 272 specifying properties to add to the button.
 273 In addition, the keyword argument :type may be used to specify a
 274 button-type from which to inherit other properties; see
 275 `define-button-type'.
 276
 277 Also see `insert-text-button', `make-button'."
 278   (apply #'make-button
 279          (prog1 (point) (insert label))
 280          (point)
 281          properties))
 282
 283 \f
 284 ;; Creating text-property buttons
 285
 286 (defun make-text-button (beg end &rest properties)
 287   "Make a button from BEG to END in the current buffer.
 288 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 289 specifying properties to add to the button.
 290 In addition, the keyword argument :type may be used to specify a
 291 button-type from which to inherit other properties; see
 292 `define-button-type'.
 293
 294 This function is like `make-button', except that the button is actually
 295 part of the text instead of being a property of the buffer.  That is,
 296 this function uses text properties, the other uses overlays.
 297 Creating large numbers of buttons can also be somewhat faster
 298 using `make-text-button'.  Note, however, that if there is an existing
 299 face property at the site of the button, the button face may not be visible.
 300 You may want to use `make-button' in that case.
 301
 302 BEG can also be a string, in which case it is made into a button.
 303
 304 Also see `insert-text-button'."
 305   (let ((object nil)
 306         (type-entry
 307          (or (plist-member properties 'type)
 308              (plist-member properties :type))))
 309     (when (stringp beg)
 310       (setq object beg beg 0 end (length object)))
 311     ;; Disallow setting the `category' property directly.
 312     (when (plist-get properties 'category)
 313       (error "Button `category' property may not be set directly"))
 314     (if (null type-entry)
 315         ;; The user didn't specify a `type' property, use the default.
 316         (setq properties (cons 'category (cons 'default-button properties)))
 317       ;; The user did specify a `type' property.  Translate it into a
 318       ;; `category' property, which is what's actually used by
 319       ;; text-properties for inheritance.
 320       (setcar type-entry 'category)
 321       (setcar (cdr type-entry)
 322               (button-category-symbol (car (cdr type-entry)))))
 323     ;; Now add all the text properties at once
 324     (add-text-properties beg end
 325                          ;; Each button should have a non-eq `button'
 326                          ;; property so that next-single-property-change can
 327                          ;; detect boundaries reliably.
 328                          (cons 'button (cons (list t) properties))
 329                          object)
 330     ;; Return something that can be used to get at the button.
 331     beg))
 332
 333 (defun insert-text-button (label &rest properties)
 334   "Insert a button with the label LABEL.
 335 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 336 specifying properties to add to the button.
 337 In addition, the keyword argument :type may be used to specify a
 338 button-type from which to inherit other properties; see
 339 `define-button-type'.
 340
 341 This function is like `insert-button', except that the button is
 342 actually part of the text instead of being a property of the buffer.
 343 Creating large numbers of buttons can also be somewhat faster using
 344 `insert-text-button'.
 345
 346 Also see `make-text-button'."
 347   (apply #'make-text-button
 348          (prog1 (point) (insert label))
 349          (point)
 350          properties))
 351
 352 \f
 353 ;; Finding buttons in a buffer
 354
 355 (defun button-at (pos)
 356   "Return the button at position POS in the current buffer, or nil."
 357   (let ((button (get-char-property pos 'button)))
 358     (if (or (overlayp button) (null button))
 359         button
 360       ;; Must be a text-property button; return a marker pointing to it.
 361       (copy-marker pos t))))
 362
 363 (defun next-button (pos &optional count-current)
 364   "Return the next button after position POS in the current buffer.
 365 If COUNT-CURRENT is non-nil, count any button at POS in the search,
 366 instead of starting at the next button."
 367     (unless count-current
 368       ;; Search for the next button boundary.
 369       (setq pos (next-single-char-property-change pos 'button)))
 370     (and (< pos (point-max))
 371          (or (button-at pos)
 372              ;; We must have originally been on a button, and are now in
 373              ;; the inter-button space.  Recurse to find a button.
 374              (next-button pos))))
 375
 376 (defun previous-button (pos &optional count-current)
 377   "Return the previous button before position POS in the current buffer.
 378 If COUNT-CURRENT is non-nil, count any button at POS in the search,
 379 instead of starting at the next button."
 380   (let ((button (button-at pos)))
 381     (if button
 382         (if count-current
 383             button
 384           ;; We started out on a button, so move to its start and look
 385           ;; for the previous button boundary.
 386           (setq pos (previous-single-char-property-change
 387                      (button-start button) 'button))
 388           (let ((new-button (button-at pos)))
 389             (if new-button
 390                 ;; We are in a button again; this can happen if there
 391                 ;; are adjacent buttons (or at bob).
 392                 (unless (= pos (button-start button)) new-button)
 393               ;; We are now in the space between buttons.
 394               (previous-button pos))))
 395       ;; We started out in the space between buttons.
 396       (setq pos (previous-single-char-property-change pos 'button))
 397       (or (button-at pos)
 398           (and (> pos (point-min))
 399                (button-at (1- pos)))))))
 400
 401 \f
 402 ;; User commands
 403
 404 (defun push-button (&optional pos use-mouse-action)
 405   "Perform the action specified by a button at location POS.
 406 POS may be either a buffer position or a mouse-event.  If
 407 USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
 408 instead of its normal action; if the button has no mouse-action,
 409 the normal action is used instead.  The action may be either a
 410 function to call or a marker to display.
 411 POS defaults to point, except when `push-button' is invoked
 412 interactively as the result of a mouse-event, in which case, the
 413 mouse event is used.
 414 If there's no button at POS, do nothing and return nil, otherwise
 415 return t."
 416   (interactive
 417    (list (if (integerp last-command-event) (point) last-command-event)))
 418   (if (and (not (integerp pos)) (eventp pos))
 419       ;; POS is a mouse event; switch to the proper window/buffer
 420       (let ((posn (event-start pos)))
 421         (with-current-buffer (window-buffer (posn-window posn))
 422           (push-button (posn-point posn) t)))
 423     ;; POS is just normal position
 424     (let ((button (button-at (or pos (point)))))
 425       (if (not button)
 426           nil
 427         (button-activate button use-mouse-action)
 428         t))))
 429
 430 (defun forward-button (n &optional wrap display-message)
 431   "Move to the Nth next button, or Nth previous button if N is negative.
 432 If N is 0, move to the start of any button at point.
 433 If WRAP is non-nil, moving past either end of the buffer continues from the
 434 other end.
 435 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
 436 Any button with a non-nil `skip' property is skipped over.
 437 Returns the button found."
 438   (interactive "p\nd\nd")
 439   (let (button)
 440     (if (zerop n)
 441         ;; Move to start of current button
 442         (if (setq button (button-at (point)))
 443             (goto-char (button-start button)))
 444       ;; Move to Nth next button
 445       (let ((iterator (if (> n 0) #'next-button #'previous-button))
 446             (wrap-start (if (> n 0) (point-min) (point-max)))
 447             opoint fail)
 448         (setq n (abs n))
 449         (setq button t)                 ; just to start the loop
 450         (while (and (null fail) (> n 0) button)
 451           (setq button (funcall iterator (point)))
 452           (when (and (not button) wrap)
 453             (setq button (funcall iterator wrap-start t)))
 454           (when button
 455             (goto-char (button-start button))
 456             ;; Avoid looping forever (e.g., if all the buttons have
 457             ;; the `skip' property).
 458             (cond ((null opoint)
 459                    (setq opoint (point)))
 460                   ((= opoint (point))
 461                    (setq fail t)))
 462             (unless (button-get button 'skip)
 463               (setq n (1- n)))))))
 464     (if (null button)
 465         (error (if wrap "No buttons!" "No more buttons"))
 466       (let ((msg (and display-message (button-get button 'help-echo))))
 467         (when msg
 468           (message "%s" msg)))
 469       button)))
 470
 471 (defun backward-button (n &optional wrap display-message)
 472   "Move to the Nth previous button, or Nth next button if N is negative.
 473 If N is 0, move to the start of any button at point.
 474 If WRAP is non-nil, moving past either end of the buffer continues from the
 475 other end.
 476 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
 477 Any button with a non-nil `skip' property is skipped over.
 478 Returns the button found."
 479   (interactive "p\nd\nd")
 480   (forward-button (- n) wrap display-message))
 481
 482
 483 (provide 'button)
 484
 485 ;;; button.el ends here