lisp/button.el

   1 ;;; button.el --- clickable buttons
   2 ;;
   3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008 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, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; This package defines functions for inserting and manipulating
  29 ;; clickable buttons in Emacs buffers, such as might be used for help
  30 ;; hyperlinks, etc.
  31 ;;
  32 ;; In some ways it duplicates functionality also offered by the
  33 ;; `widget' package, but the button package has the advantage that it
  34 ;; is (1) much faster, (2) much smaller, and (3) much, much, simpler
  35 ;; (the code, that is, not the interface).
  36 ;;
  37 ;; Buttons can either use overlays, in which case the button is
  38 ;; represented by the overlay itself, or text-properties, in which case
  39 ;; the button is represented by a marker or buffer-position pointing
  40 ;; somewhere in the button.  In the latter case, no markers into the
  41 ;; buffer are retained, which is important for speed if there are are
  42 ;; extremely large numbers of buttons.
  43 ;;
  44 ;; Using `define-button-type' to define default properties for buttons
  45 ;; is not necessary, but it is 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 '((((type pc) (class color))
  58                    (:foreground "lightblue"))
  59                   (((supports :underline t)) :underline t)
  60                   (t (:foreground "lightblue")))
  61   "Default face used for buttons."
  62   :group 'basic-faces)
  63
  64 ;;;###autoload
  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 ;;;###autoload
  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 "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 ;;;###autoload
 120 (defun define-button-type (name &rest properties)
 121   "Define a `button type' called NAME (a symbol).
 122 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 123 specifying properties to use as defaults for buttons with this type
 124 \(a button's type may be set by giving it a `type' property when
 125 creating the button, using the :type keyword argument).
 126
 127 In addition, the keyword argument :supertype may be used to specify a
 128 button-type from which NAME inherits its default property values
 129 \(however, the inheritance happens only when NAME is defined; subsequent
 130 changes to a supertype are not reflected in its subtypes)."
 131   (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
 132         (super-catsym
 133          (button-category-symbol
 134           (or (plist-get properties 'supertype)
 135               (plist-get properties :supertype)
 136               'button))))
 137     ;; Provide a link so that it's easy to find the real symbol.
 138     (put name 'button-category-symbol catsym)
 139     ;; Initialize NAME's properties using the global defaults.
 140     (let ((default-props (symbol-plist super-catsym)))
 141       (while default-props
 142         (put catsym (pop default-props) (pop default-props))))
 143     ;; Add NAME as the `type' property, which will then be returned as
 144     ;; the type property of individual buttons.
 145     (put catsym 'type name)
 146     ;; Add the properties in PROPERTIES to the real symbol.
 147     (while properties
 148       (let ((prop (pop properties)))
 149         (when (eq prop :supertype)
 150           (setq prop 'supertype))
 151         (put catsym prop (pop properties))))
 152     ;; Make sure there's a `supertype' property
 153     (unless (get catsym 'supertype)
 154       (put catsym 'supertype 'button))
 155     name))
 156
 157 (defun button-type-put (type prop val)
 158   "Set the button-type TYPE's PROP property to VAL."
 159   (put (button-category-symbol type) prop val))
 160
 161 (defun button-type-get (type prop)
 162   "Get the property of button-type TYPE named PROP."
 163   (get (button-category-symbol type) prop))
 164
 165 (defun button-type-subtype-p (type supertype)
 166   "Return t if button-type TYPE is a subtype of SUPERTYPE."
 167   (or (eq type supertype)
 168       (and type
 169            (button-type-subtype-p (button-type-get type 'supertype)
 170                                   supertype))))
 171
 172 \f
 173 ;; Button properties and other attributes
 174
 175 (defun button-start (button)
 176   "Return the position at which BUTTON starts."
 177   (if (overlayp button)
 178       (overlay-start button)
 179     ;; Must be a text-property button.
 180     (or (previous-single-property-change (1+ button) 'button)
 181         (point-min))))
 182
 183 (defun button-end (button)
 184   "Return the position at which BUTTON ends."
 185   (if (overlayp button)
 186       (overlay-end button)
 187     ;; Must be a text-property button.
 188     (or (next-single-property-change button 'button)
 189         (point-max))))
 190
 191 (defun button-get (button prop)
 192   "Get the property of button BUTTON named PROP."
 193   (if (overlayp button)
 194       (overlay-get button prop)
 195     ;; Must be a text-property button.
 196     (get-text-property button prop)))
 197
 198 (defun button-put (button prop val)
 199   "Set BUTTON's PROP property to VAL."
 200   ;; Treat some properties specially.
 201   (cond ((memq prop '(type :type))
 202          ;; We translate a `type' property a `category' property, since
 203          ;; that's what's actually used by overlays/text-properties for
 204          ;; inheriting properties.
 205          (setq prop 'category)
 206          (setq val (button-category-symbol val)))
 207         ((eq prop 'category)
 208          ;; Disallow updating the `category' property directly.
 209          (error "Button `category' property may not be set directly")))
 210   ;; Add the property.
 211   (if (overlayp button)
 212       (overlay-put button prop val)
 213     ;; Must be a text-property button.
 214     (put-text-property
 215      (or (previous-single-property-change (1+ button) 'button)
 216          (point-min))
 217      (or (next-single-property-change button 'button)
 218          (point-max))
 219      prop val)))
 220
 221 (defsubst button-activate (button &optional use-mouse-action)
 222   "Call BUTTON's action property.
 223 If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
 224 instead of its normal action; if the button has no mouse-action,
 225 the normal action is used instead."
 226   (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
 227                     (button-get button 'action))))
 228     (if (markerp action)
 229         (save-selected-window
 230           (select-window (display-buffer (marker-buffer action)))
 231           (goto-char action)
 232           (recenter 0))
 233       (funcall action button))))
 234
 235 (defun button-label (button)
 236   "Return BUTTON's text label."
 237   (buffer-substring-no-properties (button-start button) (button-end button)))
 238
 239 (defsubst button-type (button)
 240   "Return BUTTON's button-type."
 241   (button-get button 'type))
 242
 243 (defun button-has-type-p (button type)
 244   "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes."
 245   (button-type-subtype-p (button-get button 'type) type))
 246
 247 \f
 248 ;; Creating overlay buttons
 249
 250 ;;;###autoload
 251 (defun make-button (beg end &rest properties)
 252   "Make a button from BEG to END in the current buffer.
 253 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 254 specifying properties to add to the button.
 255 In addition, the keyword argument :type may be used to specify a
 256 button-type from which to inherit other properties; see
 257 `define-button-type'.
 258
 259 Also see `make-text-button', `insert-button'."
 260   (let ((overlay (make-overlay beg end nil t nil)))
 261     (while properties
 262       (button-put overlay (pop properties) (pop properties)))
 263     ;; Put a pointer to the button in the overlay, so it's easy to get
 264     ;; when we don't actually have a reference to the overlay.
 265     (overlay-put overlay 'button overlay)
 266     ;; If the user didn't specify a type, use the default.
 267     (unless (overlay-get overlay 'category)
 268       (overlay-put overlay 'category 'default-button))
 269     ;; OVERLAY is the button, so return it
 270     overlay))
 271
 272 ;;;###autoload
 273 (defun insert-button (label &rest properties)
 274   "Insert a button with the label LABEL.
 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 `insert-text-button', `make-button'."
 282   (apply #'make-button
 283          (prog1 (point) (insert label))
 284          (point)
 285          properties))
 286
 287 \f
 288 ;; Creating text-property buttons
 289
 290 ;;;###autoload
 291 (defun make-text-button (beg end &rest properties)
 292   "Make a button from BEG to END in the current buffer.
 293 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 294 specifying properties to add to the button.
 295 In addition, the keyword argument :type may be used to specify a
 296 button-type from which to inherit other properties; see
 297 `define-button-type'.
 298
 299 This function is like `make-button', except that the button is actually
 300 part of the text instead of being a property of the buffer.  Creating
 301 large numbers of buttons can also be somewhat faster using
 302 `make-text-button'.
 303
 304 Also see `insert-text-button'."
 305   (let ((type-entry
 306          (or (plist-member properties 'type)
 307              (plist-member properties :type))))
 308     ;; Disallow setting the `category' property directly.
 309     (when (plist-get properties 'category)
 310       (error "Button `category' property may not be set directly"))
 311     (if (null type-entry)
 312         ;; The user didn't specify a `type' property, use the default.
 313         (setq properties (cons 'category (cons 'default-button properties)))
 314       ;; The user did specify a `type' property.  Translate it into a
 315       ;; `category' property, which is what's actually used by
 316       ;; text-properties for inheritance.
 317       (setcar type-entry 'category)
 318       (setcar (cdr type-entry)
 319               (button-category-symbol (car (cdr type-entry))))))
 320   ;; Now add all the text properties at once
 321   (add-text-properties beg end
 322                        ;; Each button should have a non-eq `button'
 323                        ;; property so that next-single-property-change can
 324                        ;; detect boundaries reliably.
 325                        (cons 'button (cons (list t) properties)))
 326   ;; Return something that can be used to get at the button.
 327   beg)
 328
 329 ;;;###autoload
 330 (defun insert-text-button (label &rest properties)
 331   "Insert a button with the label LABEL.
 332 The remaining arguments form a sequence of PROPERTY VALUE pairs,
 333 specifying properties to add to the button.
 334 In addition, the keyword argument :type may be used to specify a
 335 button-type from which to inherit other properties; see
 336 `define-button-type'.
 337
 338 This function is like `insert-button', except that the button is
 339 actually part of the text instead of being a property of the buffer.
 340 Creating large numbers of buttons can also be somewhat faster using
 341 `insert-text-button'.
 342
 343 Also see `make-text-button'."
 344   (apply #'make-text-button
 345          (prog1 (point) (insert label))
 346          (point)
 347          properties))
 348
 349 \f
 350 ;; Finding buttons in a buffer
 351
 352 (defun button-at (pos)
 353   "Return the button at position POS in the current buffer, or nil."
 354   (let ((button (get-char-property pos 'button)))
 355     (if (or (overlayp button) (null button))
 356         button
 357       ;; Must be a text-property button; return a marker pointing to it.
 358       (copy-marker pos t))))
 359
 360 (defun next-button (pos &optional count-current)
 361   "Return the next button after position POS in the current buffer.
 362 If COUNT-CURRENT is non-nil, count any button at POS in the search,
 363 instead of starting at the next button."
 364     (unless count-current
 365       ;; Search for the next button boundary.
 366       (setq pos (next-single-char-property-change pos 'button)))
 367     (and (< pos (point-max))
 368          (or (button-at pos)
 369              ;; We must have originally been on a button, and are now in
 370              ;; the inter-button space.  Recurse to find a button.
 371              (next-button pos))))
 372
 373 (defun previous-button (pos &optional count-current)
 374   "Return the previous button before position POS in the current buffer.
 375 If COUNT-CURRENT is non-nil, count any button at POS in the search,
 376 instead of starting at the next button."
 377   (let ((button (button-at pos)))
 378     (if button
 379         (if count-current
 380             button
 381           ;; We started out on a button, so move to its start and look
 382           ;; for the previous button boundary.
 383           (setq pos (previous-single-char-property-change
 384                      (button-start button) 'button))
 385           (let ((new-button (button-at pos)))
 386             (if new-button
 387                 ;; We are in a button again; this can happen if there
 388                 ;; are adjacent buttons (or at bob).
 389                 (unless (= pos (button-start button)) new-button)
 390               ;; We are now in the space between buttons.
 391               (previous-button pos))))
 392       ;; We started out in the space between buttons.
 393       (setq pos (previous-single-char-property-change pos 'button))
 394       (or (button-at pos)
 395           (and (> pos (point-min))
 396                (button-at (1- pos)))))))
 397
 398 \f
 399 ;; User commands
 400
 401 (defun push-button (&optional pos use-mouse-action)
 402   "Perform the action specified by a button at location POS.
 403 POS may be either a buffer position or a mouse-event.  If
 404 USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action
 405 instead of its normal action; if the button has no mouse-action,
 406 the normal action is used instead.  The action may be either a
 407 function to call or a marker to display.
 408 POS defaults to point, except when `push-button' is invoked
 409 interactively as the result of a mouse-event, in which case, the
 410 mouse event is used.
 411 If there's no button at POS, do nothing and return nil, otherwise
 412 return t."
 413   (interactive
 414    (list (if (integerp last-command-event) (point) last-command-event)))
 415   (if (and (not (integerp pos)) (eventp pos))
 416       ;; POS is a mouse event; switch to the proper window/buffer
 417       (let ((posn (event-start pos)))
 418         (with-current-buffer (window-buffer (posn-window posn))
 419           (push-button (posn-point posn) t)))
 420     ;; POS is just normal position
 421     (let ((button (button-at (or pos (point)))))
 422       (if (not button)
 423           nil
 424         (button-activate button use-mouse-action)
 425         t))))
 426
 427 (defun forward-button (n &optional wrap display-message)
 428   "Move to the Nth next button, or Nth previous button if N is negative.
 429 If N is 0, move to the start of any button at point.
 430 If WRAP is non-nil, moving past either end of the buffer continues from the
 431 other end.
 432 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
 433 Any button with a non-nil `skip' property is skipped over.
 434 Returns the button found."
 435   (interactive "p\nd\nd")
 436   (let (button)
 437     (if (zerop n)
 438         ;; Move to start of current button
 439         (if (setq button (button-at (point)))
 440             (goto-char (button-start button)))
 441       ;; Move to Nth next button
 442       (let ((iterator (if (> n 0) #'next-button #'previous-button))
 443             (wrap-start (if (> n 0) (point-min) (point-max))))
 444         (setq n (abs n))
 445         (setq button t)                 ; just to start the loop
 446         (while (and (> n 0) button)
 447           (setq button (funcall iterator (point)))
 448           (when (and (not button) wrap)
 449             (setq button (funcall iterator wrap-start t)))
 450           (when button
 451             (goto-char (button-start button))
 452             (unless (button-get button 'skip)
 453               (setq n (1- n)))))))
 454     (if (null button)
 455         (error (if wrap "No buttons!" "No more buttons"))
 456       (let ((msg (and display-message (button-get button 'help-echo))))
 457         (when msg
 458           (message "%s" msg)))
 459       button)))
 460
 461 (defun backward-button (n &optional wrap display-message)
 462   "Move to the Nth previous button, or Nth next button if N is negative.
 463 If N is 0, move to the start of any button at point.
 464 If WRAP is non-nil, moving past either end of the buffer continues from the
 465 other end.
 466 If DISPLAY-MESSAGE is non-nil, the button's help-echo string is displayed.
 467 Any button with a non-nil `skip' property is skipped over.
 468 Returns the button found."
 469   (interactive "p\nd\nd")
 470   (forward-button (- n) wrap display-message))
 471
 472
 473 (provide 'button)
 474
 475 ;; arch-tag: 5f2c7627-413b-4097-b282-630f89d9c5e9
 476 ;;; button.el ends here