diff options
author | Tassilo Horn <tsdh@gnu.org> | 2020-06-11 17:02:02 +0200 |
---|---|---|
committer | Tassilo Horn <tsdh@gnu.org> | 2020-06-17 18:53:13 +0200 |
commit | 6dd702a7b62a26f9aeefd045cc99ff6ed0882ec9 (patch) | |
tree | f6f22691503a0023647c6aac162de838920e8ab6 | |
parent | 9682aa2f2493c89af1894ad2d52543d57f4958a5 (diff) | |
download | emacs-feature/bug-reference-setup.tar.gz |
bug-reference-setupfeature/bug-reference-setup
-rw-r--r-- | lisp/progmodes/bug-reference.el | 197 | ||||
-rw-r--r-- | lisp/vc/vc.el | 10 |
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. |