450 lines
18 KiB
EmacsLisp
450 lines
18 KiB
EmacsLisp
;; bug-reference.el --- buttonize bug references -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2008-2020 Free Software Foundation, Inc.
|
|
|
|
;; Author: Tom Tromey <tromey@redhat.com>
|
|
;; Created: 21 Mar 2007
|
|
;; Keywords: tools
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; This file provides minor modes for putting clickable overlays on
|
|
;; references to bugs. A bug reference is text like "PR foo/29292";
|
|
;; this is mapped to a URL using a user-supplied format.
|
|
|
|
;; Two minor modes are provided. One works on any text in the buffer;
|
|
;; the other operates only on comments and strings.
|
|
|
|
;;; Code:
|
|
|
|
(defgroup bug-reference nil
|
|
"Hyperlinking references to bug reports"
|
|
;; Somewhat arbitrary, by analogy with eg goto-address.
|
|
:group 'comm)
|
|
|
|
(defvar bug-reference-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [mouse-2] 'bug-reference-push-button)
|
|
(define-key map (kbd "C-c RET") 'bug-reference-push-button)
|
|
map)
|
|
"Keymap used by bug reference buttons.")
|
|
|
|
;; E.g., "https://gcc.gnu.org/PR%s"
|
|
(defvar bug-reference-url-format nil
|
|
"Format used to turn a bug number into a URL.
|
|
The bug number is supplied as a string, so this should have a single %s.
|
|
This can also be a function designator; it is called without arguments
|
|
and should return a string.
|
|
It can use `match-string' to get parts matched against
|
|
`bug-reference-bug-regexp', specifically:
|
|
1. issue kind (bug, patch, rfe &c)
|
|
2. issue number.
|
|
|
|
There is no default setting for this, it must be set per file.
|
|
If you set it to a symbol in the file Local Variables section,
|
|
you need to add a `bug-reference-url-format' property to it:
|
|
\(put \\='my-bug-reference-url-format \\='bug-reference-url-format t)
|
|
so that it is considered safe, see `enable-local-variables'.")
|
|
|
|
;;;###autoload
|
|
(put 'bug-reference-url-format 'safe-local-variable
|
|
(lambda (s)
|
|
(or (stringp s)
|
|
(and (symbolp s)
|
|
(get s 'bug-reference-url-format)))))
|
|
|
|
(defcustom bug-reference-bug-regexp
|
|
"\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
|
|
"Regular expression matching bug references.
|
|
The second subexpression should match the bug reference (usually a number)."
|
|
:type 'regexp
|
|
:version "24.3" ; previously defconst
|
|
:group 'bug-reference)
|
|
|
|
;;;###autoload
|
|
(put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
|
|
|
|
(defun bug-reference-set-overlay-properties ()
|
|
"Set properties of bug reference overlays."
|
|
(put 'bug-reference 'evaporate t)
|
|
(put 'bug-reference 'face 'link)
|
|
(put 'bug-reference 'mouse-face 'highlight)
|
|
(put 'bug-reference 'help-echo "mouse-1, C-c RET: visit this bug")
|
|
(put 'bug-reference 'keymap bug-reference-map)
|
|
(put 'bug-reference 'follow-link t))
|
|
|
|
(bug-reference-set-overlay-properties)
|
|
|
|
(defun bug-reference-unfontify (start end)
|
|
"Remove bug reference overlays from the region between START and END."
|
|
(dolist (o (overlays-in start end))
|
|
(when (eq (overlay-get o 'category) 'bug-reference)
|
|
(delete-overlay o))))
|
|
|
|
(defvar bug-reference-prog-mode)
|
|
|
|
(defun bug-reference-fontify (start end)
|
|
"Apply bug reference overlays to the region between START and END."
|
|
(save-excursion
|
|
(let ((beg-line (progn (goto-char start) (line-beginning-position)))
|
|
(end-line (progn (goto-char end) (line-end-position))))
|
|
;; Remove old overlays.
|
|
(bug-reference-unfontify beg-line end-line)
|
|
(goto-char beg-line)
|
|
(while (and (< (point) end-line)
|
|
(re-search-forward bug-reference-bug-regexp end-line 'move))
|
|
(when (or (not bug-reference-prog-mode)
|
|
;; This tests for both comment and string syntax.
|
|
(nth 8 (syntax-ppss)))
|
|
(let ((overlay (make-overlay (match-beginning 0) (match-end 0)
|
|
nil t nil)))
|
|
(overlay-put overlay 'category 'bug-reference)
|
|
;; Don't put a link if format is undefined
|
|
(when bug-reference-url-format
|
|
(overlay-put overlay 'bug-reference-url
|
|
(if (stringp bug-reference-url-format)
|
|
(format bug-reference-url-format
|
|
(match-string-no-properties 2))
|
|
(funcall bug-reference-url-format))))))))))
|
|
|
|
;; Taken from button.el.
|
|
(defun bug-reference-push-button (&optional pos _use-mouse-action)
|
|
"Open URL corresponding to the bug reference at POS."
|
|
(interactive
|
|
(list (if (integerp last-command-event) (point) last-command-event)))
|
|
(if (and (not (integerp pos)) (eventp pos))
|
|
;; POS is a mouse event; switch to the proper window/buffer
|
|
(let ((posn (event-start pos)))
|
|
(with-current-buffer (window-buffer (posn-window posn))
|
|
(bug-reference-push-button (posn-point posn) t)))
|
|
;; POS is just normal position.
|
|
(dolist (o (overlays-at pos))
|
|
;; It should only be possible to have one URL overlay.
|
|
(let ((url (overlay-get o 'bug-reference-url)))
|
|
(when url
|
|
(browse-url url))))))
|
|
|
|
(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt)
|
|
(when (string-match url-rx url)
|
|
(setq-local bug-reference-bug-regexp bug-rx)
|
|
(setq-local bug-reference-url-format
|
|
(let (groups)
|
|
(dotimes (i (/ (length (match-data)) 2))
|
|
(push (match-string i url) groups))
|
|
(funcall bug-url-fmt (nreverse groups))))))
|
|
|
|
(defvar bug-reference-setup-from-vc-alist
|
|
`(;;
|
|
;; GNU projects on savannah.
|
|
;;
|
|
;; Not all of them use debbugs but that doesn't really matter
|
|
;; because the auto-setup is only performed if
|
|
;; `bug-reference-url-format' and `bug-reference-bug-regexp'
|
|
;; aren't set already.
|
|
("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:"
|
|
"\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>"
|
|
,(lambda (_) "https://debbugs.gnu.org/%s"))
|
|
;;
|
|
;; GitHub projects.
|
|
;;
|
|
;; Here #17 may refer to either an issue or a pull request but
|
|
;; visiting the issue/17 web page will automatically redirect to
|
|
;; the pull/17 page if 17 is a PR. Explicit user/project#17 links
|
|
;; to possibly different projects are also supported.
|
|
("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
|
|
"\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>"
|
|
,(lambda (groups)
|
|
(let ((ns-project (nth 1 groups)))
|
|
(lambda ()
|
|
(concat "https://github.com/"
|
|
(or
|
|
;; Explicit user/proj#18 link.
|
|
(match-string 1)
|
|
ns-project)
|
|
"/issues/"
|
|
(match-string 2))))))
|
|
;;
|
|
;; GitLab projects.
|
|
;;
|
|
;; Here #18 is an issue and !17 is a merge request. Explicit
|
|
;; namespace/project#18 or namespace/project!17 references to
|
|
;; possibly different projects are also supported.
|
|
("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
|
|
"\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>"
|
|
,(lambda (groups)
|
|
(let ((ns-project (nth 1 groups)))
|
|
(lambda ()
|
|
(concat "https://gitlab.com/"
|
|
(or (match-string 1)
|
|
ns-project)
|
|
"/-/"
|
|
(if (string= (match-string 3) "#")
|
|
"issues/"
|
|
"merge_requests/")
|
|
(match-string 2)))))))
|
|
"An alist for setting up `bug-reference-mode' based on VC URL.
|
|
|
|
Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN).
|
|
|
|
URL-REGEXP is matched against the version control URL of the
|
|
current buffer's file. If it matches, BUG-REGEXP is set as
|
|
`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one
|
|
argument that receives a list of the groups 0 to N of matching
|
|
URL-REGEXP against the VCS URL and returns the value to be set as
|
|
`bug-reference-url-format'.")
|
|
|
|
(defun bug-reference-try-setup-from-vc ()
|
|
"Try setting up `bug-reference-mode' based on VC information.
|
|
Test each configuration in `bug-reference-setup-from-vc-alist'
|
|
and apply it if applicable."
|
|
(let ((file-or-dir (or buffer-file-name
|
|
;; Catches modes such as vc-dir and Magit.
|
|
default-directory)))
|
|
(when file-or-dir
|
|
(let* ((backend (vc-responsible-backend file-or-dir t))
|
|
(url
|
|
(or (ignore-errors
|
|
(vc-call-backend backend 'repository-url "upstream"))
|
|
(ignore-errors
|
|
(vc-call-backend backend 'repository-url)))))
|
|
(when url
|
|
(catch 'found
|
|
(dolist (config bug-reference-setup-from-vc-alist)
|
|
(when (apply #'bug-reference--maybe-setup-from-vc
|
|
url config)
|
|
(throw 'found t)))))))))
|
|
|
|
(defvar bug-reference-setup-from-mail-alist
|
|
`((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words)
|
|
,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org"
|
|
;; List-Id of Gnus devel mailing list.
|
|
"ding.gnus.org"))
|
|
"\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
|
|
"https://debbugs.gnu.org/%s"))
|
|
"An alist for setting up `bug-reference-mode' in mail modes.
|
|
|
|
This takes action if `bug-reference-mode' is enabled in group and
|
|
message buffers of Emacs mail clients. Currently, only Gnus is
|
|
supported.
|
|
|
|
Each element has the form
|
|
|
|
(GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT)
|
|
|
|
GROUP-REGEXP is a regexp matched against the current mail folder
|
|
or newsgroup name. HEADER-REGEXP is a regexp matched against the
|
|
From, To, Cc, Newsgroup, and List-ID header values of the current
|
|
mail or newsgroup message. If any of those matches, BUG-REGEXP
|
|
is set as `bug-reference-bug-regexp' and URL-FORMAT is set as
|
|
`bug-reference-url-format'.
|
|
|
|
Note: In Gnus, if a summary buffer has been set up based on
|
|
GROUP-REGEXP, all article buffers opened from there will get the
|
|
same `bug-reference-url-format' and `bug-reference-url-format'.")
|
|
|
|
(defvar gnus-newsgroup-name)
|
|
|
|
(defun bug-reference--maybe-setup-from-mail (group header-values)
|
|
"Set up according to mail GROUP or HEADER-VALUES.
|
|
Group is a mail group/folder name and HEADER-VALUES is a list of
|
|
mail header values, e.g., the values of From, To, Cc, List-ID,
|
|
and Newsgroup.
|
|
|
|
If any GROUP-REGEXP or HEADER-REGEXP of
|
|
`bug-reference-setup-from-mail-alist' matches GROUP or any
|
|
element in HEADER-VALUES, the corresponding BUG-REGEXP and
|
|
URL-FORMAT are set."
|
|
(catch 'setup-done
|
|
(dolist (config bug-reference-setup-from-mail-alist)
|
|
(when (or
|
|
(and group
|
|
(car config)
|
|
(string-match-p (car config) group))
|
|
(and header-values
|
|
(nth 1 config)
|
|
(catch 'matching-header
|
|
(dolist (h header-values)
|
|
(when (and h (string-match-p (nth 1 config) h))
|
|
(throw 'matching-header t))))))
|
|
(setq-local bug-reference-bug-regexp (nth 2 config))
|
|
(setq-local bug-reference-url-format (nth 3 config))
|
|
(throw 'setup-done t)))))
|
|
|
|
(defun bug-reference-try-setup-from-gnus ()
|
|
"Try setting up `bug-reference-mode' based on Gnus group or article.
|
|
Test each configuration in `bug-reference-setup-from-mail-alist'
|
|
and set it if applicable."
|
|
(when (and (derived-mode-p 'gnus-summary-mode)
|
|
(bound-and-true-p gnus-newsgroup-name))
|
|
;; Gnus reuses its article buffer so we have to check whenever the
|
|
;; article changes.
|
|
(add-hook 'gnus-article-prepare-hook
|
|
#'bug-reference--try-setup-gnus-article)
|
|
(bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil)))
|
|
|
|
(defvar gnus-article-buffer)
|
|
(defvar gnus-original-article-buffer)
|
|
(defvar gnus-summary-buffer)
|
|
|
|
(defun bug-reference--try-setup-gnus-article ()
|
|
(with-demoted-errors
|
|
"Error in bug-reference--try-setup-gnus-article: %S"
|
|
(when (and bug-reference-mode ;; Only if enabled in article buffers.
|
|
(derived-mode-p
|
|
'gnus-article-mode
|
|
;; Apparently, gnus-article-prepare-hook is run in the
|
|
;; summary buffer...
|
|
'gnus-summary-mode)
|
|
gnus-article-buffer
|
|
gnus-original-article-buffer
|
|
(buffer-live-p (get-buffer gnus-article-buffer))
|
|
(buffer-live-p (get-buffer gnus-original-article-buffer)))
|
|
(with-current-buffer gnus-article-buffer
|
|
(catch 'setup-done
|
|
;; Copy over the values from the summary buffer.
|
|
(when (and gnus-summary-buffer
|
|
(buffer-live-p gnus-summary-buffer))
|
|
(setq-local bug-reference-bug-regexp
|
|
(with-current-buffer gnus-summary-buffer
|
|
bug-reference-bug-regexp))
|
|
(setq-local bug-reference-url-format
|
|
(with-current-buffer gnus-summary-buffer
|
|
bug-reference-url-format))
|
|
(when (and bug-reference-bug-regexp
|
|
bug-reference-url-format)
|
|
(throw 'setup-done t)))
|
|
;; If the summary had no values, try setting according to
|
|
;; the values of the From, To, and Cc headers.
|
|
(let (header-values)
|
|
(with-current-buffer
|
|
(get-buffer gnus-original-article-buffer)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
;; The Newsgroup is omitted because we already matched
|
|
;; based on group name in the summary buffer.
|
|
(dolist (field '("list-id" "to" "from" "cc"))
|
|
(let ((val (mail-fetch-field field)))
|
|
(when val
|
|
(push val header-values))))))
|
|
(bug-reference--maybe-setup-from-mail nil header-values)))))))
|
|
|
|
(defvar bug-reference-setup-from-irc-alist
|
|
`((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc"
|
|
"erc") 'words))
|
|
"freenode"
|
|
"\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
|
|
"https://debbugs.gnu.org/%s"))
|
|
"An alist for setting up `bug-reference-mode' in IRC modes.
|
|
|
|
This takes action if `bug-reference-mode' is enabled in IRC
|
|
channels using one of Emacs' IRC clients (rcirc and ERC).
|
|
Currently, only rcirc is supported.
|
|
|
|
Each element has the form
|
|
|
|
(CHANNEL-REGEXP SERVER-REGEXP BUG-REGEXP URL-FORMAT)
|
|
|
|
CHANNEL-REGEXP is a regexp matched against the current mail IRC
|
|
channel name. SERVER-REGEXP is matched against the IRC server
|
|
name. If any of those matches, BUG-REGEXP is set as
|
|
`bug-reference-bug-regexp' and URL-FORMAT is set as
|
|
`bug-reference-url-format'.")
|
|
|
|
(defun bug-reference--maybe-setup-from-irc (channel server)
|
|
"Set up according to IRC CHANNEL or SERVER.
|
|
CHANNEL is an IRC channel name and SERVER is that channel's
|
|
server name.
|
|
|
|
If any CHANNEL-REGEXP or SERVER-REGEXP of
|
|
`bug-reference-setup-from-irc-alist' matches CHANNEL or SERVER,
|
|
the corresponding BUG-REGEXP and URL-FORMAT are set."
|
|
(catch 'setup-done
|
|
(dolist (config bug-reference-setup-from-irc-alist)
|
|
(when (or
|
|
(and channel
|
|
(car config)
|
|
(string-match-p (car config) channel))
|
|
(and server
|
|
(nth 1 config)
|
|
(string-match-p (car config) server)))
|
|
(setq-local bug-reference-bug-regexp (nth 2 config))
|
|
(setq-local bug-reference-url-format (nth 3 config))
|
|
(throw 'setup-done t)))))
|
|
|
|
(defvar rcirc-target)
|
|
(defvar rcirc-server-buffer)
|
|
(defvar rcirc-server)
|
|
|
|
(defun bug-reference-try-setup-from-rcirc ()
|
|
"Try setting up `bug-reference-mode' based on rcirc channel and server.
|
|
Test each configuration in `bug-reference-setup-from-irc-alist'
|
|
and set it if applicable."
|
|
(when (derived-mode-p 'rcirc-mode)
|
|
(bug-reference--maybe-setup-from-irc
|
|
rcirc-target
|
|
(and rcirc-server-buffer
|
|
(buffer-live-p rcirc-server-buffer)
|
|
(with-current-buffer rcirc-server-buffer
|
|
rcirc-server)))))
|
|
|
|
(defun bug-reference--run-auto-setup ()
|
|
(when (or bug-reference-mode
|
|
bug-reference-prog-mode)
|
|
;; Automatic setup only if the variables aren't already set, e.g.,
|
|
;; by a local variables section in the file.
|
|
(unless (and bug-reference-bug-regexp
|
|
bug-reference-url-format)
|
|
(with-demoted-errors
|
|
"Error during bug-reference auto-setup: %S"
|
|
(catch 'setup
|
|
(dolist (f (list #'bug-reference-try-setup-from-vc
|
|
#'bug-reference-try-setup-from-gnus
|
|
#'bug-reference-try-setup-from-rcirc))
|
|
(when (funcall f)
|
|
(throw 'setup t))))))))
|
|
|
|
;;;###autoload
|
|
(define-minor-mode bug-reference-mode
|
|
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
|
|
nil
|
|
""
|
|
nil
|
|
:after-hook (bug-reference--run-auto-setup)
|
|
(if bug-reference-mode
|
|
(jit-lock-register #'bug-reference-fontify)
|
|
(jit-lock-unregister #'bug-reference-fontify)
|
|
(save-restriction
|
|
(widen)
|
|
(bug-reference-unfontify (point-min) (point-max)))))
|
|
|
|
;;;###autoload
|
|
(define-minor-mode bug-reference-prog-mode
|
|
"Like `bug-reference-mode', but only buttonize in comments and strings."
|
|
nil
|
|
""
|
|
nil
|
|
:after-hook (bug-reference--run-auto-setup)
|
|
(if bug-reference-prog-mode
|
|
(jit-lock-register #'bug-reference-fontify)
|
|
(jit-lock-unregister #'bug-reference-fontify)
|
|
(save-restriction
|
|
(widen)
|
|
(bug-reference-unfontify (point-min) (point-max)))))
|
|
|
|
(provide 'bug-reference)
|
|
;;; bug-reference.el ends here
|