Commit ea43151b authored by Tassilo Horn's avatar Tassilo Horn

bug-reference-setup

parent d8a6d2e4
Pipeline #5826 failed with stage
in 59 minutes and 36 seconds
......@@ -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)
......
......@@ -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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment