bug#54359: 29.0.50; [PATCH] Undo breaking change to project interface

[dick]

>From 793d1311b28701931a9343e5196adce82da7833d Mon Sep 17 00:00:00 2001
From: dickmao <dick.r.chiang@gmail.com>
Date: Sat, 12 Mar 2022 16:39:28 -0500
Subject: [PATCH] Avoid breaking the world's `project-current` calls

mitigate 86969f9.

* lisp/progmodes/project.el (cl-generic, cl-lib):
Rectify the requires
(project-try-vc): Cache the backend outside project "struct."
(project-root): Cache the backend outside project "struct."
(project-files): Cache the backend outside project "struct."
(project-ignores): Cache the backend outside project "struct."
* test/lisp/progmodes/project-tests.el
(project-sparing-backend-discovery): Test it.
---
 lisp/progmodes/project.el            | 67 ++++++++++++++--------------
 test/lisp/progmodes/project-tests.el | 15 +++++++
 2 files changed, 49 insertions(+), 33 deletions(-)

diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index daaf86f3277..153e31552bc 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -156,7 +156,7 @@
 
 ;;; Code:
 
-(require 'cl-generic)
+(require 'cl-lib)
 (require 'seq)
 (eval-when-compile (require 'subr-x))
 
@@ -418,33 +418,32 @@ project-vc-external-roots-function
 backend implementation of `project-external-roots'.")
 
 (defun project-try-vc (dir)
-  (or (vc-file-getprop dir 'project-vc)
-      (let* ((backend (ignore-errors (vc-responsible-backend dir)))
-             (root
-              (pcase backend
-                ('Git
-                 ;; Don't stop at submodule boundary.
-                 (or (vc-file-getprop dir 'project-git-root)
-                     (let ((root (vc-call-backend backend 'root dir)))
-                       (vc-file-setprop
-                        dir 'project-git-root
-                        (if (and
-                             ;; FIXME: Invalidate the cache when the value
-                             ;; of this variable changes.
-                             (project--vc-merge-submodules-p root)
-                             (project--submodule-p root))
-                            (let* ((parent (file-name-directory
-                                            (directory-file-name root))))
-                              (vc-call-backend backend 'root parent))
-                          root)))))
-                ('nil nil)
-                (_ (ignore-errors (vc-call-backend backend 'root dir)))))
-             project)
-        (when root
-          (setq project (list 'vc backend root))
-          ;; FIXME: Cache for a shorter time.
-          (vc-file-setprop dir 'project-vc project)
-          project))))
+  (unless (vc-file-getprop dir 'project-vc)
+    (let* ((backend (ignore-errors (vc-responsible-backend dir)))
+           (root
+            (pcase backend
+              ('Git
+               ;; Don't stop at submodule boundary.
+               (or (vc-file-getprop dir 'project-git-root)
+                   (let ((root (vc-call-backend backend 'root dir)))
+                     (vc-file-setprop
+                      dir 'project-git-root
+                      (if (and
+                           ;; FIXME: Invalidate the cache when the value
+                           ;; of this variable changes.
+                           (project--vc-merge-submodules-p root)
+                           (project--submodule-p root))
+                          (let* ((parent (file-name-directory
+                                          (directory-file-name root))))
+                            (vc-call-backend backend 'root parent))
+                        root)))))
+              ('nil nil)
+              (_ (ignore-errors (vc-call-backend backend 'root dir))))))
+      (when root
+        ;; FIXME: Cache for a shorter time.
+        (vc-file-setprop dir 'project-vc (cons 'vc root))
+        (vc-file-setprop dir 'vc-backend backend))))
+  (vc-file-getprop dir 'project-vc))
 
 (defun project--submodule-p (root)
   ;; XXX: We only support Git submodules for now.
@@ -470,7 +469,7 @@ project--submodule-p
      (t nil))))
 
 (cl-defmethod project-root ((project (head vc)))
-  (nth 2 project))
+  (cdr project))
 
 (cl-defmethod project-external-roots ((project (head vc)))
   (project-subtract-directories
@@ -485,8 +484,9 @@ project-files
    (lambda (dir)
      (let ((ignores (project--value-in-dir 'project-vc-ignores dir))
            backend)
-       (if (and (file-equal-p dir (nth 2 project))
-                (setq backend (cadr project))
+       (if (and (file-equal-p dir (cdr project))
+                (setq backend (or (vc-file-getprop dir 'vc-backend)
+                                  (vc-responsible-backend dir)))
                 (cond
                  ((eq backend 'Hg))
                  ((and (eq backend 'Git)
@@ -598,11 +598,12 @@ project--git-submodules
     (file-missing nil)))
 
 (cl-defmethod project-ignores ((project (head vc)) dir)
-  (let* ((root (nth 2 project))
+  (let* ((root (cdr project))
          backend)
     (append
      (when (file-equal-p dir root)
-       (setq backend (cadr project))
+       (setq backend (or (vc-file-getprop dir 'vc-backend)
+                         (vc-responsible-backend root)))
        (delq
         nil
         (mapcar
diff --git a/test/lisp/progmodes/project-tests.el 
b/test/lisp/progmodes/project-tests.el
index d4b6bca7e8f..c001106e9f0 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -32,6 +32,7 @@
 (require 'ert-x) ; ert-with-temp-directory
 (require 'grep)
 (require 'xref)
+(require 'vc)
 
 (ert-deftest project/quoted-directory ()
   "Check that `project-files' and `project-find-regexp' deal with
@@ -110,4 +111,18 @@ project-ignores-bug-50240
                      (list
                       (expand-file-name "some-file" dir)))))))
 
