lisp/button.el

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