From ea43151b5b625ee39ff5c22b722b1b4169719123 Mon Sep 17 00:00:00 2001 From: Tassilo Horn Date: Thu, 11 Jun 2020 17:02:02 +0200 Subject: bug-reference-setup --- lisp/progmodes/bug-reference.el | 122 +++++++++++++++++++++++++++++++++++++++- lisp/vc/vc.el | 7 ++- 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, -- cgit v1.2.1