From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: =?UTF-8?Q?K=C3=A9vin?= Le Gouguec Newsgroups: gmane.emacs.bugs Subject: bug#68183: 28.3; vc-dir fails when I have a certain branch checked out Date: Wed, 07 Aug 2024 16:25:31 +0200 Message-ID: <87h6bwqujo.fsf@gmail.com> References: <8734vici68.fsf@tromey.com> <83y1da17zw.fsf@gnu.org> <87y1dab03x.fsf@tromey.com> <87h6jun400.fsf@gmail.com> <878r3q2jfx.fsf@gmail.com> <877cj6izv7.fsf@gmail.com> <87zfuyrrfz.fsf@gmail.com> <283baeb9-d427-45a3-92d5-5e6c095b87ad@gutov.dev> <87ttl43f2x.fsf@gmail.com> <06a946b4-b06a-4e10-93d5-b6d6b8bd9fcf@gutov.dev> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="6448"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: Dmitry Gutov , Eli Zaretskii , Tom Tromey , Sean Whitton , Juri Linkov To: 68183@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Aug 07 16:27:59 2024 Return-path: Envelope-to: geb-bug-gnu-emacs@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 1sbhdu-0001Tz-Qn for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 07 Aug 2024 16:27:59 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sbhdd-0006gi-32; Wed, 07 Aug 2024 10:27:41 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sbhda-0006VM-NR for bug-gnu-emacs@gnu.org; Wed, 07 Aug 2024 10:27:39 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1sbhda-0003Tw-DN for bug-gnu-emacs@gnu.org; Wed, 07 Aug 2024 10:27:38 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:References:In-Reply-To:From:To:Subject; bh=NGPO7+Uw7MIN2ACrWnWcwPCKzOCnz+ONpqfg7CjxEZ8=; b=F0w/DxnaVbLqE+ZUakOttLCAfBu805GgRtda6zO6xn9bpjdORfcG0GzCcoALapEdI5vy+l57b9/fnQncXJ+VPM6GobVaBLci5GiRiI5ac7QceIRXFQvkPXjwiHQywxiiw/fJrHU4itO9QLXLJfz+1Xpyobl8tlPpx2g7/KHosvXG/L0+v1OdoU7mKoh3AQHDxArMhzmfGrROoavU8uVfEx9x6fslEWfmsLDcfbE9jQL6Je2pEt7ZgFE2raf8TynXuIUMnjEuA5fiNef24XdVf+MBV2TQvUioNqe3Bh+1O95LmULW+puvTxkyjZQCrRPwsW9DPJNuriGjvU9uyMDjVQ==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1sbhdy-0008Rj-5w for bug-gnu-emacs@gnu.org; Wed, 07 Aug 2024 10:28:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: =?UTF-8?Q?K=C3=A9vin?= Le Gouguec Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 07 Aug 2024 14:28:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 68183 X-GNU-PR-Package: emacs Original-Received: via spool by 68183-submit@debbugs.gnu.org id=B68183.172304083232385 (code B ref 68183); Wed, 07 Aug 2024 14:28:02 +0000 Original-Received: (at 68183) by debbugs.gnu.org; 7 Aug 2024 14:27:12 +0000 Original-Received: from localhost ([127.0.0.1]:34860 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sbhd8-0008QE-51 for submit@debbugs.gnu.org; Wed, 07 Aug 2024 10:27:12 -0400 Original-Received: from mail-lj1-f178.google.com ([209.85.208.178]:56356) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sbhd4-0008Pc-6F for 68183@debbugs.gnu.org; Wed, 07 Aug 2024 10:27:08 -0400 Original-Received: by mail-lj1-f178.google.com with SMTP id 38308e7fff4ca-2f15790b472so24318201fa.0 for <68183@debbugs.gnu.org>; Wed, 07 Aug 2024 07:26:40 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1723040734; x=1723645534; darn=debbugs.gnu.org; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=NGPO7+Uw7MIN2ACrWnWcwPCKzOCnz+ONpqfg7CjxEZ8=; b=EFx24i6pzRWovnrCU3aZcp2Dmlz7w2bk/UkMnSdMchdfQaC2i2AGana4dEUc2rHKoK aI84TEVRaR090ldZsKbVXEPPhItcEUpCndU39L59xYxoYVb2BivpyMUOoYwF7fC4ONU4 RPSDaVMGncWzqqL0oF0/zuD1MtwGfI8tyiQ0YaqjIfsufKOwjCN7MBw7yzKAvjDvPiL4 H+vbiTQSdWKY8tugWiTq+h077VZIPREKp6SlvrCXFcV+t3pPy5h5B0W6YSFVUoBsqvUO HvJxnNxVWWaDyyWurtAh9elsDsHsLNZOrLJEmUfeEGS43x1vrZpiomjPVaBr/Ke4781F zj5w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1723040734; x=1723645534; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=NGPO7+Uw7MIN2ACrWnWcwPCKzOCnz+ONpqfg7CjxEZ8=; b=srrYHpoe1fahBVRYv4WOTTfFbksEIVbLcVsWHTLBbQvu6Z0N1rvlsyPpQinHZ/w1HI 8pAzog4n7PCwzS5V5+HhP1IAbGFdIojFIcPQ6czpF4jF7HG7gyxlUA07NrONgYpFYtlv DAjBFhU9me+vU/xo5n8VNdWkIyBJAeHugqL1+xQ7J5EvSWgn7A69rI82xJLCrlCLku+J Vaqh8Hk9PSvB1JsXzpmw03dI207rJZ2kKR4dIltz4BLTm+YSamfuYEhvU6ftvITYbXlH Tq2T09h5MApPGG9PoBLHf5HW1IUXfFgiAVGeq7DD8epgTn6ebY5FAUYDal7UrmBMUgtp H9UA== X-Gm-Message-State: AOJu0YxFXTZMOnjPfs8pxMVTYN42P/w2bR7/vuc57hJEBryZkBpjp3gJ USCiDrbrjgKjbKhCQENLvFdAXWcBjaoNTDdXwWVEzd67NOpIIRFi X-Google-Smtp-Source: AGHT+IH7jWeLUIhWbH6Ivcb9Oh+NMD3UE9MkpNokzX4ggD2GhGhbRYcSY0Mkyas+f08DCn8GFapNAA== X-Received: by 2002:a2e:3c18:0:b0:2ef:2b08:1742 with SMTP id 38308e7fff4ca-2f15ab396eemr115827491fa.48.1723040733687; Wed, 07 Aug 2024 07:25:33 -0700 (PDT) Original-Received: from hirondell ([2001:861:5642:b310:f004:ddf4:26e1:944]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-429059a5a8fsm31912485e9.34.2024.08.07.07.25.32 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 07 Aug 2024 07:25:32 -0700 (PDT) In-Reply-To: <06a946b4-b06a-4e10-93d5-b6d6b8bd9fcf@gutov.dev> (Dmitry Gutov's message of "Mon, 18 Mar 2024 17:26:11 +0200") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:289887 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Heya, Have spent cycles on this on-and-off these past few months; finally have something worth discussing, I think =F0=9F=A4=9E To recap where we stand, AFAIU: the reported vc-dir bug has been fixed (in time for the emacs-30 branch), but the changes could feel intrusive, since a new vc-dir header was added ("Tracking") that some users may not care for. I've now drafted a user option to give users more control over this new header; see patch #3 in the attached series. The first two patches are yak-shaving: patch #1 adds regression tests, patch #2 splits vc-git-dir-extra-headers into more manageable chunks (pure refactoring, no functional change intended). Also attaching a 'squashed.patch' if that helps review. About patch #2, CC'ing Sean Whitton for perspective on vc-git--cmds-in-progress: I was puzzled by the function supporting many commands (rebase, am, merge, bisect), whereas AFAICT its sole user only heeds 'bisect & 'rebase. Wondering if I've missed other in-tree uses, or if we should add headers for 'am and 'merge, "while in there". Curious what y'all think. OT1H not sure an alist is the best UX, OTOH struggled to keep option names concise otherwise. --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-Test-more-vc-dir-scenarios-with-Git-bug-68183.patch >From 1573015fba16f8b453e87e92e982fc633bca40d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Sun, 7 Jul 2024 12:16:12 +0200 Subject: [PATCH 1/3] Test more vc-dir scenarios with Git (bug#68183) * test/lisp/vc/vc-git-tests.el (vc-git-test-dir-track-local-branch): Remove in favor of new test. (vc-git-test--start-branch): New helper to get a repository going. (vc-git-test--dir-headers): New helper to get a list of headers in the current vc-dir buffer. (vc-git-test-dir-branch-headers): New test, exercising the original bug recipe plus more common scenarios. --- test/lisp/vc/vc-git-tests.el | 98 +++++++++++++++++++++++++++++------- 1 file changed, 80 insertions(+), 18 deletions(-) diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index f15a0f52e8c..2dbf5a8df12 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -26,6 +26,7 @@ (require 'ert-x) (require 'vc) +(require 'vc-dir) (require 'vc-git) (ert-deftest vc-git-test-program-version-general () @@ -108,24 +109,85 @@ vc-git-test--run (apply 'vc-git-command t 0 nil args) (buffer-string))) -(ert-deftest vc-git-test-dir-track-local-branch () - "Test that `vc-dir' works when tracking local branches. Bug#68183." +(defun vc-git-test--start-branch () + "Get a branch started in a freshly initialized repository. + +This returns the name of the current branch, so that tests can remain +agnostic of init.defaultbranch." + (write-region "hello" nil "README") + (vc-git-test--run "add" "README") + (vc-git-test--run "commit" "-mFirst") + (string-trim (vc-git-test--run "branch" "--show-current"))) + +(defun vc-git-test--dir-headers (headers) + "Return an alist of header values for the current `vc-dir' buffer. + +HEADERS should be a list of (NAME ...) strings. This function will +return a list of (NAME . VALUE) pairs, where VALUE is nil if the header +is absent." + ;; FIXME: to reproduce interactive sessions faithfully, we would need + ;; to wait for the dir-status-files process to terminate; have not + ;; found a reliable way to do this. As a workaround, kill pending + ;; processes and revert the `vc-dir' buffer. + (vc-dir-kill-dir-status-process) + (revert-buffer) + (mapcar + (lambda (header) + (let* ((pattern + (rx bol + (literal header) (* space) ": " (group (+ nonl)) + eol)) + (value (and (goto-char (point-min)) + (re-search-forward pattern nil t) + (match-string 1)))) + (cons header value))) + headers)) + +(ert-deftest vc-git-test-dir-branch-headers () + "Check that `vc-dir' shows expected branch-related headers." (skip-unless (executable-find vc-git-program)) - (vc-git-test--with-repo repo - ;; Create an initial commit to get a branch started. - (write-region "hello" nil "README") - (vc-git-test--run "add" "README") - (vc-git-test--run "commit" "-mFirst") - ;; Get current branch name lazily, to remain agnostic of - ;; init.defaultbranch. - (let ((upstream-branch - (string-trim (vc-git-test--run "branch" "--show-current")))) - (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch) - (vc-dir default-directory) - (pcase-dolist (`(,header ,value) - `(("Branch" "hack") - ("Tracking" ,upstream-branch))) - (goto-char (point-min)) - (re-search-forward (format "^%s *: %s$" header value)))))) + ;; Create a repository that will serve as the "remote". + (vc-git-test--with-repo origin-repo + (let ((main-branch (vc-git-test--start-branch))) + ;; 'git clone' this repository and test things in this clone. + (ert-with-temp-directory clone-repo + (vc-git-test--run "clone" origin-repo clone-repo) + (vc-dir clone-repo) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . ,main-branch) + ("Tracking" . ,(concat "origin/" main-branch)) + ("Remote" . ,origin-repo)))) + ;; Checkout a new branch: no tracking information. + (vc-git-test--run "checkout" "-b" "feature/foo" main-branch) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + '(("Branch" . "feature/foo") + ("Tracking" . nil) + ("Remote" . nil)))) + ;; Push with '--set-upstream origin': tracking information + ;; should be updated. + (vc-git-test--run "push" "--set-upstream" "origin" "feature/foo") + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . "feature/foo") + ("Tracking" . "origin/feature/foo") + ("Remote" . ,origin-repo)))) + ;; Checkout a new branch tracking the _local_ main branch. + ;; Bug#68183. + (vc-git-test--run "checkout" "-b" "feature/bar" "--track" main-branch) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . "feature/bar") + ("Tracking" . ,main-branch) + ("Remote" . "none (tracking local branch)")))))))) ;;; vc-git-tests.el ends here -- 2.39.2 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0002-Split-vc-git-dir-extra-headers-into-more-manageable-.patch >From f4caa79c492116c3b9c6a6df7972222ee977f13c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Sun, 9 Jun 2024 19:41:41 +0200 Subject: [PATCH 2/3] Split vc-git-dir-extra-headers into more manageable chunks The current code requires a lot of eyeballing back-and-forth to: - check where variables are actually used, what impact changing them can have: in actuality, there are three distinct "groups" of headers we compute, each with their own independent state; - understand formatting details such as "who's in charge of the newlines". To solve both issues, split that function into smaller ones, each handling a "group" of headers. The only expected "functional" change is that, by propertizing "\nHeader: " strings, the original code sometimes applied the vc-dir-header face to the newline preceding a header; the new code applies no faces to these newlines. This change would be visible to users with themes adding an :extended background to vc-dir-header. In practice, no in-tree theme is impacted. For bug#68183. * lisp/vc/vc-git.el (vc-git-dir--branch-headers): New function to compute "Branch", "Tracking" and "Remote". (vc-git--cmds-in-progress): Rename to... (vc-git-dir--in-progress-headers): ... this, and compute headers. (vc-git-dir--stash-headers): New function to compute the "Stash" header. (vc-git-dir-extra-headers): Boil down to just setting default-directory and assembling the headers from these new helpers. (vc-git--out-match): New function to call 'git' and capture specific bits of output. --- lisp/vc/vc-git.el | 253 ++++++++++++++++++++++++---------------------- 1 file changed, 131 insertions(+), 122 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index e8257c5dbd0..4d631c7e032 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -717,6 +717,63 @@ vc-git-dir-status-files :files files :update-function update-function))) +(defun vc-git-dir--branch-headers () + "Return headers for branch-related information." + (let ((branch (vc-git--out-match + '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + tracking remote-url) + (if branch + (when-let ((branch-merge + (vc-git--out-match + `("config" ,(concat "branch." branch ".merge")) + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (branch-remote + (vc-git--out-match + `("config" ,(concat "branch." branch ".remote")) + "\\([^\n]+\\)" 1))) + (if (string= branch-remote ".") + (setq tracking branch-merge + remote-url "none (tracking local branch)") + (setq tracking (concat branch-remote "/" branch-merge) + remote-url (vc-git-repository-url + default-directory branch-remote)))) + (setq branch "none (detached HEAD)")) + (cl-flet ((fmt (key value) + (concat + (propertize (format "% -11s: " key) 'face 'vc-dir-header) + (propertize value 'face 'vc-dir-header-value)))) + (remove nil (list + (fmt "Branch" branch) + (and tracking (fmt "Tracking" tracking)) + (and remote-url (fmt "Remote" remote-url))))))) + +(defun vc-git-dir--in-progress-headers () + "Return headers for Git commands in progress in this worktree." + (let ((gitdir (vc-git--git-path)) + cmds) + ;; See contrib/completion/git-prompt.sh in git.git. + (when (or (file-directory-p + (expand-file-name "rebase-merge" gitdir)) + (file-exists-p + (expand-file-name "rebase-apply/rebasing" gitdir))) + (push 'rebase cmds)) + (when (file-exists-p + (expand-file-name "rebase-apply/applying" gitdir)) + (push 'am cmds)) + (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir)) + (push 'merge cmds)) + (when (file-exists-p (expand-file-name "BISECT_START" gitdir)) + (push 'bisect cmds)) + (cl-flet ((fmt (cmd name) + (when (memq cmd cmds) + ;; For now just a heading, key bindings can be added + ;; later for various bisect actions. + (propertize (format "% -11s: in progress" name) + 'face 'vc-dir-status-warning)))) + (remove nil (list (fmt 'bisect "Bisect") + (fmt 'rebase "Rebase")))))) + (defvar-keymap vc-git-stash-shared-map "S" #'vc-git-stash-snapshot "C" #'vc-git-stash) @@ -797,130 +854,75 @@ vc-git-stash-menu-map :help "Show the contents of the current stash")) map)) -(defun vc-git--cmds-in-progress () - "Return a list of Git commands in progress in this worktree." - (let ((gitdir (vc-git--git-path)) - cmds) - ;; See contrib/completion/git-prompt.sh in git.git. - (when (or (file-directory-p - (expand-file-name "rebase-merge" gitdir)) - (file-exists-p - (expand-file-name "rebase-apply/rebasing" gitdir))) - (push 'rebase cmds)) - (when (file-exists-p - (expand-file-name "rebase-apply/applying" gitdir)) - (push 'am cmds)) - (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir)) - (push 'merge cmds)) - (when (file-exists-p (expand-file-name "BISECT_START" gitdir)) - (push 'bisect cmds)) - cmds)) +(defun vc-git-dir--stash-headers () + "Return headers describing the current stashes." + (list + (concat + (propertize "Stash : " 'face 'vc-dir-header) + (if-let ((stash-list (vc-git-stash-list))) + (let* ((len (length stash-list)) + (limit + (if (integerp vc-git-show-stash) + (min vc-git-show-stash len) + len)) + (shown-stashes (cl-subseq stash-list 0 limit)) + (hidden-stashes (cl-subseq stash-list limit)) + (all-hideable (or (eq vc-git-show-stash t) + (<= len vc-git-show-stash)))) + (concat + ;; Button to toggle visibility. + (if all-hideable + (vc-git-make-stash-button nil limit limit) + (vc-git-make-stash-button t vc-git-show-stash len)) + ;; Stash list. + (when shown-stashes + (concat + (propertize "\n" + 'vc-git-hideable all-hideable) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'vc-git-hideable all-hideable + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + shown-stashes + (propertize "\n" + 'vc-git-hideable all-hideable)))) + (when hidden-stashes + (concat + (propertize "\n" + 'invisible t + 'vc-git-hideable t) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'invisible t + 'vc-git-hideable t + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + hidden-stashes + (propertize "\n" + 'invisible t + 'vc-git-hideable t)))))) + (propertize "Nothing stashed" + 'help-echo vc-git-stash-shared-help + 'keymap vc-git-stash-shared-map + 'face 'vc-dir-header-value))))) (defun vc-git-dir-extra-headers (dir) - (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) - (stash-list (vc-git-stash-list)) - (default-directory dir) - (in-progress (vc-git--cmds-in-progress)) - - branch remote-url stash-button stash-string tracking-branch) - (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) - (progn - (setq branch (match-string 2 str)) - (let ((remote (vc-git--out-str - "config" (concat "branch." branch ".remote"))) - (merge (vc-git--out-str - "config" (concat "branch." branch ".merge")))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) - (setq tracking-branch (match-string 2 merge))) - (pcase remote - ("." - (setq remote-url "none (tracking local branch)")) - ((pred (not string-empty-p)) - (setq - remote-url (vc-git-repository-url dir remote) - tracking-branch (concat remote "/" tracking-branch)))))) - (setq branch "none (detached HEAD)")) - (when stash-list - (let* ((len (length stash-list)) - (limit - (if (integerp vc-git-show-stash) - (min vc-git-show-stash len) - len)) - (shown-stashes (cl-subseq stash-list 0 limit)) - (hidden-stashes (cl-subseq stash-list limit)) - (all-hideable (or (eq vc-git-show-stash t) - (<= len vc-git-show-stash)))) - (setq stash-button (if all-hideable - (vc-git-make-stash-button nil limit limit) - (vc-git-make-stash-button t vc-git-show-stash len)) - stash-string - (concat - (when shown-stashes - (concat - (propertize "\n" - 'vc-git-hideable all-hideable) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'vc-git-hideable all-hideable - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - shown-stashes - (propertize "\n" - 'vc-git-hideable all-hideable)))) - (when hidden-stashes - (concat - (propertize "\n" - 'invisible t - 'vc-git-hideable t) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'invisible t - 'vc-git-hideable t - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - hidden-stashes - (propertize "\n" - 'invisible t - 'vc-git-hideable t)))))))) - (concat - (propertize "Branch : " 'face 'vc-dir-header) - (propertize branch - 'face 'vc-dir-header-value) - (when tracking-branch - (concat - "\n" - (propertize "Tracking : " 'face 'vc-dir-header) - (propertize tracking-branch 'face 'vc-dir-header-value))) - (when remote-url - (concat - "\n" - (propertize "Remote : " 'face 'vc-dir-header) - (propertize remote-url - 'face 'vc-dir-header-value))) - ;; For now just a heading, key bindings can be added later for various bisect actions - (when (memq 'bisect in-progress) - (propertize "\nBisect : in progress" 'face 'vc-dir-status-warning)) - (when (memq 'rebase in-progress) - (propertize "\nRebase : in progress" 'face 'vc-dir-status-warning)) - (if stash-list - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - stash-button - stash-string) - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - (propertize "Nothing stashed" - 'help-echo vc-git-stash-shared-help - 'keymap vc-git-stash-shared-map - 'face 'vc-dir-header-value)))))) + (let ((default-directory dir)) + (string-join + (append + ;; Each helper returns a list of headers. Each header must be a + ;; propertized string with no final newline. + (vc-git-dir--branch-headers) + (vc-git-dir--in-progress-headers) + (vc-git-dir--stash-headers)) + "\n"))) (defun vc-git-branches () "Return the existing branches, as a list of strings. @@ -2246,6 +2248,13 @@ vc-git--out-str (with-current-buffer standard-output (apply #'vc-git--out-ok command args)))) +(defun vc-git--out-match (args regexp group) + "Run `git ARGS...' and return match for group number GROUP of REGEXP. +Return nil if the output does not match. The exit status is ignored." + (let ((out (apply #'vc-git--out-str args))) + (when (string-match regexp out) + (match-string group out)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." -- 2.39.2 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0003-Let-users-choose-when-and-how-to-display-Git-trackin.patch >From f21546f5cae71f00a73298315f00f7693cb21d5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Sun, 7 Jul 2024 19:45:49 +0200 Subject: [PATCH 3/3] Let users choose when and how to display Git tracking branch For bug#68183. * lisp/vc/vc-git.el (vc-git-dir-show-tracking): New option. (vc-git-dir--tracking): New function to format upstream branch according to the new option. (vc-git-dir--branch-headers): Use new option & new function to format upstream branch according to user preference. * test/lisp/vc/vc-git-tests.el (vc-git-test--dir-headers): Allow temporarily binding the new option. (vc-git-test-dir-branch-headers): Test a handful of option tweaks. --- lisp/vc/vc-git.el | 101 ++++++++++++++++++++++++++++++----- test/lisp/vc/vc-git-tests.el | 72 ++++++++++++++++++------- 2 files changed, 140 insertions(+), 33 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 4d631c7e032..86752bd074d 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -717,6 +717,66 @@ vc-git-dir-status-files :files files :update-function update-function))) +(defcustom vc-git-dir-show-tracking '((when . set) + (how . header)) + "Control how `vc-dir' shows the upstream branch. +The \"upstream\" branch is the one `vc-pull' fetches changes from by +default. In Git terms, when checking out branch B, the upstream branch +is defined by the configuration options branch.B.merge and +branch.B.remote. + +This option is an alist which admits the following symbol keys: + +* `when' controls whether information about the upstream branch will be + shown. The value for this key can be one of the following symbols: + - set (default) Only show the upstream branch if it is set, + as defined by the previously mentioned Git config + options. + - t If a branch is checked out (that is, HEAD is not + detached), always show something: fallback to \"none\" + if the current branch is not tracking anything. + - different Only show the upstream branch if branch.B.merge is + named differently from B. This allows hiding the + header in the common case where branch \"foo\" tracks + \"origin/foo\". + - never Never show the upstream branch. + +* `how' controls the way this information will be shown. The value can + be one of the following symbols: + - header (default) Show the branch in a dedicated header, + \"Tracking\". + - inline Append the branch to the \"Branch\" header, e.g. + Branch: foo (tracking origin/bar)" + :type 'alist + :options + '((when (radio + (const :tag "Never" never) + (const :tag "Always" t) + (const :tag "If current branch has a tracking branch" set) + (const :tag "If current & tracking branches have different names" different))) + (how (radio + (const :tag "\"Tracking\" header" header) + (const :tag "Inline in \"Branch\" header" inline)))) + :version "31.1") + +(defun vc-git-dir--tracking (branch branch-merge branch-remote) + "Return a description of BRANCH's upstream branch. +This description heeds `vc-git-dir-show-tracking'." + (cl-flet ((remote-prefix () + (if (equal branch-remote ".") + nil + (concat branch-remote "/")))) + (pcase-exhaustive (alist-get 'when vc-git-dir-show-tracking 'set) + ('set (and branch-merge + (concat (remote-prefix) branch-merge))) + ('never nil) + ('t (if branch-merge + (concat (remote-prefix) branch-merge) + "none")) + ('different (and branch-merge + (not (equal branch branch-merge)) + (concat (remote-prefix) branch-merge)))))) + (defun vc-git-dir--branch-headers () "Return headers for branch-related information." (let ((branch (vc-git--out-match @@ -724,25 +784,38 @@ vc-git-dir--branch-headers "^\\(refs/heads/\\)?\\(.+\\)$" 2)) tracking remote-url) (if branch - (when-let ((branch-merge - (vc-git--out-match - `("config" ,(concat "branch." branch ".merge")) - "^\\(refs/heads/\\)?\\(.+\\)$" 2)) - (branch-remote - (vc-git--out-match - `("config" ,(concat "branch." branch ".remote")) - "\\([^\n]+\\)" 1))) - (if (string= branch-remote ".") - (setq tracking branch-merge - remote-url "none (tracking local branch)") - (setq tracking (concat branch-remote "/" branch-merge) - remote-url (vc-git-repository-url - default-directory branch-remote)))) + (let ((branch-merge + (vc-git--out-match + `("config" ,(concat "branch." branch ".merge")) + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (branch-remote + (vc-git--out-match + `("config" ,(concat "branch." branch ".remote")) + "\\([^\n]+\\)" 1))) + ;; Either BRANCH-MERGE and BRANCH-REMOTE are both set, or + ;; neither are. + (cl-assert + (eq (not (not branch-merge)) + (not (not branch-remote))) + nil "Inconsistent branch settings: merge is %s; remote is %s" + branch-merge branch-remote) + (setq tracking (vc-git-dir--tracking + branch branch-merge branch-remote) + remote-url (and branch-remote + (if (equal branch-remote ".") + "none (tracking local branch)" + (vc-git-repository-url + default-directory branch-remote))))) (setq branch "none (detached HEAD)")) (cl-flet ((fmt (key value) (concat (propertize (format "% -11s: " key) 'face 'vc-dir-header) (propertize value 'face 'vc-dir-header-value)))) + (when (and tracking + (eq (alist-get 'how vc-git-dir-show-tracking 'header) + 'inline)) + (setq branch (format "%s (tracking %s)" branch tracking) + tracking nil)) (remove nil (list (fmt "Branch" branch) (and tracking (fmt "Tracking" tracking)) diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index 2dbf5a8df12..4ece262564e 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -119,29 +119,34 @@ vc-git-test--start-branch (vc-git-test--run "commit" "-mFirst") (string-trim (vc-git-test--run "branch" "--show-current"))) -(defun vc-git-test--dir-headers (headers) +(defun vc-git-test--dir-headers (headers &optional show-tracking) "Return an alist of header values for the current `vc-dir' buffer. HEADERS should be a list of (NAME ...) strings. This function will return a list of (NAME . VALUE) pairs, where VALUE is nil if the header -is absent." - ;; FIXME: to reproduce interactive sessions faithfully, we would need - ;; to wait for the dir-status-files process to terminate; have not - ;; found a reliable way to do this. As a workaround, kill pending - ;; processes and revert the `vc-dir' buffer. - (vc-dir-kill-dir-status-process) - (revert-buffer) - (mapcar - (lambda (header) - (let* ((pattern - (rx bol - (literal header) (* space) ": " (group (+ nonl)) - eol)) - (value (and (goto-char (point-min)) - (re-search-forward pattern nil t) - (match-string 1)))) - (cons header value))) - headers)) +is absent. + +SHOW-TRACKING is a temporary value to bind `vc-git-dir-show-tracking' +to. If omitted, the default value will be kept." + (let ((vc-git-dir-show-tracking (or show-tracking + vc-git-dir-show-tracking))) + ;; FIXME: to reproduce interactive sessions faithfully, we would need + ;; to wait for the dir-status-files process to terminate; have not + ;; found a reliable way to do this. As a workaround, kill pending + ;; processes and revert the `vc-dir' buffer. + (vc-dir-kill-dir-status-process) + (revert-buffer) + (mapcar + (lambda (header) + (let* ((pattern + (rx bol + (literal header) (* space) ": " (group (+ nonl)) + eol)) + (value (and (goto-char (point-min)) + (re-search-forward pattern nil t) + (match-string 1)))) + (cons header value))) + headers))) (ert-deftest vc-git-test-dir-branch-headers () "Check that `vc-dir' shows expected branch-related headers." @@ -153,6 +158,8 @@ vc-git-test-dir-branch-headers (ert-with-temp-directory clone-repo (vc-git-test--run "clone" origin-repo clone-repo) (vc-dir clone-repo) + + ;; Post-clone: on MAIN-BRANCH, tracking origin/MAIN-BRANCH. (should (equal (vc-git-test--dir-headers @@ -160,6 +167,25 @@ vc-git-test-dir-branch-headers `(("Branch" . ,main-branch) ("Tracking" . ,(concat "origin/" main-branch)) ("Remote" . ,origin-repo)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((how . inline))) + `(("Branch" . ,(format "%s (tracking origin/%s)" main-branch main-branch)) + ("Tracking" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . different))) + `(("Branch" . ,main-branch) + ("Tracking" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . never))) + `(("Branch" . ,main-branch) + ("Tracking" . nil)))) + ;; Checkout a new branch: no tracking information. (vc-git-test--run "checkout" "-b" "feature/foo" main-branch) (should @@ -169,6 +195,13 @@ vc-git-test-dir-branch-headers '(("Branch" . "feature/foo") ("Tracking" . nil) ("Remote" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . t))) + '(("Branch" . "feature/foo") + ("Tracking" . "none")))) + ;; Push with '--set-upstream origin': tracking information ;; should be updated. (vc-git-test--run "push" "--set-upstream" "origin" "feature/foo") @@ -179,6 +212,7 @@ vc-git-test-dir-branch-headers `(("Branch" . "feature/foo") ("Tracking" . "origin/feature/foo") ("Remote" . ,origin-repo)))) + ;; Checkout a new branch tracking the _local_ main branch. ;; Bug#68183. (vc-git-test--run "checkout" "-b" "feature/bar" "--track" main-branch) -- 2.39.2 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=squashed.patch >From 2de70ea79a5d8eb98e0dcd4ef0598a8e033b6526 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= Date: Sun, 7 Jul 2024 12:16:12 +0200 Subject: [PATCH] Let users choose when and how to display Git tracking branch While in there, split vc-git-dir-extra-headers into more manageable chunks. The current code requires a lot of eyeballing back-and-forth to: - check where variables are actually used, what impact changing them can have: in actuality, there are three distinct "groups" of headers we compute, each with their own independent state; - understand formatting details such as "who's in charge of the newlines". To solve both issues, split that function into smaller ones, each handling a "group" of headers. The only expected "functional" change is that, by propertizing "\nHeader: " strings, the original code sometimes applied the vc-dir-header face to the newline preceding a header; the new code applies no faces to these newlines. This change would be visible to users with themes adding an :extended background to vc-dir-header. In practice, no in-tree theme is impacted. For bug#68183. * lisp/vc/vc-git.el (vc-git-dir-show-tracking): New option. (vc-git-dir--tracking): New function to format upstream branch according to the new option. (vc-git-dir--branch-headers): New function to compute "Branch", "Tracking" and "Remote". (vc-git--cmds-in-progress): Rename to... (vc-git-dir--in-progress-headers): ... this, and compute headers. (vc-git-dir--stash-headers): New function to compute the "Stash" header. (vc-git-dir-extra-headers): Boil down to just setting default-directory and assembling the headers from these new helpers. (vc-git--out-match): New function to call 'git' and capture specific bits of output. * test/lisp/vc/vc-git-tests.el (vc-git-test-dir-track-local-branch): Remove in favor of new test. (vc-git-test--start-branch): New helper to get a repository going. (vc-git-test--dir-headers): New helper to get a list of headers in the current vc-dir buffer. (vc-git-test-dir-branch-headers): New test, exercising the original bug recipe plus more common scenarios, as well as some option tweaks. --- lisp/vc/vc-git.el | 326 ++++++++++++++++++++++------------- test/lisp/vc/vc-git-tests.el | 132 ++++++++++++-- 2 files changed, 318 insertions(+), 140 deletions(-) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index e8257c5dbd0..86752bd074d 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -717,6 +717,136 @@ vc-git-dir-status-files :files files :update-function update-function))) +(defcustom vc-git-dir-show-tracking '((when . set) + (how . header)) + "Control how `vc-dir' shows the upstream branch. +The \"upstream\" branch is the one `vc-pull' fetches changes from by +default. In Git terms, when checking out branch B, the upstream branch +is defined by the configuration options branch.B.merge and +branch.B.remote. + +This option is an alist which admits the following symbol keys: + +* `when' controls whether information about the upstream branch will be + shown. The value for this key can be one of the following symbols: + - set (default) Only show the upstream branch if it is set, + as defined by the previously mentioned Git config + options. + - t If a branch is checked out (that is, HEAD is not + detached), always show something: fallback to \"none\" + if the current branch is not tracking anything. + - different Only show the upstream branch if branch.B.merge is + named differently from B. This allows hiding the + header in the common case where branch \"foo\" tracks + \"origin/foo\". + - never Never show the upstream branch. + +* `how' controls the way this information will be shown. The value can + be one of the following symbols: + - header (default) Show the branch in a dedicated header, + \"Tracking\". + - inline Append the branch to the \"Branch\" header, e.g. + Branch: foo (tracking origin/bar)" + :type 'alist + :options + '((when (radio + (const :tag "Never" never) + (const :tag "Always" t) + (const :tag "If current branch has a tracking branch" set) + (const :tag "If current & tracking branches have different names" different))) + (how (radio + (const :tag "\"Tracking\" header" header) + (const :tag "Inline in \"Branch\" header" inline)))) + :version "31.1") + +(defun vc-git-dir--tracking (branch branch-merge branch-remote) + "Return a description of BRANCH's upstream branch. +This description heeds `vc-git-dir-show-tracking'." + (cl-flet ((remote-prefix () + (if (equal branch-remote ".") + nil + (concat branch-remote "/")))) + (pcase-exhaustive (alist-get 'when vc-git-dir-show-tracking 'set) + ('set (and branch-merge + (concat (remote-prefix) branch-merge))) + ('never nil) + ('t (if branch-merge + (concat (remote-prefix) branch-merge) + "none")) + ('different (and branch-merge + (not (equal branch branch-merge)) + (concat (remote-prefix) branch-merge)))))) + +(defun vc-git-dir--branch-headers () + "Return headers for branch-related information." + (let ((branch (vc-git--out-match + '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + tracking remote-url) + (if branch + (let ((branch-merge + (vc-git--out-match + `("config" ,(concat "branch." branch ".merge")) + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (branch-remote + (vc-git--out-match + `("config" ,(concat "branch." branch ".remote")) + "\\([^\n]+\\)" 1))) + ;; Either BRANCH-MERGE and BRANCH-REMOTE are both set, or + ;; neither are. + (cl-assert + (eq (not (not branch-merge)) + (not (not branch-remote))) + nil "Inconsistent branch settings: merge is %s; remote is %s" + branch-merge branch-remote) + (setq tracking (vc-git-dir--tracking + branch branch-merge branch-remote) + remote-url (and branch-remote + (if (equal branch-remote ".") + "none (tracking local branch)" + (vc-git-repository-url + default-directory branch-remote))))) + (setq branch "none (detached HEAD)")) + (cl-flet ((fmt (key value) + (concat + (propertize (format "% -11s: " key) 'face 'vc-dir-header) + (propertize value 'face 'vc-dir-header-value)))) + (when (and tracking + (eq (alist-get 'how vc-git-dir-show-tracking 'header) + 'inline)) + (setq branch (format "%s (tracking %s)" branch tracking) + tracking nil)) + (remove nil (list + (fmt "Branch" branch) + (and tracking (fmt "Tracking" tracking)) + (and remote-url (fmt "Remote" remote-url))))))) + +(defun vc-git-dir--in-progress-headers () + "Return headers for Git commands in progress in this worktree." + (let ((gitdir (vc-git--git-path)) + cmds) + ;; See contrib/completion/git-prompt.sh in git.git. + (when (or (file-directory-p + (expand-file-name "rebase-merge" gitdir)) + (file-exists-p + (expand-file-name "rebase-apply/rebasing" gitdir))) + (push 'rebase cmds)) + (when (file-exists-p + (expand-file-name "rebase-apply/applying" gitdir)) + (push 'am cmds)) + (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir)) + (push 'merge cmds)) + (when (file-exists-p (expand-file-name "BISECT_START" gitdir)) + (push 'bisect cmds)) + (cl-flet ((fmt (cmd name) + (when (memq cmd cmds) + ;; For now just a heading, key bindings can be added + ;; later for various bisect actions. + (propertize (format "% -11s: in progress" name) + 'face 'vc-dir-status-warning)))) + (remove nil (list (fmt 'bisect "Bisect") + (fmt 'rebase "Rebase")))))) + (defvar-keymap vc-git-stash-shared-map "S" #'vc-git-stash-snapshot "C" #'vc-git-stash) @@ -797,130 +927,75 @@ vc-git-stash-menu-map :help "Show the contents of the current stash")) map)) -(defun vc-git--cmds-in-progress () - "Return a list of Git commands in progress in this worktree." - (let ((gitdir (vc-git--git-path)) - cmds) - ;; See contrib/completion/git-prompt.sh in git.git. - (when (or (file-directory-p - (expand-file-name "rebase-merge" gitdir)) - (file-exists-p - (expand-file-name "rebase-apply/rebasing" gitdir))) - (push 'rebase cmds)) - (when (file-exists-p - (expand-file-name "rebase-apply/applying" gitdir)) - (push 'am cmds)) - (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir)) - (push 'merge cmds)) - (when (file-exists-p (expand-file-name "BISECT_START" gitdir)) - (push 'bisect cmds)) - cmds)) +(defun vc-git-dir--stash-headers () + "Return headers describing the current stashes." + (list + (concat + (propertize "Stash : " 'face 'vc-dir-header) + (if-let ((stash-list (vc-git-stash-list))) + (let* ((len (length stash-list)) + (limit + (if (integerp vc-git-show-stash) + (min vc-git-show-stash len) + len)) + (shown-stashes (cl-subseq stash-list 0 limit)) + (hidden-stashes (cl-subseq stash-list limit)) + (all-hideable (or (eq vc-git-show-stash t) + (<= len vc-git-show-stash)))) + (concat + ;; Button to toggle visibility. + (if all-hideable + (vc-git-make-stash-button nil limit limit) + (vc-git-make-stash-button t vc-git-show-stash len)) + ;; Stash list. + (when shown-stashes + (concat + (propertize "\n" + 'vc-git-hideable all-hideable) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'vc-git-hideable all-hideable + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + shown-stashes + (propertize "\n" + 'vc-git-hideable all-hideable)))) + (when hidden-stashes + (concat + (propertize "\n" + 'invisible t + 'vc-git-hideable t) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'invisible t + 'vc-git-hideable t + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + hidden-stashes + (propertize "\n" + 'invisible t + 'vc-git-hideable t)))))) + (propertize "Nothing stashed" + 'help-echo vc-git-stash-shared-help + 'keymap vc-git-stash-shared-map + 'face 'vc-dir-header-value))))) (defun vc-git-dir-extra-headers (dir) - (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) - (stash-list (vc-git-stash-list)) - (default-directory dir) - (in-progress (vc-git--cmds-in-progress)) - - branch remote-url stash-button stash-string tracking-branch) - (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) - (progn - (setq branch (match-string 2 str)) - (let ((remote (vc-git--out-str - "config" (concat "branch." branch ".remote"))) - (merge (vc-git--out-str - "config" (concat "branch." branch ".merge")))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) - (setq tracking-branch (match-string 2 merge))) - (pcase remote - ("." - (setq remote-url "none (tracking local branch)")) - ((pred (not string-empty-p)) - (setq - remote-url (vc-git-repository-url dir remote) - tracking-branch (concat remote "/" tracking-branch)))))) - (setq branch "none (detached HEAD)")) - (when stash-list - (let* ((len (length stash-list)) - (limit - (if (integerp vc-git-show-stash) - (min vc-git-show-stash len) - len)) - (shown-stashes (cl-subseq stash-list 0 limit)) - (hidden-stashes (cl-subseq stash-list limit)) - (all-hideable (or (eq vc-git-show-stash t) - (<= len vc-git-show-stash)))) - (setq stash-button (if all-hideable - (vc-git-make-stash-button nil limit limit) - (vc-git-make-stash-button t vc-git-show-stash len)) - stash-string - (concat - (when shown-stashes - (concat - (propertize "\n" - 'vc-git-hideable all-hideable) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'vc-git-hideable all-hideable - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - shown-stashes - (propertize "\n" - 'vc-git-hideable all-hideable)))) - (when hidden-stashes - (concat - (propertize "\n" - 'invisible t - 'vc-git-hideable t) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'invisible t - 'vc-git-hideable t - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - hidden-stashes - (propertize "\n" - 'invisible t - 'vc-git-hideable t)))))))) - (concat - (propertize "Branch : " 'face 'vc-dir-header) - (propertize branch - 'face 'vc-dir-header-value) - (when tracking-branch - (concat - "\n" - (propertize "Tracking : " 'face 'vc-dir-header) - (propertize tracking-branch 'face 'vc-dir-header-value))) - (when remote-url - (concat - "\n" - (propertize "Remote : " 'face 'vc-dir-header) - (propertize remote-url - 'face 'vc-dir-header-value))) - ;; For now just a heading, key bindings can be added later for various bisect actions - (when (memq 'bisect in-progress) - (propertize "\nBisect : in progress" 'face 'vc-dir-status-warning)) - (when (memq 'rebase in-progress) - (propertize "\nRebase : in progress" 'face 'vc-dir-status-warning)) - (if stash-list - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - stash-button - stash-string) - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - (propertize "Nothing stashed" - 'help-echo vc-git-stash-shared-help - 'keymap vc-git-stash-shared-map - 'face 'vc-dir-header-value)))))) + (let ((default-directory dir)) + (string-join + (append + ;; Each helper returns a list of headers. Each header must be a + ;; propertized string with no final newline. + (vc-git-dir--branch-headers) + (vc-git-dir--in-progress-headers) + (vc-git-dir--stash-headers)) + "\n"))) (defun vc-git-branches () "Return the existing branches, as a list of strings. @@ -2246,6 +2321,13 @@ vc-git--out-str (with-current-buffer standard-output (apply #'vc-git--out-ok command args)))) +(defun vc-git--out-match (args regexp group) + "Run `git ARGS...' and return match for group number GROUP of REGEXP. +Return nil if the output does not match. The exit status is ignored." + (let ((out (apply #'vc-git--out-str args))) + (when (string-match regexp out) + (match-string group out)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index f15a0f52e8c..4ece262564e 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -26,6 +26,7 @@ (require 'ert-x) (require 'vc) +(require 'vc-dir) (require 'vc-git) (ert-deftest vc-git-test-program-version-general () @@ -108,24 +109,119 @@ vc-git-test--run (apply 'vc-git-command t 0 nil args) (buffer-string))) -(ert-deftest vc-git-test-dir-track-local-branch () - "Test that `vc-dir' works when tracking local branches. Bug#68183." +(defun vc-git-test--start-branch () + "Get a branch started in a freshly initialized repository. + +This returns the name of the current branch, so that tests can remain +agnostic of init.defaultbranch." + (write-region "hello" nil "README") + (vc-git-test--run "add" "README") + (vc-git-test--run "commit" "-mFirst") + (string-trim (vc-git-test--run "branch" "--show-current"))) + +(defun vc-git-test--dir-headers (headers &optional show-tracking) + "Return an alist of header values for the current `vc-dir' buffer. + +HEADERS should be a list of (NAME ...) strings. This function will +return a list of (NAME . VALUE) pairs, where VALUE is nil if the header +is absent. + +SHOW-TRACKING is a temporary value to bind `vc-git-dir-show-tracking' +to. If omitted, the default value will be kept." + (let ((vc-git-dir-show-tracking (or show-tracking + vc-git-dir-show-tracking))) + ;; FIXME: to reproduce interactive sessions faithfully, we would need + ;; to wait for the dir-status-files process to terminate; have not + ;; found a reliable way to do this. As a workaround, kill pending + ;; processes and revert the `vc-dir' buffer. + (vc-dir-kill-dir-status-process) + (revert-buffer) + (mapcar + (lambda (header) + (let* ((pattern + (rx bol + (literal header) (* space) ": " (group (+ nonl)) + eol)) + (value (and (goto-char (point-min)) + (re-search-forward pattern nil t) + (match-string 1)))) + (cons header value))) + headers))) + +(ert-deftest vc-git-test-dir-branch-headers () + "Check that `vc-dir' shows expected branch-related headers." (skip-unless (executable-find vc-git-program)) - (vc-git-test--with-repo repo - ;; Create an initial commit to get a branch started. - (write-region "hello" nil "README") - (vc-git-test--run "add" "README") - (vc-git-test--run "commit" "-mFirst") - ;; Get current branch name lazily, to remain agnostic of - ;; init.defaultbranch. - (let ((upstream-branch - (string-trim (vc-git-test--run "branch" "--show-current")))) - (vc-git-test--run "checkout" "--track" "-b" "hack" upstream-branch) - (vc-dir default-directory) - (pcase-dolist (`(,header ,value) - `(("Branch" "hack") - ("Tracking" ,upstream-branch))) - (goto-char (point-min)) - (re-search-forward (format "^%s *: %s$" header value)))))) + ;; Create a repository that will serve as the "remote". + (vc-git-test--with-repo origin-repo + (let ((main-branch (vc-git-test--start-branch))) + ;; 'git clone' this repository and test things in this clone. + (ert-with-temp-directory clone-repo + (vc-git-test--run "clone" origin-repo clone-repo) + (vc-dir clone-repo) + + ;; Post-clone: on MAIN-BRANCH, tracking origin/MAIN-BRANCH. + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . ,main-branch) + ("Tracking" . ,(concat "origin/" main-branch)) + ("Remote" . ,origin-repo)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((how . inline))) + `(("Branch" . ,(format "%s (tracking origin/%s)" main-branch main-branch)) + ("Tracking" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . different))) + `(("Branch" . ,main-branch) + ("Tracking" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . never))) + `(("Branch" . ,main-branch) + ("Tracking" . nil)))) + + ;; Checkout a new branch: no tracking information. + (vc-git-test--run "checkout" "-b" "feature/foo" main-branch) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + '(("Branch" . "feature/foo") + ("Tracking" . nil) + ("Remote" . nil)))) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking") '((when . t))) + '(("Branch" . "feature/foo") + ("Tracking" . "none")))) + + ;; Push with '--set-upstream origin': tracking information + ;; should be updated. + (vc-git-test--run "push" "--set-upstream" "origin" "feature/foo") + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . "feature/foo") + ("Tracking" . "origin/feature/foo") + ("Remote" . ,origin-repo)))) + + ;; Checkout a new branch tracking the _local_ main branch. + ;; Bug#68183. + (vc-git-test--run "checkout" "-b" "feature/bar" "--track" main-branch) + (should + (equal + (vc-git-test--dir-headers + '("Branch" "Tracking" "Remote")) + `(("Branch" . "feature/bar") + ("Tracking" . ,main-branch) + ("Remote" . "none (tracking local branch)")))))))) ;;; vc-git-tests.el ends here -- 2.39.2 --=-=-=--