From: Tassilo Horn Date: Thu, 11 Jun 2020 15:02:02 +0000 (+0200) Subject: Auto-setup for bug-reference-mode X-Git-Tag: emacs-28.0.90~7161 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5502eedf90d0da27df0c6c1fa33389d849d59a80;p=emacs.git 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. --- diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 02af263ec34..50bd3661eff 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 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.