lisp/progmodes/bug-reference.el

   1 ;; bug-reference.el --- buttonize bug references
   2
   3 ;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Tom Tromey <tromey@redhat.com>
   6 ;; Created: 21 Mar 2007
   7 ;; Keywords: tools
   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 file provides minor modes for putting clickable overlays on
  27 ;; references to bugs.  A bug reference is text like "PR foo/29292";
  28 ;; this is mapped to a URL using a user-supplied format.
  29
  30 ;; Two minor modes are provided.  One works on any text in the buffer;
  31 ;; the other operates only on comments and strings.
  32
  33 ;;; Code:
  34
  35 (defgroup bug-reference nil
  36   "Hyperlinking references to bug reports"
  37   ;; Somewhat arbitrary, by analogy with eg goto-address.
  38   :group 'comm)
  39
  40 (defvar bug-reference-map
  41   (let ((map (make-sparse-keymap)))
  42     (define-key map [mouse-2] 'bug-reference-push-button)
  43     (define-key map (kbd "C-c RET") 'bug-reference-push-button)
  44     map)
  45   "Keymap used by bug reference buttons.")
  46
  47 ;; E.g., "https://gcc.gnu.org/PR%s"
  48 (defvar bug-reference-url-format nil
  49   "Format used to turn a bug number into a URL.
  50 The bug number is supplied as a string, so this should have a single %s.
  51 This can also be a function designator; it is called without arguments
  52  and should return a string.
  53 It can use `match-string' to get parts matched against
  54 `bug-reference-bug-regexp', specifically:
  55  1. issue kind (bug, patch, rfe &c)
  56  2. issue number.
  57
  58 There is no default setting for this, it must be set per file.
  59 If you set it to a symbol in the file Local Variables section,
  60 you need to add a `bug-reference-url-format' property to it:
  61 \(put \\='my-bug-reference-url-format \\='bug-reference-url-format t)
  62 so that it is considered safe, see `enable-local-variables'.")
  63
  64 ;;;###autoload
  65 (put 'bug-reference-url-format 'safe-local-variable
  66      (lambda (s)
  67        (or (stringp s)
  68            (and (symbolp s)
  69                 (get s 'bug-reference-url-format)))))
  70
  71 (defcustom bug-reference-bug-regexp
  72   "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
  73   "Regular expression matching bug references.
  74 The second subexpression should match the bug reference (usually a number)."
  75   :type 'string
  76   :version "24.3"                       ; previously defconst
  77   :group 'bug-reference)
  78
  79 ;;;###autoload
  80 (put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
  81
  82 (defun bug-reference-set-overlay-properties ()
  83   "Set properties of bug reference overlays."
  84   (put 'bug-reference 'evaporate t)
  85   (put 'bug-reference 'face 'link)
  86   (put 'bug-reference 'mouse-face 'highlight)
  87   (put 'bug-reference 'help-echo "mouse-1, C-c RET: visit this bug")
  88   (put 'bug-reference 'keymap bug-reference-map)
  89   (put 'bug-reference 'follow-link t))
  90
  91 (bug-reference-set-overlay-properties)
  92
  93 (defun bug-reference-unfontify (start end)
  94   "Remove bug reference overlays from region."
  95   (dolist (o (overlays-in start end))
  96     (when (eq (overlay-get o 'category) 'bug-reference)
  97       (delete-overlay o))))
  98
  99 (defvar bug-reference-prog-mode)
 100
 101 (defun bug-reference-fontify (start end)
 102   "Apply bug reference overlays to region."
 103   (save-excursion
 104     (let ((beg-line (progn (goto-char start) (line-beginning-position)))
 105           (end-line (progn (goto-char end) (line-end-position))))
 106       ;; Remove old overlays.
 107       (bug-reference-unfontify beg-line end-line)
 108       (goto-char beg-line)
 109       (while (and (< (point) end-line)
 110                   (re-search-forward bug-reference-bug-regexp end-line 'move))
 111         (when (or (not bug-reference-prog-mode)
 112                   ;; This tests for both comment and string syntax.
 113                   (nth 8 (syntax-ppss)))
 114           (let ((overlay (make-overlay (match-beginning 0) (match-end 0)
 115                                        nil t nil)))
 116             (overlay-put overlay 'category 'bug-reference)
 117             ;; Don't put a link if format is undefined
 118             (when bug-reference-url-format
 119               (overlay-put overlay 'bug-reference-url
 120                            (if (stringp bug-reference-url-format)
 121                                (format bug-reference-url-format
 122                                        (match-string-no-properties 2))
 123                              (funcall bug-reference-url-format))))))))))
 124
 125 ;; Taken from button.el.
 126 (defun bug-reference-push-button (&optional pos _use-mouse-action)
 127   "Open URL corresponding to the bug reference at POS."
 128   (interactive
 129    (list (if (integerp last-command-event) (point) last-command-event)))
 130   (if (and (not (integerp pos)) (eventp pos))
 131       ;; POS is a mouse event; switch to the proper window/buffer
 132       (let ((posn (event-start pos)))
 133         (with-current-buffer (window-buffer (posn-window posn))
 134           (bug-reference-push-button (posn-point posn) t)))
 135     ;; POS is just normal position.
 136     (dolist (o (overlays-at pos))
 137       ;; It should only be possible to have one URL overlay.
 138       (let ((url (overlay-get o 'bug-reference-url)))
 139         (when url
 140           (browse-url url))))))
 141
 142 ;;;###autoload
 143 (define-minor-mode bug-reference-mode
 144   "Toggle hyperlinking bug references in the buffer (Bug Reference mode).
 145 With a prefix argument ARG, enable Bug Reference mode if ARG is
 146 positive, and disable it otherwise.  If called from Lisp, enable
 147 the mode if ARG is omitted or nil."
 148   nil
 149   ""
 150   nil
 151   (if bug-reference-mode
 152       (jit-lock-register #'bug-reference-fontify)
 153     (jit-lock-unregister #'bug-reference-fontify)
 154     (save-restriction
 155       (widen)
 156       (bug-reference-unfontify (point-min) (point-max)))))
 157
 158 ;;;###autoload
 159 (define-minor-mode bug-reference-prog-mode
 160   "Like `bug-reference-mode', but only buttonize in comments and strings."
 161   nil
 162   ""
 163   nil
 164   (if bug-reference-prog-mode
 165       (jit-lock-register #'bug-reference-fontify)
 166     (jit-lock-unregister #'bug-reference-fontify)
 167     (save-restriction
 168       (widen)
 169       (bug-reference-unfontify (point-min) (point-max)))))
 170
 171 (provide 'bug-reference)
 172 ;;; bug-reference.el ends here