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.

(cherry picked from commit 370b216f08699bdd85b910868642df441c06306c)

diff --git a/etc/NEWS b/etc/NEWS
index 07d0dc6e2a8668e4623e546f48667ae9ab4ef952..f8430c25efe711b88b98468f677f2b37c2703a3f 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -699,6 +699,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 4958cb06bb391ca7fdd768d0510ea5dba2a79165..66ce548add9686e09b76b4a7981a88c41fad2b42 100644 (file)
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -318,6 +318,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
@@ -340,7 +346,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 "./")
@@ -371,12 +376,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'.
@@ -684,7 +691,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))))
@@ -711,7 +720,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
@@ -720,9 +730,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
@@ -959,15 +972,20 @@ The following commands are available:
 (cl-defmethod xref-backend-restore ((_backend (head project-dir)) _context))
 (cl-defmethod xref-backend-apropos ((backend (head project-dir)) pattern)
   (project--find-regexp-in-files
-   pattern (project--files-in-directory (nth 1 backend) nil (nth 2 backend))))
+   pattern
+   (let ((project-files-relative-names t))
+     (project--files-in-directory (nth 1 backend) nil (nth 2 backend)))))
 
 (cl-defmethod xref-backend-context ((_backend (head project-ext)) _id _kind))
 (cl-defmethod xref-backend-restore ((_backend (head project-ext)) _context))
 (cl-defmethod xref-backend-apropos ((backend (head project-ext)) pattern)
   (let ((pr (cdr backend)))
     (project--find-regexp-in-files
-     pattern (project-files pr (cons (project-root pr)
-                                     (project-external-roots pr))))))
+     pattern
+     ;; TODO: Make use of `project-files-relative-names' by
+     ;; searching each root separately (maybe in parallel, too).
+     (project-files pr (cons (project-root pr)
+                             (project-external-roots pr))))))
 
 ;;;###autoload
 (defun project-find-regexp (regexp &optional dir pattern)
@@ -1054,7 +1072,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 +1149,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 +1191,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 +1248,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 6e0fc9c08dda7fe2bf2b3a4e1c27defb1ca115d2..f1446954c023b90b03c81cc26e8ac40b8c20afeb 100644 (file)
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -2063,7 +2063,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 04cdf1dea2963e79c1bec8181568cf4ec758028c..84a5d55f1360b398096d184348ae3b68b35e3c53 100644 (file)
--- 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