From: Tassilo Horn Date: Sat, 11 Sep 2021 20:49:29 +0000 (+0200) Subject: Refactor bug-reference setup for software forges X-Git-Tag: emacs-28.0.90~1057 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6e60e746535e74d49f4a61b78a7844fa221dbba8;p=emacs.git Refactor bug-reference setup for software forges * lisp/progmodes/bug-reference.el (bug-reference-gitea-instances) (bug-reference-gitlab-instances,bug-reference-sourcehut-instances): Delete defvars. Those are replaced with bug-reference-forge-alist. (bug-reference-forge-alist): New variable. (bug-reference--build-forge-setup-entry): New cl-defgeneric with methods for github, gitlab, gitea, and sourcehut instances. (bug-reference--setup-from-vc-alist): Use bug-reference-forge-alist and bug-reference--build-forge-setup-entry. * doc/emacs/maintaining.texi (Bug Reference): Mention that the first group in bug-reference-bug-regexp defines the overlay bounds. Also mention bug-reference-forge-alist in VCS setup section. --- diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index 8305918336b..4ec2b2d72a6 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -3113,6 +3113,10 @@ these local variables section would do. ;; End: @end smallexample +The string captured by the first regexp group defines the bounds of +the overlay bug-reference creates, i.e., the part which is highlighted +and made clickable. + The string captured by the second regexp group in @code{bug-reference-bug-regexp} is used to replace the @code{%s} template in the @code{bug-reference-url-format}. @@ -3135,20 +3139,22 @@ variables itself by calling the functions in one is able to set the variables. @vindex bug-reference-setup-from-vc-alist +@vindex bug-reference-forge-alist @vindex bug-reference-setup-from-mail-alist @vindex bug-reference-setup-from-irc-alist Right now, there are three types of setup functions. @enumerate @item -Setup for version-controlled files configurable by the variable -@code{bug-reference-setup-from-vc-alist}. The default is able to +Setup for version-controlled files configurable by the variables +@code{bug-reference-forge-alist}, and +@code{bug-reference-setup-from-vc-alist}. The defaults are able to setup GNU projects where @url{https://debbugs.gnu.org} is used as issue tracker and issues are usually referenced as @code{bug#13} (but -many different notations are considered, too), Sourcehut projects -where issues are referenced using the notation @code{#17}, Codeberg -and Github projects where both bugs and pull requests are referenced -using the same notation, and GitLab projects where bugs are referenced -with @code{#17}, too, but merge requests use the @code{!18} notation. +many different notations are considered, too), and several kinds of +modern software forges such as GitLab, Gitea, SourceHut, or GitHub. +If you deploy a self-hosted instance of such a forge, the easiest way +to tell bug-reference about it is through +@code{bug-reference-forge-alist}. @item Setup for email guessing from mail folder/mbox names, and mail header diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index e5d77a0a334..a596b27cd08 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -26,17 +26,17 @@ ;; This file provides minor modes for putting clickable overlays on ;; references to bugs. A bug reference is text like "PR foo/29292"; ;; this is mapped to a URL using a user-supplied format; see -;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More +;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More ;; extensive documentation is in (info "(emacs) Bug Reference"). ;; Two minor modes are provided. One works on any text in the buffer; -;; the other operates only on comments and strings. By default, the +;; the other operates only on comments and strings. By default, the ;; URL link is followed by invoking C-c RET or mouse-2. ;;; Code: (defgroup bug-reference nil - "Hyperlinking references to bug reports" + "Hyperlinking references to bug reports." ;; Somewhat arbitrary, by analogy with eg goto-address. :group 'comm) @@ -125,10 +125,7 @@ to the highlighted and clickable region." (defvar bug-reference-prog-mode) -(defvar bug-reference--nonconforming-regexps nil - "Holds `bug-reference-bug-regexp' values which don't conform to -the documented contract in order to warn about their -non-conformance only once.") +(defvar bug-reference--nonconforming-regexps nil) (defun bug-reference--overlay-bounds () (let ((m-b1 (match-beginning 1)) @@ -171,27 +168,27 @@ subexpression 10." "Apply bug reference overlays to the region between START and END." (save-excursion (let* ((beg-line (progn (goto-char start) (line-beginning-position))) - (end-line (progn (goto-char end) (line-end-position))) + (end-line (progn (goto-char end) (line-end-position))) ;; Reuse existing overlays overlays. (overlays (bug-reference--overlays-in beg-line end-line))) (goto-char beg-line) (while (and (< (point) end-line) - (re-search-forward bug-reference-bug-regexp end-line 'move)) - (when (or (not bug-reference-prog-mode) - ;; This tests for both comment and string syntax. - (nth 8 (syntax-ppss))) - (let* ((bounds (bug-reference--overlay-bounds)) + (re-search-forward bug-reference-bug-regexp end-line 'move)) + (when (or (not bug-reference-prog-mode) + ;; This tests for both comment and string syntax. + (nth 8 (syntax-ppss))) + (let* ((bounds (bug-reference--overlay-bounds)) (overlay (or (let ((ov (pop overlays))) (when ov (move-overlay ov (car bounds) (cdr bounds)) ov)) (let ((ov (make-overlay (car bounds) (cdr bounds) - nil t nil))) + nil t nil))) (overlay-put ov 'category 'bug-reference) ov)))) - ;; Don't put a link if format is undefined. - (when bug-reference-url-format + ;; Don't put a link if format is undefined. + (when bug-reference-url-format (overlay-put overlay 'bug-reference-url (if (stringp bug-reference-url-format) (format bug-reference-url-format @@ -212,14 +209,14 @@ subexpression 10." (if (and (not (integerp pos)) (eventp pos)) ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) - (with-current-buffer (window-buffer (posn-window posn)) - (bug-reference-push-button (posn-point posn) t))) + (with-current-buffer (window-buffer (posn-window posn)) + (bug-reference-push-button (posn-point posn) t))) ;; POS is just normal position. (dolist (o (overlays-at pos)) ;; It should only be possible to have one URL overlay. (let ((url (overlay-get o 'bug-reference-url))) - (when url - (browse-url url)))))) + (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) @@ -230,54 +227,123 @@ subexpression 10." (push (match-string i url) groups)) (funcall bug-url-fmt (nreverse groups)))))) -;; TODO: Change to alist with (HOST PROTOCOL) entries because -;; self-hosted instances might be accessed with http rather than -;; https. -(defvar bug-reference-gitea-instances '("gitea.com" - "codeberg.org") - "List of Gitea forge instances. -When the value is changed after bug-reference has already been -loaded, and performed an auto-setup, evaluate -`(bug-reference--setup-from-vc-alist t)' for rebuilding the value -of `bug-reference--setup-from-vc-alist'.") - -;; TODO: Change to alist with (HOST PROTOCOL) entries because -;; self-hosted instances might be accessed with http rather than -;; https. -(defvar bug-reference-gitlab-instances '("gitlab.com" - "salsa.debian.org" - "framagit.org") - "List of GitLab forge instances. -When the value is changed after bug-reference has already been -loaded, and performed an auto-setup, evaluate -`(bug-reference--setup-from-vc-alist t)' for rebuilding the value -of `bug-reference--setup-from-vc-alist'.") - -;; TODO: Change to alist with (HOST PROTOCOL) entries because -;; self-hosted instances might be accessed with http rather than -;; https. -(defvar bug-reference-sourcehut-instances '("sr.ht") - "List of SourceHut forge instances. -When the value is changed after bug-reference has already been -loaded, and performed an auto-setup, evaluate -`(bug-reference--setup-from-vc-alist t)' for rebuilding the value -of `bug-reference--setup-from-vc-alist'.") - (defvar bug-reference--setup-from-vc-alist nil - "An alist for setting up ‘bug-reference-mode’ based on VC URL. + "An alist for setting up `bug-reference-mode' based on VC URL. This is like `bug-reference-setup-from-vc-alist' but generated -for the known free software forges from the variables -`bug-reference-gitea-instances', -`bug-reference-gitlab-instances', and -`bug-reference-sourcehut-instances'.") +from a few default entries, and the value of +`bug-reference-forge-alist'.") + +(defvar bug-reference-forge-alist + '(("github.com" github "https") + ("gitea.com" gitea "https") + ("codeberg.org" gitea "https") + ("gitlab.com" gitlab "https") + ("framagit.org" gitlab "https") + ("salsa.debian.org" gitlab "https") + ("sr.ht" sourcehut "https")) + "An alist of forge instances. +Each entry has the form (HOST-DOMAIN FORGE-TYPE PROTOCOL). +HOST-DOMAIN is the host- and domain name, e.g., gitlab.com, +salsa.debian.org, or sr.ht. +FORGE-TYPE is the type of the forge, e.g., gitlab, gitea, +sourcehut, or github. +PROTOCOL is the protocol for accessing the forge's issue tracker, +usually \"https\" but for self-hosted forge instances not +accessible via the internet it might also be \"http\".") + +(cl-defgeneric bug-reference--build-forge-setup-entry + (host-domain forge-type protocol) + "Build an entry for `bug-reference--setup-from-vc-alist'. +HOST-DOMAIN is the host- and domain name, e.g., gitlab.com, or +sr.ht. + +FORGE-TYPE is the type of the forge, e.g., gitlab, gitea, +sourcehut, or github. + +PROTOCOL is the protocol for accessing the forge's issue tracker, +usually https but for self-hosted forge instances not accessible +via the internet it might also be http.") + +;; GitHub: 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. +(cl-defmethod bug-reference--build-forge-setup-entry + (host-domain (_forge-type (eql github)) protocol) + `(,(concat "[/@]" host-domain "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (format "%s://%s/%s/issues/%s" + protocol host-domain + (or (match-string-no-properties 2) ns-project) + (match-string-no-properties 3))))))) + +;; GitLab: 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. +(cl-defmethod bug-reference--build-forge-setup-entry + (host-domain (_forge-type (eql gitlab)) protocol) + `(,(concat "[/@]" (regexp-quote host-domain) + "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (format "%s://%s/%s/-/%s/%s" + protocol host-domain + (or (match-string-no-properties 2) ns-project) + (if (string= (match-string-no-properties 3) "#") + "issues/" + "merge_requests/") + (match-string-no-properties 4))))))) + +;; Gitea: The systematics is exactly as for Github projects. +(cl-defmethod bug-reference--build-forge-setup-entry + (host-domain (_forge-type (eql gitea)) protocol) + `(,(concat "[/@]" (regexp-quote host-domain) + "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (format "%s://%s/%s/issues/%s" + protocol host-domain + (or (match-string-no-properties 2) ns-project) + (match-string-no-properties 3))))))) + +;; Sourcehut: #19 is an issue. Other project's issues can be +;; referenced as ~user/project#19. +;; +;; Caveat: The code assumes that a project on git.sr.ht or hg.sr.ht +;; has a tracker of the same name on todo.sh.ht. That's a very common +;; setup but all sr.ht services are loosely coupled, so you can have a +;; repo without tracker, or a repo with a tracker using a different +;; name, etc. So we can only try to make a good guess. +(cl-defmethod bug-reference--build-forge-setup-entry + (host-domain (_forge-type (eql sourcehut)) protocol) + `(,(concat "[/@]\\(?:git\\|hg\\)." (regexp-quote host-domain) + "[/:]\\(~[.A-Za-z0-9_/-]+\\)") + "\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (format "%s://todo.%s/%s/%s" + protocol host-domain + (or (match-string-no-properties 2) ns-project) + (match-string-no-properties 3))))))) (defun bug-reference--setup-from-vc-alist (&optional rebuild) + "Compute the `bug-reference--setup-from-vc-alist' value. +If REBUILD is non-nil, compute it again even if has been computed +already. The value contains a few default entries, and entries +generated from `bug-reference-forge-alist'." (if (and bug-reference--setup-from-vc-alist (null rebuild)) bug-reference--setup-from-vc-alist (setq bug-reference--setup-from-vc-alist - `(;; - ;; GNU projects on savannah. + `(;; GNU projects on savannah. ;; ;; Not all of them use debbugs but that doesn't really ;; matter because the auto-setup is only performed if @@ -286,95 +352,12 @@ for the known free software forges from the variables ("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 2) - ns-project) - "/issues/" - (match-string 3)))))) - ;; - ;; Gitea instances. - ;; - ;; The systematics is exactly as for Github projects. - (,(concat "[/@]" - (regexp-opt bug-reference-gitea-instances t) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") - "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" - ,(lambda (groups) - (let ((host (nth 1 groups)) - (ns-project (nth 2 groups))) - (lambda () - (concat "https://" host "/" - (or - ;; Explicit user/proj#18 link. - (match-string 2) - ns-project) - "/issues/" - (match-string 3)))))) - ;; - ;; GitLab instances. - ;; - ;; 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. - (,(concat "[/@]" - (regexp-opt bug-reference-gitlab-instances t) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") - "\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>" - ,(lambda (groups) - (let ((host (nth 1 groups)) - (ns-project (nth 2 groups))) - (lambda () - (concat "https://" host "/" - (or (match-string 2) - ns-project) - "/-/" - (if (string= (match-string 3) "#") - "issues/" - "merge_requests/") - (match-string 4)))))) - ;; - ;; Sourcehut instances. - ;; - ;; #19 is an issue. Other project's issues can be - ;; #referenced as ~user/project#19. - ;; - ;; Caveat: The code assumes that a project on git.sr.ht or - ;; hg.sr.ht has a tracker of the same name on todo.sh.ht. - ;; That's a very common setup but all sr.ht services are - ;; loosely coupled, so you can have a repo without - ;; tracker, or a repo with a tracker using a different - ;; name, etc. So we can only try to make a good guess. - (,(concat "[/@]\\(?:git\\|hg\\)." - (regexp-opt bug-reference-sourcehut-instances t) - "[/:]\\(~[.A-Za-z0-9_/-]+\\)") - "\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" - ,(lambda (groups) - (let ((host (nth 1 groups)) - (ns-project (nth 2 groups))) - (lambda () - (concat "https://todo." host "/" - (or - ;; Explicit user/proj#18 link. - (match-string 2) - ns-project) - "/" - (match-string 3)))))))))) + + ;; Entries for the software forges of + ;; `bug-reference-forge-alist'. + ,@(mapcar (lambda (entry) + (apply #'bug-reference--build-forge-setup-entry entry)) + bug-reference-forge-alist))))) (defvar bug-reference-setup-from-vc-alist nil "An alist for setting up `bug-reference-mode' based on VC URL.