1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-21 06:55:39 +00:00

Fix 'C-u C-x p g' globally and 'A' in dired-mode

* lisp/progmodes/project.el (project-find-regexp): Ensure the
DEFAULT-DIRECTORY is set correctly for the 'C-u' case (bug#70888).

* lisp/progmodes/project.el (project--files-in-directory):
Ensure that the DIR argument ends with a slash --
'dired-do-find-regexp' passes it differently, for example.

* lisp/progmodes/xref.el (xref--group-name-for-display): Ensure
the project-relative and absolute display modes work well for
groups with "relative" file names.
(xref--analyze, xref--add-log-current-defun): Change accordingly.

* test/lisp/progmodes/project-tests.el
(project-find-regexp-with-prefix): New test.
This commit is contained in:
Dmitry Gutov 2024-05-12 20:42:08 +03:00
parent 2c759b9ce6
commit b20d4ab374
3 changed files with 64 additions and 20 deletions

View File

@ -347,7 +347,8 @@ to find the list of ignores for each directory."
(defun project--files-in-directory (dir ignores &optional files)
(require 'find-dired)
(require 'xref)
(let* ((default-directory dir)
(let* ((dir (file-name-as-directory dir))
(default-directory dir)
;; Make sure ~/ etc. in local directory name is
;; expanded and not left for the shell command
;; to interpret.
@ -989,8 +990,9 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
(files
(if (not current-prefix-arg)
(project-files pr)
(let ((dir (read-directory-name "Base directory: "
caller-dir nil t)))
(let* ((dir (read-directory-name "Base directory: "
caller-dir nil t)))
(setq default-directory dir)
(project--files-in-directory dir
nil
(grep-read-files regexp))))))

View File

@ -1048,11 +1048,15 @@ beginning of the line."
(defun xref--add-log-current-defun ()
"Return the string used to group a set of locations.
This function is used as a value for `add-log-current-defun-function'."
(xref--group-name-for-display
(if-let (item (xref--item-at-point))
(xref-location-group (xref-match-item-location item))
(xref--imenu-extract-index-name))
(xref--project-root (project-current))))
(let ((project-root (xref--project-root (project-current))))
(xref--group-name-for-display
(if-let (item (xref--item-at-point))
(xref-location-group (xref-match-item-location item))
(xref--imenu-extract-index-name))
project-root
(and
(string-prefix-p project-root default-directory)
(substring default-directory (length project-root))))))
(defun xref--next-error-function (n reset?)
(when reset?
@ -1184,12 +1188,15 @@ GROUP is a string for decoration purposes and XREF is an
(xref--apply-truncation)))
(run-hooks 'xref-after-update-hook))
(defun xref--group-name-for-display (group project-root)
(defun xref--group-name-for-display (group project-root dd-suffix)
"Return GROUP formatted in the preferred style.
The style is determined by the value of `xref-file-name-display'.
If GROUP looks like a file name, its value is formatted according
to that style. Otherwise it is returned unchanged."
to that style. Otherwise it is returned unchanged.
PROJECT-ROOT is the root of the current project, if any. DD-SUFFIX is
the relative name of `default-directory' relative to the project root."
;; XXX: The way we verify that it's indeed a file name and not some
;; other kind of string, e.g. Java package name or TITLE from
;; `tags-apropos-additional-actions', is pretty lax. But we don't
@ -1199,16 +1206,19 @@ to that style. Otherwise it is returned unchanged."
;; values themselves (e.g. by piping through some public function),
;; or adding a new accessor to locations, like GROUP-TYPE.
(cl-ecase xref-file-name-display
(abs group)
(abs (if (file-name-absolute-p group) group (expand-file-name group)))
(nondirectory
(if (file-name-absolute-p group)
(file-name-nondirectory group)
group))
(file-name-nondirectory group))
(project-relative
(if (and project-root
(string-prefix-p project-root group))
(substring group (length project-root))
group))))
(cond
((not (file-name-absolute-p group))
(concat dd-suffix group))
((and project-root
(string-prefix-p project-root group))
(substring group (length project-root)))
;; Default to absolute when there's not project around.
(t
(expand-file-name group))))))
(defun xref--analyze (xrefs)
"Find common groups in XREFS and format group names.
@ -1221,10 +1231,13 @@ Return an alist of the form ((GROUP . (XREF ...)) ...)."
(eq xref-file-name-display 'project-relative)
(project-current)))
(project-root (and project
(expand-file-name (xref--project-root project)))))
(expand-file-name (xref--project-root project))))
(dd-suffix (and project-root
(string-prefix-p project-root default-directory)
(substring default-directory (length project-root)))))
(mapcar
(lambda (pair)
(cons (xref--group-name-for-display (car pair) project-root)
(cons (xref--group-name-for-display (car pair) project-root dd-suffix)
(cdr pair)))
alist)))

View File

@ -188,4 +188,33 @@ When `project-ignores' includes a name matching project dir."
(should (equal (sort (mapcar #'xref-item-summary matches) #'string<)
'("((nil . ((project-vc-ignores . (\"etc\")))))" "etc"))))))
(ert-deftest project-find-regexp-with-prefix ()
"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-list-file (expand-file-name "emacs-projects" temporary-file-directory))
(project (cons 'transient (expand-file-name "../elisp-mode-resources/" 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))))
(current-prefix-arg t))
(cl-letf (((symbol-function 'read-directory-name)
(lambda (_prompt _default _dirname _mm) directory))
((symbol-function 'grep-read-files) (lambda (_re) "*")))
(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