[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug-reference-setup ea43151: bug-reference-setup
From: |
Tassilo Horn |
Subject: |
bug-reference-setup ea43151: bug-reference-setup |
Date: |
Thu, 11 Jun 2020 17:22:38 -0400 (EDT) |
branch: bug-reference-setup
commit ea43151b5b625ee39ff5c22b722b1b4169719123
Author: Tassilo Horn <tsdh@gnu.org>
Commit: Tassilo Horn <tsdh@gnu.org>
bug-reference-setup
---
lisp/progmodes/bug-reference.el | 122 +++++++++++++++++++++++++++++++++++++++-
lisp/vc/vc.el | 7 ++-
2 files changed, 125 insertions(+), 4 deletions(-)
diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 02af263..e8cffd6 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -60,6 +60,7 @@ 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'.")
+(make-variable-buffer-local 'bug-reference-url-format)
;;;###autoload
(put 'bug-reference-url-format 'safe-local-variable
@@ -75,6 +76,7 @@ The second subexpression should match the bug reference
(usually a number)."
:type 'regexp
:version "24.3" ; previously defconst
:group 'bug-reference)
+(make-variable-buffer-local 'bug-reference-bug-regexp)
;;;###autoload
(put 'bug-reference-bug-regexp 'safe-local-variable 'stringp)
@@ -139,6 +141,122 @@ The second subexpression should match the bug reference
(usually a number)."
(when url
(browse-url url))))))
+(defcustom bug-reference-setup-functions nil
+ "A list of function for setting up bug-reference mode.
+A setup function should return non-nil if it set
+`bug-reference-bug-regexp' and `bug-reference-url-format'
+appropiately for the current buffer. The functions are called in
+sequence stopping as soon as one signalled a successful setup.
+
+Also see `bug-reference-default-setup-functions'.
+
+The `bug-reference-setup-functions' take preference over
+`bug-reference-default-setup-functions', i.e., they are
+called before the latter."
+ :type '(list function)
+ :version "28.1"
+ :group 'bug-reference)
+
+(defun bug-reference-try-setup-from-vc ()
+ "Try setting up `bug-reference-bug-regexp' and
+`bug-reference-url-format' from the version control system of the
+current file."
+ (when (buffer-file-name)
+ (let* ((backend (vc-responsible-backend (buffer-file-name) t))
+ (url (pcase backend
+ ('Git (string-trim
+ (shell-command-to-string
+ "git ls-remote --get-url"))))))
+ (cl-flet ((maybe-set (url-rx bug-rx bug-url-fmt)
+ (when (string-match url-rx url)
+ (setq bug-reference-bug-regexp bug-rx)
+ (setq bug-reference-url-format
+ (if (functionp bug-url-fmt)
+ (funcall bug-url-fmt)
+ bug-url-fmt)))))
+ (when (and url
+ ;; If there's a space in the url, it's propably an
+ ;; error message.
+ (not (string-match-p "[[:space:]]" url)))
+ (or
+ ;; GNU projects on savannah. FIXME: Only a fraction of
+ ;; them uses debbugs.
+ (maybe-set "git\\.\\(sv\\|savannah\\)\\.gnu\\.org:"
+ "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)"
+ "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. TODO: Support user/project#17 references linking
+ ;; to possibly different than the current project.
+ (maybe-set "[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\(#\\)\\([0-9]+\\)"
+ (lambda ()
+ (concat "https://github.com/"
+ (match-string 1 url)
+ "/issues/%s")))
+ ;; GitLab projects.
+ (maybe-set "[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git"
+ "\\(#\\|!\\)\\([0-9]+\\)"
+ (lambda ()
+ (let ((user-project (match-string 1 url)))
+ (lambda ()
+ (concat "https://gitlab.com/"
+ user-project
+ "/-/"
+ (if (string= (match-string 1) "#")
+ "issues/"
+ "merge_requests/")
+ (match-string 2))))))))))))
+
+(defun bug-reference-try-setup-from-gnus ()
+ (when (and (memq major-mode '(gnus-summary-mode gnus-article-mode))
+ (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name)
+ (let ((debbugs-regexp
+ ;; TODO: Obviously there are more, so add them.
+ (regexp-opt '("emacs" "auctex" "reftex"
+ "-devel@gnu.org" "ding@gnus.org"))))
+ (when (or (string-match-p debbugs-regexp gnus-newsgroup-name)
+ (and
+ gnus-article-buffer
+ (with-current-buffer gnus-article-buffer
+ (let ((headers (mail-header-extract)))
+ (when headers
+ (or (string-match-p
+ debbugs-regexp
+ (or (mail-header 'from headers) ""))
+ (string-match-p
+ debbugs-regexp
+ (or (mail-header 'to headers) ""))
+ (string-match-p
+ debbugs-regexp
+ (or (mail-header 'cc headers) ""))))))))
+ (setq bug-reference-bug-regexp
+ "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)")
+ (setq bug-reference-url-format
+ "https://debbugs.gnu.org/%s")))))
+
+;;;###autoload
+(defvar bug-reference-default-setup-functions
+ (list #'bug-reference-try-setup-from-vc
+ #'bug-reference-try-setup-from-gnus)
+ "Like `bug-reference-setup-functions' for packages to hook in.")
+
+(defun bug-reference--init ()
+ "Initialize `bug-reference-mode'."
+ (progn
+ (or
+ (with-demoted-errors
+ "Error while running bug-reference-setup-functions: %S"
+ (run-hook-with-args-until-success
+ 'bug-reference-setup-functions))
+ (with-demoted-errors
+ "Error while running bug-reference-default-setup-functions: %S"
+ (run-hook-with-args-until-success
+ 'bug-reference-default-setup-functions)))
+ (jit-lock-register #'bug-reference-fontify)))
+
;;;###autoload
(define-minor-mode bug-reference-mode
"Toggle hyperlinking bug references in the buffer (Bug Reference mode)."
@@ -146,7 +264,7 @@ The second subexpression should match the bug reference
(usually a number)."
""
nil
(if bug-reference-mode
- (jit-lock-register #'bug-reference-fontify)
+ (bug-reference--init)
(jit-lock-unregister #'bug-reference-fontify)
(save-restriction
(widen)
@@ -159,7 +277,7 @@ The second subexpression should match the bug reference
(usually a number)."
""
nil
(if bug-reference-prog-mode
- (jit-lock-register #'bug-reference-fontify)
+ (bug-reference--init)
(jit-lock-unregister #'bug-reference-fontify)
(save-restriction
(widen)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index c640ba0..af7339f 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -957,7 +957,7 @@ use."
(throw 'found bk))))
;;;###autoload
-(defun vc-responsible-backend (file)
+(defun vc-responsible-backend (file &optional no-error)
"Return the name of a backend system that is responsible for FILE.
If FILE is already registered, return the
@@ -967,7 +967,10 @@ responsible for FILE is returned.
Note that if FILE is a symbolic link, it will not be resolved --
the responsible backend system for the symbolic link itself will
-be reported."
+be reported.
+
+If NO-ERROR is nil, signal an error that no VC backend is
+responsible for the given file."
(or (and (not (file-directory-p file)) (vc-backend file))
(catch 'found
;; First try: find a responsible backend. If this is for registration,