From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.ciao.gmane.io!not-for-mail From: Tassilo Horn Newsgroups: gmane.emacs.devel Subject: RFC: Automatic setup for bug-reference-mode Date: Sun, 14 Jun 2020 11:37:37 +0200 Message-ID: <87r1uihtsu.fsf@gnu.org> Mime-Version: 1.0 Content-Type: text/plain Injection-Info: ciao.gmane.io; posting-host="ciao.gmane.io:159.69.161.202"; logging-data="74706"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/28.0.50 (gnu/linux) Cc: Stefan Monnier To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sun Jun 14 11:38:13 2020 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1jkP5h-000JMB-BN for ged-emacs-devel@m.gmane-mx.org; Sun, 14 Jun 2020 11:38:13 +0200 Original-Received: from localhost ([::1]:36234 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jkP5g-0002PW-Ea for ged-emacs-devel@m.gmane-mx.org; Sun, 14 Jun 2020 05:38:12 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:49628) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jkP5D-0001yt-GL for emacs-devel@gnu.org; Sun, 14 Jun 2020 05:37:43 -0400 Original-Received: from fencepost.gnu.org ([2001:470:142:3::e]:42328) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jkP5C-0004Gh-Qp; Sun, 14 Jun 2020 05:37:42 -0400 Original-Received: from auth1-smtp.messagingengine.com ([66.111.4.227]:50239) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA256:256) (Exim 4.82) (envelope-from ) id 1jkP5C-0005ol-JR; Sun, 14 Jun 2020 05:37:42 -0400 Original-Received: from compute7.internal (compute7.nyi.internal [10.202.2.47]) by mailauth.nyi.internal (Postfix) with ESMTP id 0378127C005A; Sun, 14 Jun 2020 05:37:42 -0400 (EDT) Original-Received: from mailfrontend2 ([10.202.2.163]) by compute7.internal (MEProxy); Sun, 14 Jun 2020 05:37:42 -0400 X-ME-Sender: X-ME-Proxy-Cause: gggruggvucftvghtrhhoucdtuddrgeduhedrudeiiedgvddtucetufdoteggodetrfdotf fvucfrrhhofhhilhgvmecuhfgrshhtofgrihhlpdfqfgfvpdfurfetoffkrfgpnffqhgen uceurghilhhouhhtmecufedttdenucesvcftvggtihhpihgvnhhtshculddquddttddmne cujfgurhephffvufffkfgfgggtsehttdertddtredtnecuhfhrohhmpefvrghsshhilhho ucfjohhrnhcuoehtshguhhesghhnuhdrohhrgheqnecuggftrfgrthhtvghrnhepieektd fhkeeiteevteehtedvvdeijefgleektdefvedvkeevudeuvefgjeffffevnecuffhomhgr ihhnpehgnhhurdhorhhgpdhgihhthhhusgdrtghomhdpghhithhlrggsrdgtohhmnecukf hppeelfedrvdefiedrudefiedrfedunecuvehluhhsthgvrhfuihiivgeptdenucfrrghr rghmpehmrghilhhfrhhomhepthhhohhrnhdomhgvshhmthhprghuthhhphgvrhhsohhnrg hlihhthidqkeeijeefkeejkeegqdeifeehvdelkedqthhsughhpeepghhnuhdrohhrghes fhgrshhtmhgrihhlrdhfmh X-ME-Proxy: Original-Received: from thinkpad-t440p (p5dec881f.dip0.t-ipconnect.de [93.236.136.31]) by mail.messagingengine.com (Postfix) with ESMTPA id 786933060FE7; Sun, 14 Jun 2020 05:37:40 -0400 (EDT) Mail-Followup-To: emacs-devel@gnu.org, Stefan Monnier X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.23 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:252222 Archived-At: Hi all, I've been working on a feature to setup bug-reference-mode automatically in common cases, i.e., make it guess the right `bug-reference-url-format' and `bug-reference-bug-regexp' automatically (if not already set). Attach is my first attempt at doing so and I'd welcome comments. What it achieves in the current state: - Setup according to VCS information - Only for Git at the moment (Is there a generic way to get the VCS URL?) - Project on savannah => setup GNU debbugs instance - GitHub: support #17 and namespace/project#17 links (both issues and PRs) - GitLab: support #17 issue links and !18 merge request including cross-project namespace/project#18 references. - Setup according to Gnus newsgroup, To, From, Cc - Probably too lax but works for setting our GNU debbugs instance for emacs-devel and other emacs-related mailing lists and newsgroups. Bye, Tassilo --8<---------------cut here---------------start------------->8--- 2 files changed, 142 insertions(+), 4 deletions(-) lisp/progmodes/bug-reference.el | 139 +++++++++++++++++++++++++++++++++++++++- lisp/vc/vc.el | 7 +- modified lisp/progmodes/bug-reference.el @@ -60,6 +60,7 @@ bug-reference-url-format 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 @@ bug-reference-bug-regexp :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,139 @@ bug-reference-push-button (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. +They are only called if the two variables aren't set already, +e.g., by a local variables section. + +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. Explicit user/project#17 links to possibly + ;; different projects are also supported. + (maybe-set + "[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)" + (lambda () + (let ((ns-project (match-string 1 url))) + (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. + (maybe-set + "[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:#\\|!\\)\\(?2:[0-9]+\\)" + (lambda () + (let ((ns-project (match-string 1 url))) + (lambda () + (concat "https://gitlab.com/" + (or (match-string 1) + ns-project) + "/-/" + (if (string= (match-string 3) "#") + "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 + ;; 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) + (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 +281,7 @@ bug-reference-mode "" 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 +294,7 @@ bug-reference-prog-mode "" nil (if bug-reference-prog-mode - (jit-lock-register #'bug-reference-fontify) + (bug-reference--init) (jit-lock-unregister #'bug-reference-fontify) (save-restriction (widen) modified lisp/vc/vc.el @@ -957,7 +957,7 @@ vc-backend-for-registration (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 @@ vc-responsible-backend 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, --8<---------------cut here---------------end--------------->8---