lisp/button.el

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