LCOV - code coverage report
Current view: top level - lisp - button.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 20 165 12.1 %
Date: 2017-08-30 10:12:24 Functions: 2 24 8.3 %

          Line data    Source code
       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 <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.  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             : 
      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             : 
     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          57 :   (or (get type 'button-category-symbol)
     117          57 :       (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          57 :   (let ((catsym (make-symbol (concat (symbol-name name) "-button")))
     131             :         (super-catsym
     132          57 :          (button-category-symbol
     133          57 :           (or (plist-get properties 'supertype)
     134          57 :               (plist-get properties :supertype)
     135          57 :               'button))))
     136             :     ;; Provide a link so that it's easy to find the real symbol.
     137          57 :     (put name 'button-category-symbol catsym)
     138             :     ;; Initialize NAME's properties using the global defaults.
     139          57 :     (let ((default-props (symbol-plist super-catsym)))
     140         617 :       (while default-props
     141        1120 :         (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          57 :     (put catsym 'type name)
     145             :     ;; Add the properties in PROPERTIES to the real symbol.
     146         221 :     (while properties
     147         328 :       (let ((prop (pop properties)))
     148         164 :         (when (eq prop :supertype)
     149         164 :           (setq prop 'supertype))
     150         328 :         (put catsym prop (pop properties))))
     151             :     ;; Make sure there's a `supertype' property
     152          57 :     (unless (get catsym 'supertype)
     153          57 :       (put catsym 'supertype 'button))
     154          57 :     name))
     155             : 
     156             : (defun button-type-put (type prop val)
     157             :   "Set the button-type TYPE's PROP property to VAL."
     158           0 :   (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           0 :   (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           0 :   (or (eq type supertype)
     167           0 :       (and type
     168           0 :            (button-type-subtype-p (button-type-get type 'supertype)
     169           0 :                                   supertype))))
     170             : 
     171             : 
     172             : ;; Button properties and other attributes
     173             : 
     174             : (defun button-start (button)
     175             :   "Return the position at which BUTTON starts."
     176           0 :   (if (overlayp button)
     177           0 :       (overlay-start button)
     178             :     ;; Must be a text-property button.
     179           0 :     (or (previous-single-property-change (1+ button) 'button)
     180           0 :         (point-min))))
     181             : 
     182             : (defun button-end (button)
     183             :   "Return the position at which BUTTON ends."
     184           0 :   (if (overlayp button)
     185           0 :       (overlay-end button)
     186             :     ;; Must be a text-property button.
     187           0 :     (or (next-single-property-change button 'button)
     188           0 :         (point-max))))
     189             : 
     190             : (defun button-get (button prop)
     191             :   "Get the property of button BUTTON named PROP."
     192           0 :   (cond ((overlayp button)
     193           0 :          (overlay-get button prop))
     194           0 :         ((button--area-button-p button)
     195           0 :          (get-text-property (cdr button)
     196           0 :                             prop (button--area-button-string button)))
     197           0 :         ((markerp button)
     198           0 :          (get-text-property button prop (marker-buffer button)))
     199             :         (t ; Must be a text-property button.
     200           0 :          (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           0 :   (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           0 :          (setq prop 'category)
     210           0 :          (setq val (button-category-symbol val)))
     211           0 :         ((eq prop 'category)
     212             :          ;; Disallow updating the `category' property directly.
     213           0 :          (error "Button `category' property may not be set directly")))
     214             :   ;; Add the property.
     215           0 :   (cond ((overlayp button)
     216           0 :          (overlay-put button prop val))
     217           0 :         ((button--area-button-p button)
     218           0 :          (setq button (button--area-button-string button))
     219           0 :          (put-text-property 0 (length button) prop val button))
     220             :         (t ; Must be a text-property button.
     221           0 :          (put-text-property
     222           0 :           (or (previous-single-property-change (1+ button) 'button)
     223           0 :               (point-min))
     224           0 :           (or (next-single-property-change button 'button)
     225           0 :               (point-max))
     226           0 :           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 it 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           0 :   (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
     240           0 :                     (button-get button 'action))))
     241           0 :     (if (markerp action)
     242           0 :         (save-selected-window
     243           0 :           (select-window (display-buffer (marker-buffer action)))
     244           0 :           (goto-char action)
     245           0 :           (recenter 0))
     246           0 :       (funcall action button))))
     247             : 
     248             : (defun button-label (button)
     249             :   "Return BUTTON's text label."
     250           0 :   (if (button--area-button-p button)
     251           0 :       (substring-no-properties (button--area-button-string button))
     252           0 :     (buffer-substring-no-properties (button-start button)
     253           0 :                                     (button-end button))))
     254             : 
     255             : (defsubst button-type (button)
     256             :   "Return BUTTON's button-type."
     257           0 :   (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           0 :   (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           0 :   (stringp (car-safe b)))
     267             : 
     268             : (defalias 'button--area-button-string #'car
     269             :   "Return area button BUTTON's button-string.")
     270             : 
     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           0 :   (let ((overlay (make-overlay beg end nil t nil)))
     283           0 :     (while properties
     284           0 :       (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           0 :     (overlay-put overlay 'button overlay)
     288             :     ;; If the user didn't specify a type, use the default.
     289           0 :     (unless (overlay-get overlay 'category)
     290           0 :       (overlay-put overlay 'category 'default-button))
     291             :     ;; OVERLAY is the button, so return it
     292           0 :     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           0 :   (apply #'make-button
     304           0 :          (prog1 (point) (insert label))
     305           0 :          (point)
     306           0 :          properties))
     307             : 
     308             : 
     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           0 :   (let ((object nil)
     331             :         (type-entry
     332           0 :          (or (plist-member properties 'type)
     333           0 :              (plist-member properties :type))))
     334           0 :     (when (stringp beg)
     335           0 :       (setq object beg beg 0 end (length object)))
     336             :     ;; Disallow setting the `category' property directly.
     337           0 :     (when (plist-get properties 'category)
     338           0 :       (error "Button `category' property may not be set directly"))
     339           0 :     (if (null type-entry)
     340             :         ;; The user didn't specify a `type' property, use the default.
     341           0 :         (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           0 :       (setcar type-entry 'category)
     346           0 :       (setcar (cdr type-entry)
     347           0 :               (button-category-symbol (car (cdr type-entry)))))
     348             :     ;; Now add all the text properties at once
     349           0 :     (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           0 :                          (cons 'button (cons (list t) properties))
     354           0 :                          object)
     355             :     ;; Return something that can be used to get at the button.
     356           0 :     (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           0 :   (apply #'make-text-button
     373           0 :          (prog1 (point) (insert label))
     374           0 :          (point)
     375           0 :          properties))
     376             : 
     377             : 
     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           0 :   (let ((button (get-char-property pos 'button)))
     385           0 :     (if (or (overlayp button) (null button))
     386           0 :         button
     387             :       ;; Must be a text-property button; return a marker pointing to it.
     388           0 :       (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           0 :     (unless count-current
     395             :       ;; Search for the next button boundary.
     396           0 :       (setq pos (next-single-char-property-change pos 'button)))
     397           0 :     (and (< pos (point-max))
     398           0 :          (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           0 :              (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           0 :   (let ((button (button-at pos)))
     408           0 :     (if button
     409           0 :         (if count-current
     410           0 :             button
     411             :           ;; We started out on a button, so move to its start and look
     412             :           ;; for the previous button boundary.
     413           0 :           (setq pos (previous-single-char-property-change
     414           0 :                      (button-start button) 'button))
     415           0 :           (let ((new-button (button-at pos)))
     416           0 :             (if new-button
     417             :                 ;; We are in a button again; this can happen if there
     418             :                 ;; are adjacent buttons (or at bob).
     419           0 :                 (unless (= pos (button-start button)) new-button)
     420             :               ;; We are now in the space between buttons.
     421           0 :               (previous-button pos))))
     422             :       ;; We started out in the space between buttons.
     423           0 :       (setq pos (previous-single-char-property-change pos 'button))
     424           0 :       (or (button-at pos)
     425           0 :           (and (> pos (point-min))
     426           0 :                (button-at (1- pos)))))))
     427             : 
     428             : 
     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           0 :    (list (if (integerp last-command-event) (point) last-command-event)))
     449           0 :   (if (and (not (integerp pos)) (eventp pos))
     450             :       ;; POS is a mouse event; switch to the proper window/buffer
     451           0 :       (let ((posn (event-start pos)))
     452           0 :         (with-current-buffer (window-buffer (posn-window posn))
     453           0 :           (if (posn-string posn)
     454             :               ;; mode-line, header-line, or display string event.
     455           0 :               (button-activate (posn-string posn) t)
     456           0 :             (push-button (posn-point posn) t))))
     457             :     ;; POS is just normal position
     458           0 :     (let ((button (button-at (or pos (point)))))
     459           0 :       (when button
     460           0 :         (button-activate button use-mouse-action)
     461           0 :         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           0 :   (let (button)
     473           0 :     (if (zerop n)
     474             :         ;; Move to start of current button
     475           0 :         (if (setq button (button-at (point)))
     476           0 :             (goto-char (button-start button)))
     477             :       ;; Move to Nth next button
     478           0 :       (let ((iterator (if (> n 0) #'next-button #'previous-button))
     479           0 :             (wrap-start (if (> n 0) (point-min) (point-max)))
     480             :             opoint fail)
     481           0 :         (setq n (abs n))
     482           0 :         (setq button t)                 ; just to start the loop
     483           0 :         (while (and (null fail) (> n 0) button)
     484           0 :           (setq button (funcall iterator (point)))
     485           0 :           (when (and (not button) wrap)
     486           0 :             (setq button (funcall iterator wrap-start t)))
     487           0 :           (when button
     488           0 :             (goto-char (button-start button))
     489             :             ;; Avoid looping forever (e.g., if all the buttons have
     490             :             ;; the `skip' property).
     491           0 :             (cond ((null opoint)
     492           0 :                    (setq opoint (point)))
     493           0 :                   ((= opoint (point))
     494           0 :                    (setq fail t)))
     495           0 :             (unless (button-get button 'skip)
     496           0 :               (setq n (1- n)))))))
     497           0 :     (if (null button)
     498           0 :         (user-error (if wrap "No buttons!" "No more buttons"))
     499           0 :       (let ((msg (and display-message (button-get button 'help-echo))))
     500           0 :         (when msg
     501           0 :           (message "%s" msg)))
     502           0 :       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           0 :   (forward-button (- n) wrap display-message))
     514             : 
     515             : 
     516             : (provide 'button)
     517             : 
     518             : ;;; button.el ends here

Generated by: LCOV version 1.12