+(ert-deftest project-sparing-backend-discovery ()
+  "Cache results of `vc-responsible-backend`."
+  (skip-unless (eq 'Git (ignore-errors
+                          (vc-responsible-backend default-directory))))
+  (let* ((default-directory (vc-call-backend 'Git 'root default-directory))
+         (project (project-current)))
+    (should (vc-file-getprop default-directory 'project-vc))
+    (should (eq 'Git (vc-file-getprop default-directory 'vc-backend)))
+    (cl-letf (((symbol-function 'vc-responsible-backend)
+               (lambda (&rest _args) (should nil))))
+      (project-files project)
+      (vc-file-clearprops default-directory)
+      (should-error (project-files project)))))
+
 ;;; project-tests.el ends here
-- 
2.26.2



In Commercial Emacs 0.3.1snapshot 455dcd3 in bad_merges (upstream 29.0.50, 
x86_64-pc-linux-gnu) built on dick
Repository revision: 455dcd3b1e5c5f8c23f44679096d1abb10657e76
Repository branch: bad_merges
Windowing system distributor 'The X.Org Foundation', version 11.0.12013000
System Description: Ubuntu 20.04.3 LTS

Configured using:
 'configure --prefix=/home/dick/.local --with-tree-sitter
 --enable-dumping-overwrite 'CFLAGS=-g3 -O2
 -I/home/dick/.local/include/' LDFLAGS=-L/home/dick/.local/lib'

Configured features:
CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG JSON
TREE_SITTER LCMS2 LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG
RSVG SECCOMP SOUND THREADS TIFF TOOLKIT_SCROLL_BARS WEBP X11 XDBE XIM
XPM GTK3 ZLIB

Important settings:
  value of $LANG: en_US.UTF-8
  locale-coding-system: utf-8-unix

Major mode: Lisp Interaction

Minor modes in effect:
  async-bytecomp-package-mode: t
  global-git-commit-mode: t
  magit-auto-revert-mode: t
  shell-dirtrack-mode: t
  paredit-mode: t
  global-auto-revert-mode: t
  projectile-mode: t
  flx-ido-mode: t
  override-global-mode: t
  winner-mode: t
  tooltip-mode: t
  eldoc-mode: t
  show-paren-mode: t
  mouse-wheel-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  blink-cursor-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  column-number-mode: t
  line-number-mode: t
  transient-mark-mode: t

Load-path shadows:
/home/dick/gomacro-mode/gomacro-mode hides 
/home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode
/home/dick/.emacs.d/elpa/magit-3.3.0snapshot/magit-section-pkg hides 
/home/dick/.emacs.d/elpa/magit-section-3.3.0snapshot/magit-section-pkg
/home/dick/org-gcal.el/org-gcal hides 
/home/dick/.emacs.d/elpa/org-gcal-0.3/org-gcal
/home/dick/.emacs.d/elpa/chess-2.0.5/_pkg hides 
/home/dick/.local/share/emacs/site-lisp/_pkg
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-pos hides 
/home/dick/.local/share/emacs/site-lisp/chess-pos
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-module hides 
/home/dick/.local/share/emacs/site-lisp/chess-module
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ucb hides 
/home/dick/.local/share/emacs/site-lisp/chess-ucb
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-scid hides 
/home/dick/.local/share/emacs/site-lisp/chess-scid
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-puzzle hides 
/home/dick/.local/share/emacs/site-lisp/chess-puzzle
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-irc hides 
/home/dick/.local/share/emacs/site-lisp/chess-irc
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-network hides 
/home/dick/.local/share/emacs/site-lisp/chess-network
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-autosave hides 
/home/dick/.local/share/emacs/site-lisp/chess-autosave
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-engine hides 
/home/dick/.local/share/emacs/site-lisp/chess-engine
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-tutorial hides 
/home/dick/.local/share/emacs/site-lisp/chess-tutorial
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-german hides 
/home/dick/.local/share/emacs/site-lisp/chess-german
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-file hides 
/home/dick/.local/share/emacs/site-lisp/chess-file
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-random hides 
/home/dick/.local/share/emacs/site-lisp/chess-random
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-stockfish hides 
/home/dick/.local/share/emacs/site-lisp/chess-stockfish
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-pgn hides 
/home/dick/.local/share/emacs/site-lisp/chess-pgn
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-kibitz hides 
/home/dick/.local/share/emacs/site-lisp/chess-kibitz
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-eco hides 
/home/dick/.local/share/emacs/site-lisp/chess-eco
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-display hides 
/home/dick/.local/share/emacs/site-lisp/chess-display
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-var hides 
/home/dick/.local/share/emacs/site-lisp/chess-var
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-test hides 
/home/dick/.local/share/emacs/site-lisp/chess-test
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ply hides 
/home/dick/.local/share/emacs/site-lisp/chess-ply
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-message hides 
/home/dick/.local/share/emacs/site-lisp/chess-message
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ics1 hides 
/home/dick/.local/share/emacs/site-lisp/chess-ics1
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-phalanx hides 
/home/dick/.local/share/emacs/site-lisp/chess-phalanx
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-game hides 
/home/dick/.local/share/emacs/site-lisp/chess-game
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-log hides 
/home/dick/.local/share/emacs/site-lisp/chess-log
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-plain hides 
/home/dick/.local/share/emacs/site-lisp/chess-plain
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-perft hides 
/home/dick/.local/share/emacs/site-lisp/chess-perft
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-glaurung hides 
/home/dick/.local/share/emacs/site-lisp/chess-glaurung
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ai hides 
/home/dick/.local/share/emacs/site-lisp/chess-ai
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-fruit hides 
/home/dick/.local/share/emacs/site-lisp/chess-fruit
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-uci hides 
/home/dick/.local/share/emacs/site-lisp/chess-uci
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-epd hides 
/home/dick/.local/share/emacs/site-lisp/chess-epd
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-database hides 
/home/dick/.local/share/emacs/site-lisp/chess-database
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-link hides 
/home/dick/.local/share/emacs/site-lisp/chess-link
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-transport hides 
/home/dick/.local/share/emacs/site-lisp/chess-transport
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-none hides 
/home/dick/.local/share/emacs/site-lisp/chess-none
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-polyglot hides 
/home/dick/.local/share/emacs/site-lisp/chess-polyglot
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-crafty hides 
/home/dick/.local/share/emacs/site-lisp/chess-crafty
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-chat hides 
/home/dick/.local/share/emacs/site-lisp/chess-chat
/home/dick/.emacs.d/elpa/chess-2.0.5/chess hides 
/home/dick/.local/share/emacs/site-lisp/chess
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-images hides 
/home/dick/.local/share/emacs/site-lisp/chess-images
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-gnuchess hides 
/home/dick/.local/share/emacs/site-lisp/chess-gnuchess
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-fen hides 
/home/dick/.local/share/emacs/site-lisp/chess-fen
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ics hides 
/home/dick/.local/share/emacs/site-lisp/chess-ics
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-ics2 hides 
/home/dick/.local/share/emacs/site-lisp/chess-ics2
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-common hides 
/home/dick/.local/share/emacs/site-lisp/chess-common
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-input hides 
/home/dick/.local/share/emacs/site-lisp/chess-input
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-announce hides 
/home/dick/.local/share/emacs/site-lisp/chess-announce
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-clock hides 
/home/dick/.local/share/emacs/site-lisp/chess-clock
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-sound hides 
/home/dick/.local/share/emacs/site-lisp/chess-sound
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-sjeng hides 
/home/dick/.local/share/emacs/site-lisp/chess-sjeng
/home/dick/.emacs.d/elpa/chess-2.0.5/chess-algebraic hides 
/home/dick/.local/share/emacs/site-lisp/chess-algebraic
/home/dick/.emacs.d/elpa/transient-0.3.7snapshot/transient hides 
/home/dick/.local/share/emacs/0.3.1/lisp/transient

Features:
(shadow sort footnote mail-extr gnus-msg emacsbug sendmail org-element
avl-tree ol-eww eww xdg url-queue ol-rmail ol-mhe ol-irc ol-info ol-gnus
nnselect gnus-art mm-uu mml2015 mm-view mml-smime smime dig gnus-sum
gnus-group mm-url gnus-undo gnus-start gnus-dbus dbus gnus-cloud nnimap
nnmail mail-source utf7 netrc nnoo gnus-spec gnus-int gnus-range
gnus-win ol-docview doc-view jka-compr image-mode exif ol-bibtex ol-bbdb
ol-w3m ol-doi org-link-doi org-tempo tempo org org-macro org-footnote
org-pcomplete org-list org-faces org-entities org-version ob-R
ob-emacs-lisp ob-ein ein-cell ein-shared-output ein-output-area shr
pixel-fill kinsoku url-file url-dired svg dom xml ein-kernel ein-ipdb
ein-query ein-events ein-websocket websocket bindat ein-node ewoc
ein-log ein-classes ein-core request anaphora ein ein-utils deferred
cc-mode cc-fonts cc-guess cc-menus cc-cmds cc-styles cc-align cc-engine
cc-vars cc-defs ob ob-tangle org-src ob-ref ob-lob ob-table ob-exp
ob-comint ob-core ob-eval org-table oc-basic bibtex ol org-keys oc
org-compat org-macs org-loaddefs find-func cal-menu calendar
cal-loaddefs blamer a tramp tramp-loaddefs trampver tramp-integration
cus-start files-x tramp-compat parse-time iso8601 ls-lisp magit-extras
benchmark vc-git vc-dispatcher bug-reference mule-util face-remap
magit-patch-changelog magit-patch magit-submodule magit-obsolete
magit-popup async-bytecomp async magit-blame magit-stash magit-reflog
magit-bisect magit-push magit-pull magit-fetch magit-clone magit-remote
magit-commit magit-sequence magit-notes magit-worktree magit-tag
magit-merge magit-branch magit-reset magit-files magit-refs magit-status
magit magit-repos magit-apply magit-wip magit-log which-func imenu
magit-diff smerge-mode diff diff-mode git-commit log-edit message
yank-media rmc puny dired-x dired dired-loaddefs rfc822 mml mml-sec epa
epg rfc6068 epg-config mm-decode mm-bodies mm-encode mail-parse rfc2231
rfc2047 rfc2045 ietf-drums mailabbrev gmm-utils mailheader pcvs-util
add-log magit-core magit-autorevert magit-margin magit-transient
magit-process with-editor shell pcomplete server magit-mode transient
format-spec magit-git magit-base magit-section crm dash paredit-ext
paredit autorevert filenotify subed subed-vtt subed-srt subed-common
subed-mpv subed-debug subed-config inf-ruby ruby-mode smie company pcase
haskell-interactive-mode haskell-presentation-mode haskell-process
haskell-session haskell-compile haskell-mode haskell-cabal haskell-utils
haskell-font-lock haskell-indentation haskell-string
haskell-sort-imports haskell-lexeme rx haskell-align-imports
haskell-complete-module haskell-ghc-support noutline outline
flymake-proc flymake warnings etags fileloop generator xref project
dabbrev haskell-customize hydra lv use-package-ensure solarized-theme
solarized-definitions projectile lisp-mnt ibuf-ext ibuffer
ibuffer-loaddefs thingatpt grep compile comint ansi-color gnus nnheader
range mail-utils mm-util mail-prsvr gnus-util text-property-search
time-date flx-ido flx google-translate-default-ui
google-translate-core-ui facemenu color ido google-translate-core
google-translate-tk google-translate-backend use-package-bind-key
bind-key auto-complete easy-mmode advice edmacro kmacro popup cus-edit
pp cus-load wid-edit emms-player-mplayer emms-player-simple emms
emms-compat cl-extra help-mode use-package-core derived winner ring
json-reformat-autoloads json-snatcher-autoloads finder-inf
sml-mode-autoloads tornado-template-mode-autoloads info package
browse-url url url-proxy url-privacy url-expand url-methods url-history
url-cookie url-domsuf url-util mailcap url-handlers url-parse
auth-source cl-seq eieio eieio-core cl-macs eieio-loaddefs
password-cache json map url-vars seq gv subr-x byte-opt bytecomp
byte-compile cconv cldefs cl-loaddefs cl-lib iso-transl tooltip eldoc
paren electric uniquify ediff-hook vc-hooks lisp-float-type elisp-mode
mwheel term/x-win x-win term/common-win x-dnd tool-bar dnd fontset image
regexp-opt fringe tree-sitter tabulated-list replace newcomment
text-mode lisp-mode prog-mode register page tab-bar menu-bar rfn-eshadow
isearch easymenu timer select scroll-bar mouse jit-lock font-lock syntax
font-core term/tty-colors frame minibuffer cl-generic cham georgian
utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean
japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european
ethiopic indian cyrillic chinese composite emoji-zwj charscript charprop
case-table epa-hook jka-cmpr-hook help simple abbrev obarray
cl-preloaded nadvice button loaddefs faces cus-face macroexp files
window text-properties overlay sha1 md5 base64 format env code-pages
mule custom widget keymap hashtable-print-readable backquote threads
dbusbind inotify lcms2 dynamic-setting system-font-setting
font-render-setting cairo move-toolbar gtk x-toolkit x multi-tty
make-network-process emacs)

Memory information:
((conses 16 581094 35186)
 (symbols 48 41162 2)
 (strings 32 169212 6930)
 (string-bytes 1 5335567)
 (vectors 16 68284)
 (vector-slots 8 840886 33851)
 (floats 8 509 1281)
 (intervals 56 3406 2262)
 (buffers 992 15))