bug-reference-setupbug-reference-setup

2 files changed, 125 insertions, 4 deletions

diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 02af263ec34..e8cffd639f0 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 c640ba0420e..af7339f34b3 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,