bug-reference-setupfeature/bug-reference-setup

2 files changed, 204 insertions, 3 deletions

diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 02af263ec34..20558de6b02 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -139,12 +139,208 @@ The second subexpression should match the bug reference (usually a number)."
         (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.  FIXME: Only a fraction of
+    ;; them uses debbugs.
+    ("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 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 return 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 VCS information.
+Tests each configuration from `bug-reference-setup-from-vc-alist'
+and sets it if applicable."
+  (when buffer-file-name
+    (let* ((backend (vc-responsible-backend buffer-file-name 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") '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"))
+  ;; TODO: Adapt docstring!
+  "An alist for setting up `bug-reference-mode' based 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
+name or newsgroup.  HEADER-REGEXP is a regexp matched against the
+From, To, Cc, 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 headers)
+  (catch 'setup-done
+    (dolist (config bug-reference-setup-from-mail-alist)
+      (when (or
+             (and group
+                  (car config)
+                  (string-match-p (car config) group))
+             (and headers
+                  (nth 1 config)
+                  (catch 'matching-header
+                    (dolist (h headers)
+                      (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.
+Tests each configuration from `bug-reference-setup-from-mail-alist'
+and sets 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-summary-buffer)
+(declare-function mail-header-extract "mailheader")
+(declare-function mail-header "mailheader")
+
+(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
+               (buffer-live-p (get-buffer gnus-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 ((headers (save-excursion
+                           (goto-char (point-min))
+                           (mail-header-extract)))
+                header-values)
+            (dolist (h '(list-id to from cc))
+              (let ((val (mail-header h headers)))
+                (when val
+                  (push val header-values))))
+            (bug-reference--maybe-setup-from-mail
+             nil header-values)))))))
+
+(defun bug-reference--after-hook ()
+  (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))
+            (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--after-hook)
   (if bug-reference-mode
       (jit-lock-register #'bug-reference-fontify)
     (jit-lock-unregister #'bug-reference-fontify)
@@ -158,6 +354,7 @@ The second subexpression should match the bug reference (usually a number)."
   nil
   ""
   nil
+  :after-hook (bug-reference--after-hook)
   (if bug-reference-prog-mode
       (jit-lock-register #'bug-reference-fontify)
     (jit-lock-unregister #'bug-reference-fontify)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index ce947d21f95..9b12d449785 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -964,7 +964,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
@@ -974,7 +974,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,
@@ -982,7 +985,8 @@ be reported."
         (dolist (backend vc-handled-backends)
           (and (vc-call-backend backend 'responsible-p file)
                (throw 'found backend))))
-      (error "No VC backend is responsible for %s" file)))
+      (unless no-error
+        (error "No VC backend is responsible for %s" file))))
 
 (defun vc-expand-dirs (file-or-dir-list backend)
   "Expands directories in a file list specification.