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

From: Kévin Le Gouguec <[email-masked]>
Date: Sat, 15 Feb 2025 23:17:45 +0100

Paul Eggert <[email-masked]> writes:

> On 2025-02-15 02:42, Kévin Le Gouguec wrote:
>> waiting for vc-dir-busy*after* invoking vc-dir seems to work fine,
>> which makes complete sense
>
> Makes sense to me too. I didn't look at the patch in detail, but did notice a "TODO" comment.

One of these "finishing touches" I mentioned, yup.

Attaching for your consideration:

1. a patch that fixes the vc-dir synchronization,
2. a patch that ditches vc-dir entirely.

Either fixes the issue, as far as I can validate.  I still have a slight
preference for the second one¹.  FWIW, here the test takes ≈330ms with
patch 1, and ≈68ms with patch 2².

Happy to install whichever.

¹ tl;dr vc-dir is a middleman with no added value for the purposes of
this test.

² Which is only worth consideration if you happen to need run that test
repeatedly to reproduce a weird race condition 🥲

>From e835d68f43f652e5f179a7fc005b224265d86558 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?K=C3=A9vin=20Le=20Gouguec?= <[email-masked]>
Date: Sat, 15 Feb 2025 22:42:33 +0100
Subject: [PATCH] Fix race condition in vc-git-tests.el (bug#76187)

* test/lisp/vc/vc-git-tests.el (vc-git-test--run): Make sure to
log output from failing Git commands.
(vc-git-test--vc-dir): New function to invoke vc-dir, then wait
for background processes to complete before returning.
(vc-git-test--dir-headers): Remove kludge to kill these
background processes, and call the new function.
(vc-git-test-dir-branch-headers): Let the header-parsing
function invoke vc-dir; set default-directory to the "cloned
repo" to simplify bookkeeping.
---
 test/lisp/vc/vc-git-tests.el | 109 ++++++++++++++++++++---------------
 1 file changed, 62 insertions(+), 47 deletions(-)

diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el
index 4b5cb75df01..655b3b54bc0 100644
--- a/test/lisp/vc/vc-git-tests.el
+++ b/test/lisp/vc/vc-git-tests.el
@@ -104,9 +104,14 @@ vc-git-test--with-repo
        ,@body)))
 
 (defun vc-git-test--run (&rest args)
-  "Run git ARGS…, check for non-zero status, and return output."
+  "Run git ARGS…, check for non-zero status, and return output.
+If the exit status is non-zero, log the command output and re-throw."
   (with-temp-buffer
-    (apply 'vc-git-command t 0 nil args)
+    (condition-case err
+        (apply 'vc-git-command t 0 nil args)
+      (t (message "Error running Git: %s" err)
+         (message "(buffer-string:\n%s\n)" (buffer-string))
+         (signal (car err) (cdr err))))
     (buffer-string)))
 
 (defun vc-git-test--start-branch ()
@@ -119,18 +124,28 @@ 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)
-  "Return an alist of header values for the current `vc-dir' buffer.
+(defun vc-git-test--vc-dir ()
+  "Invoke `vc-dir' in the current repository.
+Wait until all asynchronous processes are complete before returning:
+some of them hold index.lock files that may trip the next Git commands."
+  (vc-dir default-directory)
+  ;; Wait at most 1s, checking every 50ms.
+  (let ((max-pause 1.0)
+        (step 0.05)
+        (paused 0.0))
+    (while (vc-dir-busy)
+      (when (> (cl-incf paused step) max-pause)
+        (error "Timed out waiting for vc-dir-busy"))
+      (sleep-for step))
+    (when (> paused 0)
+      (message "Paused %.2f s waiting for vc-dir-busy" paused))))
 
+(defun vc-git-test--dir-headers (headers)
+  "Invoke `vc-dir' and return an alist of header values.
 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)
+  (vc-git-test--vc-dir)
   (mapcar
    (lambda (header)
      (let* ((pattern
@@ -152,42 +167,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

>From 300adf2f1008aad71ec18c7c319888b0de14800e 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--run): Make sure to
log output from failing Git commands.
(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 | 122 ++++++++++++++++++-----------------
 1 file changed, 63 insertions(+), 59 deletions(-)

diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el
index 4b5cb75df01..3cb12d5f86e 100644
--- a/test/lisp/vc/vc-git-tests.el
+++ b/test/lisp/vc/vc-git-tests.el
@@ -104,9 +104,14 @@ vc-git-test--with-repo
        ,@body)))
 
 (defun vc-git-test--run (&rest args)
-  "Run git ARGS…, check for non-zero status, and return output."
+  "Run git ARGS…, check for non-zero status, and return output.
+If the exit status is non-zero, log the command output and re-throw."
   (with-temp-buffer
-    (apply 'vc-git-command t 0 nil args)
+    (condition-case err
+        (apply 'vc-git-command t 0 nil args)
+      (t (message "Error running Git: %s" err)
+         (message "(buffer-string:\n%s\n)" (buffer-string))
+         (signal (car err) (cdr err))))
     (buffer-string)))
 
 (defun vc-git-test--start-branch ()
@@ -120,31 +125,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 +156,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