lisp/button.el

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