master 5502eed: Auto-setup for bug-reference-mode

[Tassilo Horn]

branch: master
commit 5502eedf90d0da27df0c6c1fa33389d849d59a80
Author: Tassilo Horn <tsdh@gnu.org>
Commit: Tassilo Horn <tsdh@gnu.org>

    Auto-setup for bug-reference-mode
    
    Tries to guess suitable bug-reference-bug-regexp and
    bug-reference-url-format values based on version control URL (in file
    buffers) and mail information (in Gnus summary and article buffers).
    
    * lisp/progmodes/bug-reference.el
    (bug-reference--maybe-setup-from-vc): New defun.
    (bug-reference-setup-from-vc-alist): New defvar defining setup rules
    based on version control URL.
    (bug-reference-try-setup-from-vc): New defun using above defvar.
    (bug-reference--maybe-setup-from-mail): New defun.
    (bug-reference-setup-from-mail-alist): New defvar defining setup rules
    based on mail/newsgroups and header values.
    (bug-reference-try-setup-from-gnus): New defun using above defvar.
    (bug-reference--try-setup-gnus-article): New defun.
    (bug-reference--run-auto-setup): New defun.
    (bug-reference-mode): Call bug-reference--run-auto-setup as
    :after-hook.
    (bug-reference-prog-mode): Call bug-reference--run-auto-setup as
    :after-hook.
---
 lisp/progmodes/bug-reference.el | 218 ++++++++++++++++++++++++++++++++++++++++
 lisp/vc/vc.el                   |  10 +-
 2 files changed, 225 insertions(+), 3 deletions(-)

diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el
index 02af263..50bd366 100644
--- a/lisp/progmodes/bug-reference.el
+++ b/lisp/progmodes/bug-reference.el
@@ -139,12 +139,229 @@ 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.
+    ;;
+    ;; 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."
+  (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";))
+  "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)))))))
+
+(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))
+            (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)
@@ -158,6 +375,7 @@ The second subexpression should match the bug reference 
(usually a number)."
   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)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index ce947d2..9b12d44 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.