Subject: bug#76187: vc-git-test-dir-branch-headers failure on Fedora

From: Kévin Le Gouguec <[email-masked]>
Date: Thu, 13 Feb 2025 23:58:21 +0100

Kévin Le Gouguec <[email-masked]> writes:

> FWIW, with that last patch I posted, the test has been passing on repeat
> for 3h (47k iterations) and counting.  Maybe we have a winner?

4h10min, 66k iterations, no failures.  Stopping the count because this
brain needs zzz's.

> Let me know if it looks acceptable, I'll add commentary & a changelog
> entry.

Done; attached for your consideration.

>From 6c38e17745b422cf65110d4c7ee6f2cd065d5ece Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <[email-masked]>
Date: Thu, 13 Feb 2025 23:52:06 +0100
Subject: [PATCH] Test vc-git-dir-extra-headers directly (bug#76187)

* test/lisp/vc/vc-git-tests.el (vc-git-test--dir-headers): Stop
bothering with vc-dir internals and just invoke the
branch-munging and header-formatting code we mean to test.
(vc-git-test-dir-branch-headers): Stop invoking vc-dir; just set
default-directory to be able to pass it to the backend function.
---
 test/lisp/vc/vc-git-tests.el | 113 +++++++++++++++++------------------
 1 file changed, 56 insertions(+), 57 deletions(-)

diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el
index 4b5cb75df01..98d1fc4ef44 100644
--- a/test/lisp/vc/vc-git-tests.el
+++ b/test/lisp/vc/vc-git-tests.el
@@ -120,31 +120,30 @@ vc-git-test--start-branch
   (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.
-
+  "Return an alist of header values as they would appear in `vc-dir'.
 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))
+  (with-temp-buffer
+    ;; We invoke the backend's dir-extra-headers function directly
+    ;; because (a) that covers the logic we mean to test (b) going
+    ;; through vc-dir "like a user would" has proven fraught; see
+    ;; bug#76187 for hard-to-reproduce and hard-to-diagnose errors.
+    (insert (vc-git-dir-extra-headers default-directory) "\n")
+    (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."
+  "Check that dir-extra-headers recognizes various branch arrangements."
   (skip-unless (executable-find vc-git-program))
   ;; Create a repository that will serve as the "remote".
   (vc-git-test--with-repo origin-repo
@@ -152,42 +151,42 @@ vc-git-test-dir-branch-headers
       ;; '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)"))))))))
+        (let ((default-directory 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.48.1