diff --git a/modules/emacs/vc/autoload/bug-reference-backport.el b/modules/emacs/vc/autoload/bug-reference-backport.el new file mode 100644 index 000000000..314cc6632 --- /dev/null +++ b/modules/emacs/vc/autoload/bug-reference-backport.el @@ -0,0 +1,100 @@ +;;; emacs/vc/autoload/bug-reference-backport.el -*- lexical-binding: t; -*- +;;;###if (not EMACS28+) +;; DEPRECATED Remove when Emacs 27.x support is dropped + +;; In Emacs 28, the built-in bug-reference package started consulting vc for +;; repo information (to inform its bug reference URLs). This incredibly useful +;; feature is not available in 27.x yet, so I've backported it: + +(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--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)))))) + +;;;###autoload +(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 (require 'browse-at-remote nil t) + (when-let* ((remote (car (browse-at-remote--get-remotes))) + (url (browse-at-remote--get-remote-url remote))) + (catch 'found + (dolist (config bug-reference-setup-from-vc-alist) + (and (apply #'bug-reference--maybe-setup-from-vc + url config) + (throw 'found t))))))) + +;;;###autoload +(add-hook! '(bug-reference-mode-hook + bug-reference-prog-mode-hook) + (defun +vc-init-bug-reference-from-vc-h () + (when (or bug-reference-mode + bug-reference-prog-mode) + (unless (and bug-reference-bug-regexp + bug-reference-url-format) + (bug-reference-try-setup-from-vc))))) diff --git a/modules/tools/lookup/autoload/lookup.el b/modules/tools/lookup/autoload/lookup.el index c210f228b..531dd7ca0 100644 --- a/modules/tools/lookup/autoload/lookup.el +++ b/modules/tools/lookup/autoload/lookup.el @@ -284,20 +284,28 @@ otherwise falling back to ffap.el (find-file-at-point)." "Searches for a bug reference in user/repo#123 or #123 format and opens it in the browser." (require 'bug-reference) - (let ((bug-reference-url-format bug-reference-url-format) - (bug-reference-bug-regexp bug-reference-bug-regexp) - (bug-reference-mode (derived-mode-p 'text-mode 'conf-mode)) - (bug-reference-prog-mode (derived-mode-p 'prog-mode))) - (bug-reference--run-auto-setup) - (unwind-protect - (catch 'found - (bug-reference-fontify (line-beginning-position) (line-end-position)) - (dolist (o (overlays-at (point))) - ;; It should only be possible to have one URL overlay. - (when-let (url (overlay-get o 'bug-reference-url)) - (browse-url url) - (throw 'found t)))) - (bug-reference-unfontify (line-beginning-position) (line-end-position))))) + (when (fboundp 'bug-reference-try-setup-from-vc) + (let ((old-bug-reference-mode bug-reference-mode) + (old-bug-reference-prog-mode bug-reference-prog-mode) + (bug-reference-url-format bug-reference-url-format) + (bug-reference-bug-regexp bug-reference-bug-regexp)) + (bug-reference-try-setup-from-vc) + (unwind-protect + (let ((bug-reference-mode t) + (bug-reference-prog-mode nil)) + (catch 'found + (bug-reference-fontify (line-beginning-position) (line-end-position)) + (dolist (o (overlays-at (point))) + ;; It should only be possible to have one URL overlay. + (when-let (url (overlay-get o 'bug-reference-url)) + (browse-url url) + + (throw 'found t))))) + ;; Restore any messed up fontification as a result of this. + (bug-reference-unfontify (line-beginning-position) (line-end-position)) + (if (or old-bug-reference-mode + old-bug-reference-prog-mode) + (bug-reference-fontify (line-beginning-position) (line-end-position))))))) ;;