all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: dick <dick.r.chiang@gmail.com>
To: 61861@debbugs.gnu.org
Subject: bug#61861: 30.0.50; [PATCH] Catch project.el to projectile's dwim behaviors
Date: Mon, 27 Feb 2023 20:22:34 -0500	[thread overview]
Message-ID: <87v8jmfusl.fsf@dick> (raw)

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: 0001-Catch-project.el-up-to-projectile-s-dwim-behaviors.patch --]
[-- Type: text/x-diff, Size: 36289 bytes --]

From 4f1ab3ca1db5e2aa2fb71599918f6d1c32ebf95e Mon Sep 17 00:00:00 2001
From: dickmao <dick.r.chiang@gmail.com>
Date: Mon, 27 Feb 2023 19:55:55 -0500
Subject: [PATCH] Catch project.el up to projectile's dwim behaviors.

src/emacs -Q --batch \
 --eval "(setq project-list-file (make-temp-name \"/tmp/qux\"))" \
 --eval "(if installation-directory \
             (condition-case err \
                 (let ((default-directory installation-directory)) \
                   (project-query-replace-regexp \
                     (concat \"nim\" \"rod\") \"stunad\")) \
               (user-error (princ (format \"%s\n\"
                                          (error-message-string err))))) \
           (princ \"!! run from src/emacs !!\n\"))"

* lisp/progmodes/project.el (project-get-project, project-current):
Rationalize interfaces.
(project--files-in-directory): Whitespace.
(project-try-vc): Avoid swallowing errors.
(project-files): De-obfuscate.
(project--vc-list-files): Whitespace.
(project-find-regexp, project-or-external-find-regexp, project-find-file,
project-or-external-find-file, project-find-dir, project-dired,
project-vc-dir, project-eshell, project-shell, project-async-shell-command,
project-shell-command, project-search, project-query-replace-regexp,
project-compile, project--read-project-buffer, project-list-buffers,
project-kill-buffers, project-switch-project): DWIM.
(project--read-file-cpd-relative): De-obfuscate.
(project-find-file-in): Whitespace.
(project-most-recent-project): New DWIM function.
(project-remember-project, project-prompt-project-dir): De-obfuscate.
(project-execute-extended-command): Rationalize interfaces.
(project-remember-projects-under): Avoid backslashes.
* lisp/progmodes/xref.el (xref-matches-in-files): Do expand-file-name here.
* test/lisp/progmodes/project-tests.el (project-switch-project-extant-buffer,
project-implicit-project-absorption, project-assume-mru-project): Test.
(project-vc-extra-root-markers-supports-wildcards): Dude.
---
 lisp/progmodes/project.el            | 340 +++++++++++++--------------
 lisp/progmodes/xref.el               |   2 +-
 test/lisp/progmodes/project-tests.el |  99 +++++++-
 3 files changed, 266 insertions(+), 175 deletions(-)

diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index 11228226592..565c2f85f5a 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -60,7 +60,7 @@
 ;;
 ;; Transient project:
 ;;
-;; An instance of this type can be returned by `project-current' if no
+;; An instance of this type can be returned by `project-get-project' if no
 ;; project was detected automatically, and the user had to pick a
 ;; directory manually.  The fileset it describes is the whole
 ;; directory, with the exception of some standard ignored files and
@@ -203,38 +203,42 @@ project-current-directory-override
 When it is non-nil, `project-current' will always skip prompting too.")
 
 ;;;###autoload
-(defun project-current (&optional maybe-prompt directory)
-  "Return the project instance in DIRECTORY, defaulting to `default-directory'.
-
-When no project is found in that directory, the result depends on
-the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
-else ask the user for a directory in which to look for the
-project, and if no project is found there, return a \"transient\"
-project instance.
-
-The \"transient\" project instance is a special kind of value
-which denotes a project rooted in that directory and includes all
-the files under the directory except for those that match entries
-in `vc-directory-exclusion-list' or `grep-find-ignored-files'.
-
-See the doc string of `project-find-functions' for the general form
-of the project instance object."
-  (unless directory (setq directory (or project-current-directory-override
-                                        default-directory)))
-  (let ((pr (project--find-in-directory directory)))
-    (cond
-     (pr)
-     ((unless project-current-directory-override
-        maybe-prompt)
+(defun project-get-project (&optional directory)
+  "Return the project for DIRECTORY, and mark as most recently used.
+DIRECTORY defaults to `default-directory'.  If no project obtains
+from DIRECTORY, prompt the user for an alternate directory.  If
+no project obtains from the alternate, return the \"transient\"
+project instance and do not adjust recently used projects."
+  (let* ((directory (or directory
+                        project-current-directory-override
+                        default-directory))
+         (pr (project--find-in-directory directory)))
+    (when (and (not pr)
+               (not project-current-directory-override))
       (setq directory (project-prompt-project-dir)
-            pr (project--find-in-directory directory))))
-    (when maybe-prompt
-      (if pr
-          (project-remember-project pr)
+            pr (project--find-in-directory directory)))
+    (if pr
+        (prog1 pr
+          (project-remember-project pr))
+      (prog1 (cons 'transient directory)
         (project--remove-from-project-list
-         directory "Project `%s' not found; removed from list")
-        (setq pr (cons 'transient directory))))
-    pr))
+         directory "Project `%s' not found; removed from list")))))
+
+;;;###autoload
+(defun project-current (&optional maybe-prompt directory)
+  "Return the project for DIRECTORY.
+DIRECTORY defaults to `default-directory'.
+Under MAYBE-PROMPT, calls `project-get-project'."
+  ;; Gradually replace occurrences of (project-current t)
+  ;; with (project-get-project), and replace (project-current nil dir)
+  ;; with (let ((default-directory dir)) (project-current))
+  (if maybe-prompt
+      (project-get-project directory)
+    (let ((pr (project--find-in-directory
+               (or directory
+                   project-current-directory-override
+                   default-directory))))
+      (prog1 pr (when pr (project-remember-project pr))))))
 
 (defun project--find-in-directory (dir)
   (run-hook-with-args-until-success 'project-find-functions dir))
@@ -327,11 +331,6 @@ project--files-in-directory
   (require 'find-dired)
   (require 'xref)
   (let* ((default-directory dir)
-         ;; Make sure ~/ etc. in local directory name is
-         ;; 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 "./")
@@ -347,14 +346,12 @@ project--files-in-directory
                             "")))
          res)
     (with-temp-buffer
-      (let ((status
-             (process-file-shell-command command nil t))
+      (let ((status (process-file-shell-command command nil t))
             (pt (point-min)))
         (unless (zerop status)
           (goto-char (point-min))
-          (if (and
-               (not (eql status 127))
-               (search-forward "Permission denied\n" nil t))
+          (if (and (not (eql status 127))
+                   (search-forward "Permission denied\n" nil t))
               (let ((end (1- (point))))
                 (re-search-backward "\\`\\|\0")
                 (error "File listing failed: %s"
@@ -365,21 +362,17 @@ project--files-in-directory
           (push (buffer-substring-no-properties (1+ pt) (1- (point)))
                 res)
           (setq pt (point)))))
-    (project--remote-file-names
-     (mapcar (lambda (s) (concat dfn s))
-             (sort res #'string<)))))
-
-(defun project--remote-file-names (local-files)
-  "Return LOCAL-FILES as if they were on the system of `default-directory'.
-Also quote LOCAL-FILES if `default-directory' is quoted."
-  (let ((remote-id (file-remote-p default-directory)))
-    (if (not remote-id)
-        (if (file-name-quoted-p default-directory)
-            (mapcar #'file-name-quote local-files)
-          local-files)
-      (mapcar (lambda (file)
-                (concat remote-id file))
-              local-files))))
+    (setq res (sort res #'string<))
+    (if-let ((remote-id (file-remote-p default-directory)))
+        (mapcar (lambda (file)
+                  (concat remote-id
+                          (directory-file-name
+                           (file-name-unquote
+                            (file-local-name
+                             (expand-file-name default-directory))))
+                          file))
+                res)
+      (mapcar (lambda (s) (concat (directory-file-name default-directory) s)) res))))
 
 (cl-defgeneric project-buffers (project)
   "Return the list of all live buffers that belong to PROJECT.
@@ -539,10 +532,8 @@ project-try-vc
                dir
                (lambda (d)
                  ;; Maybe limit count to 100 when we can drop Emacs < 28.
-                 (setq last-matches
-                       (condition-case nil
-                           (directory-files d nil marker-re t)
-                         (file-missing nil))))))
+                 (when (file-directory-p d)
+                   (setq last-matches (directory-files d nil marker-re t))))))
              (backend
               (cl-find-if
                (lambda (b)
@@ -604,18 +595,13 @@ project-files
        (when backend
          (require (intern (concat "vc-" (downcase (symbol-name backend))))))
        (if (and (file-equal-p dir (nth 2 project))
-                (cond
-                 ((eq backend 'Hg))
-                 ((and (eq backend 'Git)
-                       (or
-                        (not ignores)
-                        (version<= "1.9" (vc-git--program-version)))))))
+                (or (eq backend 'Hg)
+                    (and (eq backend 'Git)
+                         (or (not ignores)
+                             (version<= "1.9" (vc-git--program-version))))))
            (project--vc-list-files dir backend ignores)
-         (project--files-in-directory
-          dir
-          (project--dir-ignores project dir)))))
-   (or dirs
-       (list (project-root project)))))
+         (project--files-in-directory dir (project--dir-ignores project dir)))))
+   (or dirs (list (project-root project)))))
 
 (declare-function vc-git--program-version "vc-git")
 (declare-function vc-git--run-command-string "vc-git")
@@ -625,16 +611,15 @@ project--vc-list-files
   (defvar vc-git-use-literal-pathspecs)
   (pcase backend
     (`Git
-     (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
+     (let* ((default-directory dir)
             (args '("-z"))
             (vc-git-use-literal-pathspecs nil)
             (include-untracked (project--value-in-dir
                                 'project-vc-include-untracked
                                 dir))
             files)
-       (setq args (append args
-                          '("-c" "--exclude-standard")
-                          (and include-untracked '("-o"))))
+       (setq args (append args '("-c" "--exclude-standard")
+                          (when include-untracked '("-o"))))
        (when extra-ignores
          (setq args (append args
                             (cons "--"
@@ -663,7 +648,7 @@ project--vc-list-files
                                    extra-ignores)))))
        (setq files
              (mapcar
-              (lambda (file) (concat default-directory file))
+              (lambda (file) (concat (file-name-as-directory dir) file))
               (split-string
                (apply #'vc-git--run-command-string nil "ls-files" args)
                "\0" t)))
@@ -675,17 +660,16 @@ project--vc-list-files
                   (lambda (module)
                     (when (file-directory-p module)
                       (project--vc-list-files
-                       (concat default-directory module)
+                       (concat (file-name-as-directory dir) module)
                        backend
                        extra-ignores)))
                   submodules)))
-           (setq files
-                 (apply #'nconc files sub-files))))
+           (setq files (apply #'nconc files sub-files))))
        ;; 'git ls-files' returns duplicate entries for merge conflicts.
        ;; XXX: Better solutions welcome, but this seems cheap enough.
        (delete-consecutive-dups files)))
     (`Hg
-     (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
+     (let* ((default-directory dir)
             (include-untracked (project--value-in-dir
                                 'project-vc-include-untracked
                                 dir))
@@ -693,16 +677,12 @@ project--vc-list-files
                         "--no-status"
                         "-0")))
        (when extra-ignores
-         (setq args (nconc args
-                           (mapcan
-                            (lambda (i)
-                              (list "--exclude" i))
-                            extra-ignores))))
+         (setq args (nconc args (mapcan (lambda (i) (list "--exclude" i))
+                                        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)))))))
+         (mapcar (lambda (s) (concat (file-name-as-directory dir) s))
+                 (split-string (buffer-string) "\0" t)))))))
 
 (defun project--vc-merge-submodules-p (dir)
   (project--value-in-dir
@@ -924,7 +904,7 @@ project-find-regexp
   (require 'xref)
   (require 'grep)
   (let* ((caller-dir default-directory)
-         (pr (project-current t))
+         (pr (project-most-recent-project))
          (default-directory (project-root pr))
          (files
           (if (not current-prefix-arg)
@@ -956,7 +936,7 @@ project-or-external-find-regexp
 pattern to search for."
   (interactive (list (project--read-regexp)))
   (require 'xref)
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (default-directory (project-root pr))
          (files
           (project-files pr (cons
@@ -992,7 +972,7 @@ project-find-file
 interactively, include all files under the project root, except
 for VCS directories listed in `vc-directory-exclusion-list'."
   (interactive "P")
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (root (project-root pr))
          (dirs (list root)))
     (project-find-file-in
@@ -1011,7 +991,7 @@ project-or-external-find-file
 interactively, include all files under the project root, except
 for VCS directories listed in `vc-directory-exclusion-list'."
   (interactive "P")
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (dirs (cons
                 (project-root pr)
                 (project-external-roots pr))))
@@ -1039,39 +1019,40 @@ project--read-file-cpd-relative
 MB-DEFAULT is used as part of \"future history\", to be inserted
 by the user at will."
   (let* ((common-parent-directory
-          (let ((common-prefix (try-completion "" all-files)))
-            (if (> (length common-prefix) 0)
-                (file-name-directory common-prefix))))
-         (cpd-length (length common-parent-directory))
-         (prompt (if (zerop cpd-length)
-                     prompt
-                   (concat prompt (format " in %s" common-parent-directory))))
-         (included-cpd (when (member common-parent-directory all-files)
-                         (setq all-files
-                               (delete common-parent-directory all-files))
-                         t))
-         (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
-         (_ (when included-cpd
-              (setq substrings (cons "./" substrings))))
-         (new-collection (project--file-completion-table substrings))
-         (abbr-cpd (abbreviate-file-name common-parent-directory))
-         (abbr-cpd-length (length abbr-cpd))
-         (relname (cl-letf ((history-add-new-input nil)
-                            ((symbol-value hist)
-                             (mapcan
-                              (lambda (s)
-                                (and (string-prefix-p abbr-cpd s)
-                                     (not (eq abbr-cpd-length (length s)))
-                                     (list (substring s abbr-cpd-length))))
-                              (symbol-value hist))))
-                    (project--completing-read-strict prompt
-                                                     new-collection
-                                                     predicate
-                                                     hist mb-default)))
+          (or (let ((common-prefix (try-completion "" all-files)))
+                (unless (zerop (length common-prefix))
+                  (file-name-directory common-prefix)))
+              ""))
+         (relname (cl-letf* ((new-collection
+                              (project--file-completion-table
+                               (mapcar
+                                (lambda (file)
+                                  (let ((s (substring
+                                            file (length common-parent-directory))))
+                                    (if (string-empty-p s) "." s)))
+                                all-files)))
+                             (history-add-new-input nil)
+                             (abbr-cpd (abbreviate-file-name common-parent-directory))
+                             (abbr-cpd-length (length abbr-cpd))
+                             ((symbol-value hist)
+                              (mapcan
+                               (lambda (s)
+                                 (and (string-prefix-p abbr-cpd s)
+                                      (not (eq abbr-cpd-length (length s)))
+                                      (list (substring s abbr-cpd-length))))
+                               (symbol-value hist))))
+                    (project--completing-read-strict
+                     (concat prompt
+                             (unless (string-empty-p common-parent-directory)
+                               (format " [%s]" (directory-file-name
+                                                common-parent-directory))))
+                     new-collection
+                     predicate
+                     hist mb-default)))
          (absname (expand-file-name relname common-parent-directory)))
-    (when (and hist history-add-new-input)
-      (add-to-history hist (abbreviate-file-name absname)))
-    absname))
+    (prog1 absname
+      (when (and hist history-add-new-input)
+        (add-to-history hist (abbreviate-file-name absname))))))
 
 (defun project--read-file-absolute (prompt
                                     all-files &optional predicate
@@ -1094,17 +1075,16 @@ project-find-file-in
                            (lambda (dir)
                              (concat dir "/"))
                            vc-directory-exclusion-list))
-         (all-files
-          (if include-all
-              (mapcan
-               (lambda (dir) (project--files-in-directory dir vc-dirs-ignores))
-               dirs)
-            (project-files project dirs)))
+         (all-files (if include-all
+                        (mapcan (lambda (dir)
+                                  (project--files-in-directory dir vc-dirs-ignores))
+                                dirs)
+                      (project-files project dirs)))
          (completion-ignore-case read-file-name-completion-ignore-case)
          (file (funcall project-read-file-name-function
                         "Find file" all-files nil 'file-name-history
                         suggested-filename)))
-    (if (string= file "")
+    (if (string-empty-p file)
         (user-error "You didn't specify the file")
       (find-file file))))
 
@@ -1126,7 +1106,7 @@ project--completing-read-strict
 (defun project-find-dir ()
   "Start Dired in a directory inside the current project."
   (interactive)
-  (let* ((project (project-current t))
+  (let* ((project (project-most-recent-project))
          (all-files (project-files project))
          (completion-ignore-case read-file-name-completion-ignore-case)
          ;; FIXME: This misses directories without any files directly
@@ -1146,13 +1126,13 @@ project-find-dir
 (defun project-dired ()
   "Start Dired in the current project's root."
   (interactive)
-  (dired (project-root (project-current t))))
+  (dired (project-root (project-most-recent-project))))
 
 ;;;###autoload
 (defun project-vc-dir ()
   "Run VC-Dir in the current project's root."
   (interactive)
-  (vc-dir (project-root (project-current t))))
+  (vc-dir (project-root (project-most-recent-project))))
 
 (declare-function comint-check-proc "comint")
 
@@ -1165,7 +1145,7 @@ project-shell
 if one already exists."
   (interactive)
   (require 'comint)
-  (let* ((default-directory (project-root (project-current t)))
+  (let* ((default-directory (project-root (project-most-recent-project)))
          (default-project-shell-name (project-prefixed-buffer-name "shell"))
          (shell-buffer (get-buffer default-project-shell-name)))
     (if (and shell-buffer (not current-prefix-arg))
@@ -1183,7 +1163,7 @@ project-eshell
 if one already exists."
   (interactive)
   (defvar eshell-buffer-name)
-  (let* ((default-directory (project-root (project-current t)))
+  (let* ((default-directory (project-root (project-most-recent-project)))
          (eshell-buffer-name (project-prefixed-buffer-name "eshell"))
          (eshell-buffer (get-buffer eshell-buffer-name)))
     (if (and eshell-buffer (not current-prefix-arg))
@@ -1195,7 +1175,7 @@ project-async-shell-command
   "Run `async-shell-command' in the current project's root directory."
   (declare (interactive-only async-shell-command))
   (interactive)
-  (let ((default-directory (project-root (project-current t))))
+  (let ((default-directory (project-root (project-most-recent-project))))
     (call-interactively #'async-shell-command)))
 
 ;;;###autoload
@@ -1203,7 +1183,7 @@ project-shell-command
   "Run `shell-command' in the current project's root directory."
   (declare (interactive-only shell-command))
   (interactive)
-  (let ((default-directory (project-root (project-current t))))
+  (let ((default-directory (project-root (project-most-recent-project))))
     (call-interactively #'shell-command)))
 
 (declare-function fileloop-continue "fileloop" ())
@@ -1216,7 +1196,7 @@ project-search
 command \\[fileloop-continue]."
   (interactive "sSearch (regexp): ")
   (fileloop-initialize-search
-   regexp (project-files (project-current t)) 'default)
+   regexp (project-files (project-most-recent-project)) 'default)
   (fileloop-continue))
 
 ;;;###autoload
@@ -1239,7 +1219,10 @@ project-query-replace-regexp
    ;; XXX: Filter out Git submodules, which are not regular files.
    ;; `project-files' can return those, which is arguably suboptimal,
    ;; but removing them eagerly has performance cost.
-   (cl-delete-if-not #'file-regular-p (project-files (project-current t)))
+   (cl-delete-if-not (lambda (file)
+                       (and (file-regular-p file)
+                            (not (find-file-name-handler file 'insert-file-contents))))
+                 (project-files (project-most-recent-project)))
    'default)
   (fileloop-continue))
 
@@ -1270,7 +1253,7 @@ project-compile
   "Run `compile' in the project root."
   (declare (interactive-only compile))
   (interactive)
-  (let ((default-directory (project-root (project-current t)))
+  (let ((default-directory (project-root (project-most-recent-project)))
         (compilation-buffer-name-function
          (or project-compilation-buffer-name-function
              compilation-buffer-name-function)))
@@ -1300,7 +1283,7 @@ project-ignore-buffer-conditions
   :package-version '(project . "0.8.2"))
 
 (defun project--read-project-buffer ()
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (current-buffer (current-buffer))
          (other-buffer (other-buffer current-buffer))
          (other-name (buffer-name other-buffer))
@@ -1365,7 +1348,7 @@ project-list-buffers
 start with a space (which are for internal use).  With prefix argument
 ARG, show only buffers that are visiting files."
   (interactive "P")
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (buffer-list-function
           (lambda ()
             (seq-filter
@@ -1506,7 +1489,7 @@ project-kill-buffers
 
 Also see the `project-kill-buffers-display-buffer-list' variable."
   (interactive)
-  (let* ((pr (project-current t))
+  (let* ((pr (project-most-recent-project))
          (bufs (project--buffers-to-kill pr))
          (query-user (lambda ()
                        (yes-or-no-p
@@ -1582,19 +1565,28 @@ project--write-project-list
       (write-region nil nil filename nil 'silent))))
 
 ;;;###autoload
-(defun project-remember-project (pr &optional no-write)
+(defun project-most-recent-project ()
+  (project--ensure-read-project-list)
+  (let ((pr (or (project-current)
+                (when-let ((mru (caar project--list)))
+                  (project--find-in-directory mru))
+                (project-get-project))))
+    (prog1 pr (project-remember-project pr))))
+
+;;;###autoload
+(defun project-remember-project (pr &optional _no-write)
   "Add project PR to the front of the project list.
 Save the result in `project-list-file' if the list of projects
 has changed, and NO-WRITE is nil."
   (project--ensure-read-project-list)
-  (let ((dir (project-root pr)))
-    (unless (equal (caar project--list) dir)
-      (dolist (ent project--list)
-        (when (equal dir (car ent))
-          (setq project--list (delq ent project--list))))
-      (push (list dir) project--list)
-      (unless no-write
-        (project--write-project-list)))))
+  (let* ((dir (project-root pr))
+         (extant (cl-find-if (lambda (entry) (equal dir (car entry)))
+                             project--list)))
+    (setq project--list (delq extant project--list))
+    (push (list dir) project--list)
+    (when (and (not extant)
+               (not (bound-and-true-p ert--running-tests)))
+      (project--write-project-list))))
 
 (defun project--remove-from-project-list (project-root report-message)
   "Remove directory PROJECT-ROOT of a missing project from the project list.
@@ -1623,19 +1615,17 @@ project-prompt-project-dir
 see `project-list-file'.
 It's also possible to enter an arbitrary directory not in the list."
   (project--ensure-read-project-list)
-  (let* ((dir-choice "... (choose a dir)")
-         (choices
-          ;; XXX: Just using this for the category (for the substring
-          ;; completion style).
-          (project--file-completion-table
-           (append project--list `(,dir-choice))))
-         (pr-dir ""))
-    (while (equal pr-dir "")
-      ;; If the user simply pressed RET, do this again until they don't.
-      (setq pr-dir (completing-read "Select project: " choices nil t)))
-    (if (equal pr-dir dir-choice)
+  (let* (pr
+         (dir-choice "... (choose a dir)")
+         (choices (project--file-completion-table
+                   (append project--list `(,dir-choice)))))
+    (while (string-empty-p
+            ;; Even under require-match, `completing-read' allows RET
+            ;; to yield an empty string.
+            (setq pr (completing-read "Select project: " choices nil t))))
+    (if (equal pr dir-choice)
         (read-directory-name "Select directory: " default-directory nil t)
-      pr-dir)))
+      pr)))
 
 ;;;###autoload
 (defun project-known-project-roots ()
@@ -1648,7 +1638,7 @@ project-execute-extended-command
   "Execute an extended command in project root."
   (declare (interactive-only command-execute))
   (interactive)
-  (let ((default-directory (project-root (project-current t))))
+  (let ((default-directory (project-root (project-most-recent-project))))
     (call-interactively #'execute-extended-command)))
 
 (defun project-remember-projects-under (dir &optional recursive)
@@ -1672,7 +1662,7 @@ project-remember-projects-under
         (when-let ((project (project--find-in-directory subdir))
                    (project-root (project-root project))
                    ((not (gethash project-root known))))
-          (project-remember-project project t)
+          (project-remember-project project)
           (puthash project-root t known)
           (message "Found %s..." project-root)
           (setq count (1+ count)))
@@ -1818,18 +1808,22 @@ project--switch-project-command
 
 ;;;###autoload
 (defun project-switch-project (dir)
-  "\"Switch\" to another project by running an Emacs command.
+  "Switch to another project by running an Emacs command.
 The available commands are presented as a dispatch menu
 made from `project-switch-commands'.
 
 When called in a program, it will use the project corresponding
 to directory DIR."
   (interactive (list (project-prompt-project-dir)))
-  (let ((command (if (symbolp project-switch-commands)
-                     project-switch-commands
-                   (project--switch-project-command))))
-    (let ((project-current-directory-override dir))
-      (call-interactively command))))
+  (if-let ((pr (let ((default-directory dir))
+                 (project-current)))
+           (mru (cl-find-if #'buffer-file-name (project-buffers pr))))
+      (project-switch-to-buffer mru)
+    (let ((command (if (symbolp project-switch-commands)
+                       project-switch-commands
+                     (project--switch-project-command))))
+      (let ((project-current-directory-override dir))
+        (call-interactively command)))))
 
 (provide 'project)
 ;;; project.el ends here
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 38c424402a0..b23a628816a 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -1908,7 +1908,7 @@ xref-matches-in-files
     (with-current-buffer output
       (erase-buffer)
       (with-temp-buffer
-        (insert (mapconcat #'identity files "\0"))
+        (insert (mapconcat #'expand-file-name files "\0"))
         (setq default-directory dir)
         (setq status
               (xref--with-connection-local-variables
diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el
index 5a206b67db1..21fb71ac58e 100644
--- a/test/lisp/progmodes/project-tests.el
+++ b/test/lisp/progmodes/project-tests.el
@@ -32,6 +32,10 @@
 (require 'ert-x) ; ert-with-temp-directory
 (require 'grep)
 (require 'xref)
+(require 'vc)
+(require 'vc-git)
+(require 'log-edit)
+
 
 (ert-deftest project/quoted-directory ()
   "Check that `project-files' and `project-find-regexp' deal with
@@ -110,6 +114,99 @@ project-ignores-bug-50240
                      (list
                       (expand-file-name "some-file" dir)))))))
 
+(ert-deftest project-switch-project-extant-buffer ()
+  "Prefer just switching to the mru buffer of the switched-to project instead
+of bringing up `project-switch-commands'."
+  (ert-with-temp-directory dir1
+    (ert-with-temp-directory dir2
+      (cl-letf* ((switch-called-on nil)
+                 ((symbol-function 'switch-project)
+                  (lambda () (interactive)
+                    (setq default-directory project-current-directory-override
+                          switch-called-on default-directory)))
+                 (project1 (make-project-tests--trivial :root dir1))
+                 (project2 (make-project-tests--trivial :root dir2))
+                 (project-find-functions
+                  (list (lambda (dir)
+                          (assoc-default dir (list (cons dir1 project1)
+                                                   (cons dir2 project2))))))
+                 (project-switch-commands 'switch-project)
+                 (buf2 (progn
+                         (make-empty-file (expand-file-name "some-file" dir2))
+                         (find-file-noselect (expand-file-name "some-file" dir2)))))
+        (project-switch-project dir1)
+        (should (equal switch-called-on dir1))
+        (should (equal (project-root (project-current)) dir1))
+        (project-switch-project dir2)
+        (should (equal switch-called-on dir1)) ; not dir2
+        (should (equal (project-root (project-current)) dir2))
+        (should (eq (current-buffer) buf2))
+        (let (kill-buffer-query-functions) (kill-buffer buf2))))))
+
+(ert-deftest project-assume-mru-project ()
+  "Assume mru project if default-directory is project-less."
+  (ert-with-temp-directory dir1
+    (ert-with-temp-directory dir2
+      (cl-letf* ((project2 (make-project-tests--trivial :root dir2))
+                 (project-find-functions
+                  (list (lambda (dir)
+                          (assoc-default dir (list (cons dir2 project2))))))
+                 (buf1 (progn
+                         (make-empty-file (expand-file-name "some-file" dir1))
+                         (find-file-noselect (expand-file-name "some-file" dir1))))
+                 (buf2 (progn
+                         (make-empty-file (expand-file-name "some-file" dir2))
+                         (find-file-noselect (expand-file-name "some-file" dir2))))
+                 ((symbol-function 'read-buffer)
+                  (lambda (_prompt other-buffer &rest _args)
+                    other-buffer)))
+        (switch-to-buffer buf1)
+        (should-not (project-current))
+        (switch-to-buffer buf2)
+        (should (equal (project-root (project-current)) dir2))
+        (switch-to-buffer buf1)
+        (call-interactively #'project-switch-to-buffer)
+        (should (eq (current-buffer) buf2))
+        (let (kill-buffer-query-functions)
+          (kill-buffer buf1)
+          (kill-buffer buf2))))))
+
+(defmacro project-tests--mock-repo (&rest body)
+  (declare (indent defun))
+  `(let* ((dir (make-temp-file "project-tests" t))
+          (default-directory dir))
+     (unwind-protect
+         (progn
+           (vc-git-create-repo)
+           (vc-git-command nil 0 nil "config" "--add" "user.name" "frou")
+           (vc-git-command nil 0 nil "config" "--add" "user.email" "frou@frou.org")
+           ,@body)
+       (delete-directory dir t))))
+
+(ert-deftest project-implicit-project-absorption ()
+  "Running a project command should register the project without further ado."
+  (skip-unless (executable-find vc-git-program))
+  (project-tests--mock-repo
+    (with-temp-file "foo")
+    (condition-case err
+        (progn
+          (vc-git-register (split-string "foo"))
+          (vc-git-checkin (split-string "foo") "No-Verify: yes
+his fooness")
+          (vc-git-checkout nil (vc-git--rev-parse "HEAD")))
+      (error (signal (car err) (with-current-buffer "*vc*" (buffer-string)))))
+    (cl-letf (((symbol-function 'read-buffer)
+               (lambda (&rest _args)
+                 (current-buffer))))
+      (switch-to-buffer (find-file-noselect "foo"))
+      (should-not (cl-some (lambda (project)
+                             (equal default-directory (car project)))
+                           project--list))
+      (call-interactively #'project-switch-to-buffer)
+      (should (cl-some (lambda (project)
+                         (equal default-directory (car project)))
+                       project--list)))))
+
 (defvar project-tests--this-file (or (bound-and-true-p byte-compile-current-file)
                                      (and load-in-progress load-file-name)
                                      buffer-file-name))
@@ -136,7 +233,7 @@ project-vc-extra-root-markers-supports-wildcards
          (_ (vc-file-clearprops dir))
          (project-vc-extra-root-markers '("files-x-tests.*"))
          (project (project-current nil dir)))
-    (should-not (null project))
+    (should project)
     (should (string-match-p "/test/lisp/\\'" (project-root project)))))
 
 (ert-deftest project-vc-supports-project-in-different-dir ()
-- 
2.38.1






             reply	other threads:[~2023-02-28  1:22 UTC|newest]

Thread overview: 2+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2023-02-28  1:22 dick [this message]
2023-02-28 16:20 ` bug#61861: 30.0.50; [PATCH] Catch project.el to projectile's dwim behaviors Dmitry Gutov

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87v8jmfusl.fsf@dick \
    --to=dick.r.chiang@gmail.com \
    --cc=61861@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.