From 4f1ab3ca1db5e2aa2fb71599918f6d1c32ebf95e Mon Sep 17 00:00:00 2001 From: dickmao 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