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