From: "Kévin Le Gouguec" <kevin.legouguec@gmail.com>
To: 68183@debbugs.gnu.org
Cc: Dmitry Gutov <dmitry@gutov.dev>, Eli Zaretskii <eliz@gnu.org>,
Tom Tromey <tom@tromey.com>,
Sean Whitton <spwhitton@spwhitton.name>,
Juri Linkov <juri@linkov.net>
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 [thread overview]
Message-ID: <87h6bwqujo.fsf@gmail.com> (raw)
In-Reply-To: <06a946b4-b06a-4e10-93d5-b6d6b8bd9fcf@gutov.dev> (Dmitry Gutov's message of "Mon, 18 Mar 2024 17:26:11 +0200")
[-- Attachment #1: Type: text/plain, Size: 1204 bytes --]
Heya,
Have spent cycles on this on-and-off these past few months; finally have
something worth discussing, I think 🤞
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.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Test-more-vc-dir-scenarios-with-Git-bug-68183.patch --]
[-- Type: text/x-diff, Size: 5429 bytes --]
From 1573015fba16f8b453e87e92e982fc633bca40d2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Split-vc-git-dir-extra-headers-into-more-manageable-.patch --]
[-- Type: text/x-diff, Size: 13563 bytes --]
From f4caa79c492116c3b9c6a6df7972222ee977f13c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-Let-users-choose-when-and-how-to-display-Git-trackin.patch --]
[-- Type: text/x-diff, Size: 11372 bytes --]
From f21546f5cae71f00a73298315f00f7693cb21d5f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: squashed.patch --]
[-- Type: text/x-diff, Size: 23520 bytes --]
From 2de70ea79a5d8eb98e0dcd4ef0598a8e033b6526 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <kevin.legouguec@gmail.com>
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
next prev parent reply other threads:[~2024-08-07 14:25 UTC|newest]
Thread overview: 29+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-12-31 18:59 bug#68183: 28.3; vc-dir fails when I have a certain branch checked out Tom Tromey
2023-12-31 19:34 ` Eli Zaretskii
2023-12-31 20:14 ` Tom Tromey
2024-01-03 9:46 ` Kévin Le Gouguec
2024-02-12 8:08 ` Kévin Le Gouguec
2024-02-14 19:56 ` Kévin Le Gouguec
2024-03-13 20:03 ` Kévin Le Gouguec
2024-03-15 2:57 ` Dmitry Gutov
2024-03-16 17:56 ` Kévin Le Gouguec
2024-03-17 1:06 ` Dmitry Gutov
2024-03-17 18:09 ` Kévin Le Gouguec
2024-03-18 15:26 ` Dmitry Gutov
2024-08-07 14:25 ` Kévin Le Gouguec [this message]
2024-08-08 0:32 ` Sean Whitton
2024-08-08 7:07 ` Kévin Le Gouguec
2024-08-08 12:02 ` Sean Whitton
2024-08-13 1:32 ` Dmitry Gutov
2024-08-20 6:15 ` Kévin Le Gouguec
2024-08-20 12:15 ` Eli Zaretskii
2024-08-22 7:15 ` Kévin Le Gouguec
2024-08-22 12:46 ` Eli Zaretskii
2024-08-29 15:36 ` Kévin Le Gouguec
2024-08-29 15:46 ` Eli Zaretskii
2024-08-29 16:41 ` Kévin Le Gouguec
2024-08-21 0:42 ` Dmitry Gutov
2024-08-21 1:40 ` Sean Whitton
2024-08-21 7:05 ` Kévin Le Gouguec
2024-08-21 7:59 ` Sean Whitton
2024-08-21 12:29 ` Dmitry Gutov
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87h6bwqujo.fsf@gmail.com \
--to=kevin.legouguec@gmail.com \
--cc=68183@debbugs.gnu.org \
--cc=dmitry@gutov.dev \
--cc=eliz@gnu.org \
--cc=juri@linkov.net \
--cc=spwhitton@spwhitton.name \
--cc=tom@tromey.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.