master 370b216f086: New variable 'project-files-relative-names'

[Dmitry Gutov]

branch: master
commit 370b216f08699bdd85b910868642df441c06306c
Author: Dmitry Gutov <dmitry@gutov.dev>
Commit: Dmitry Gutov <dmitry@gutov.dev>

    New variable 'project-files-relative-names'
    
    * lisp/progmodes/project.el (project-files-relative-names):
    New variable (bug#69233).
    (project--files-in-directory): Honor it.
    (project--vc-list-files): Here too.
    (project-find-regexp): Use it to improve performance.
    (project-or-external-find-regexp): Add a TODO.
    (project-find-file): Use it here too.
    (project--read-file-cpd-relative, project--read-file-absolute):
    Try to handle file lists with absolute and relative files names.
    (project-find-file-in): Set default-directory, so relative names
    are interpreted correctly.
    
    * lisp/progmodes/xref.el (xref-matches-in-files):
    Consider that the first in FILES can be a relative file name.
    
    * test/lisp/progmodes/project-tests.el (project-find-regexp):
    New test.
    
    * etc/NEWS: Mention it.
---
 etc/NEWS                             |  4 +++
 lisp/progmodes/project.el            | 64 +++++++++++++++++++++++++++---------
 lisp/progmodes/xref.el               |  3 +-
 test/lisp/progmodes/project-tests.el | 24 ++++++++++++++
 4 files changed, 78 insertions(+), 17 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 9b264a23d5c..014184f1fa6 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -696,6 +696,10 @@ you can add this to your init script:
 
     (setopt project-switch-commands #'project-prefix-or-any-command)
 
+*** New variable 'project-files-relative-names'.
+Project backends can support it to improve the performance of their
+'project-files' implementation when this variable is non-nil.
+
 ** VC
 
 ---
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 000a05804a8..b716d442aed 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -323,6 +323,12 @@ end it with `/'.  DIR must be either `project-root' or one 
of
 (cl-defmethod project-root ((project (head transient)))
   (cdr project))
 
+(defvar project-files-relative-names nil
+  "When non-nil, `project-files' is allowed to return relative names.
+The names will be relative to the project root.  And this can only
+happen when all returned files are in the same directory. Meaning, the
+DIRS argument has to be nil or have only one element.")
+
 (cl-defgeneric project-files (project &optional dirs)
   "Return a list of files in directories DIRS in PROJECT.
 DIRS is a list of absolute directories; it should be some
@@ -345,7 +351,6 @@ to find the list of ignores for each directory."
          ;; expanded and not left for the shell command
          ;; to interpret.
          (localdir (file-name-unquote (file-local-name (expand-file-name 
dir))))
-         (dfn (directory-file-name localdir))
          (command (format "%s -H . %s -type f %s -print0"
                           find-program
                           (xref--find-ignores-arguments ignores "./")
@@ -376,12 +381,14 @@ to find the list of ignores for each directory."
             (error "File listing failed: %s" (buffer-string))))
         (goto-char pt)
         (while (search-forward "\0" nil t)
-          (push (buffer-substring-no-properties (1+ pt) (1- (point)))
+          (push (buffer-substring-no-properties (+ pt 2) (1- (point)))
                 res)
           (setq pt (point)))))
-    (project--remote-file-names
-     (mapcar (lambda (s) (concat dfn s))
-             (sort res #'string<)))))
+    (if project-files-relative-names
+        (sort res #'string<)
+      (project--remote-file-names
+       (mapcar (lambda (s) (concat localdir s))
+               (sort res #'string<))))))
 
 (defun project--remote-file-names (local-files)
   "Return LOCAL-FILES as if they were on the system of `default-directory'.
@@ -689,7 +696,9 @@ See `project-vc-extra-root-markers' for the marker value 
format.")
                    (mapcar
                     (lambda (file)
                       (unless (member file submodules)
-                        (concat default-directory file)))
+                        (if project-files-relative-names
+                            file
+                          (concat default-directory file))))
                     (split-string
                      (apply #'vc-git--run-command-string nil "ls-files" args)
                      "\0" t))))
@@ -716,7 +725,8 @@ See `project-vc-extra-root-markers' for the marker value 
format.")
                                 dir))
             (args (list (concat "-mcard" (and include-untracked "u"))
                         "--no-status"
-                        "-0")))
+                        "-0"))
+            files)
        (when extra-ignores
          (setq args (nconc args
                            (mapcan
@@ -725,9 +735,12 @@ See `project-vc-extra-root-markers' for the marker value 
format.")
                             extra-ignores))))
        (with-temp-buffer
          (apply #'vc-hg-command t 0 "." "status" args)
-         (mapcar
-          (lambda (s) (concat default-directory s))
-          (split-string (buffer-string) "\0" t)))))))
+         (setq files (split-string (buffer-string) "\0" t))
+         (unless project-files-relative-names
+           (setq files (mapcar
+                        (lambda (s) (concat default-directory s))
+                        files)))
+         files)))))
 
 (defun project--vc-merge-submodules-p (dir)
   (project--value-in-dir
@@ -970,6 +983,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
   (let* ((caller-dir default-directory)
          (pr (project-current t))
          (default-directory (project-root pr))
+         (project-files-relative-names t)
          (files
           (if (not current-prefix-arg)
               (project-files pr)
@@ -1000,6 +1014,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
   (require 'xref)
   (let* ((pr (project-current t))
          (default-directory (project-root pr))
+         ;; TODO: Make use of `project-files-relative-names' by
+         ;; searching each root separately (maybe in parallel, too).
          (files
           (project-files pr (cons
                              (project-root pr)
@@ -1054,7 +1070,8 @@ for VCS directories listed in 
`vc-directory-exclusion-list'."
   (interactive "P")
   (let* ((pr (project-current t))
          (root (project-root pr))
-         (dirs (list root)))
+         (dirs (list root))
+         (project-files-relative-names t))
     (project-find-file-in
      (or (thing-at-point 'filename)
          (and buffer-file-name (project--find-default-from buffer-file-name 
pr)))
@@ -1130,7 +1147,12 @@ by the user at will."
             (if (> (length common-prefix) 0)
                 (file-name-directory common-prefix))))
          (cpd-length (length common-parent-directory))
-         (prompt (if (zerop cpd-length)
+         (common-parent-directory (if (file-name-absolute-p (car all-files))
+                                      common-parent-directory
+                                    (concat default-directory 
common-parent-directory)))
+         (prompt (if (and (zerop cpd-length)
+                          all-files
+                          (file-name-absolute-p (car all-files)))
                      prompt
                    (concat prompt (format " in %s" common-parent-directory))))
          (included-cpd (when (member common-parent-directory all-files)
@@ -1167,10 +1189,19 @@ by the user at will."
 (defun project--read-file-absolute (prompt
                                     all-files &optional predicate
                                     hist mb-default)
-  (project--completing-read-strict prompt
-                                   (project--file-completion-table all-files)
-                                   predicate
-                                   hist mb-default))
+  (let* ((new-prompt (if (file-name-absolute-p (car all-files))
+                         prompt
+                       (concat prompt " in " default-directory)))
+         ;; FIXME: Map relative names to absolute?
+         (ct (project--file-completion-table all-files))
+         (file
+          (project--completing-read-strict new-prompt
+                                           ct
+                                           predicate
+                                           hist mb-default)))
+    (unless (file-name-absolute-p file)
+      (setq file (expand-file-name file)))
+    file))
 
 (defun project--read-file-name ( project prompt
                                  all-files &optional predicate
@@ -1215,6 +1246,7 @@ directories listed in `vc-directory-exclusion-list'."
                dirs)
             (project-files project dirs)))
          (completion-ignore-case read-file-name-completion-ignore-case)
+         (default-directory (project-root project))
          (file (project--read-file-name
                 project "Find file"
                 all-files nil 'file-name-history
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 755c3db04fd..29fc6cd560f 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1922,7 +1922,8 @@ to control which program to use when looking for matches."
        (hits nil)
        ;; Support for remote files.  The assumption is that, if the
        ;; first file is remote, they all are, and on the same host.
-       (dir (file-name-directory (car files)))
+       (dir (or (file-name-directory (car files))
+                default-directory))
        (remote-id (file-remote-p dir))
        ;; The 'auto' default would be fine too, but ripgrep can't handle
        ;; the options we pass in that case.
diff --git a/test/lisp/progmodes/project-tests.el 
b/test/lisp/progmodes/project-tests.el
index 04cdf1dea29..84a5d55f136 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -163,4 +163,28 @@ When `project-ignores' includes a name matching project 
dir."
     (should-not (null project))
     (should (string-match-p "/test/lisp/progmodes/project-resources/\\'" 
(project-root project)))))
 
+(ert-deftest project-find-regexp ()
+  "Check the happy path."
+  (skip-unless (executable-find find-program))
+  (skip-unless (executable-find "xargs"))
+  (skip-unless (executable-find "grep"))
+  (let* ((directory (ert-resource-directory))
+         (project-find-functions nil)
+         (project (cons 'transient directory)))
+    (add-hook 'project-find-functions (lambda (_dir) project))
+    (should (eq (project-current) project))
+    (let* ((matches nil)
+           (xref-search-program 'grep)
+           (xref-show-xrefs-function
+            (lambda (fetcher _display)
+              (setq matches (funcall fetcher)))))
+      (project-find-regexp "etc")
+      (should (equal (mapcar (lambda (item)
+                               (file-name-base
+                                (xref-location-group (xref-item-location 
item))))
+                             matches)
+                     '(".dir-locals" "etc")))
+      (should (equal (sort (mapcar #'xref-item-summary matches) #'string<)
+                     '("((nil . ((project-vc-ignores . (\"etc\")))))" 
"etc"))))))
+
 ;;; project-tests.el ends here