project.el - dotemacs - My Emacs configuration

project.el (73568B)
      1 ;;; project.el --- Operations on the current project  -*- lexical-binding: t; -*-
      2 
      3 ;; Copyright (C) 2015-2023 Free Software Foundation, Inc.
      4 ;; Version: 0.9.4
      5 ;; Package-Requires: ((emacs "26.1") (xref "1.4.0"))
      6 
      7 ;; This is a GNU ELPA :core package.  Avoid using functionality that
      8 ;; not compatible with the version of Emacs recorded above.
      9 
     10 ;; This file is part of GNU Emacs.
     11 
     12 ;; GNU Emacs is free software: you can redistribute it and/or modify
     13 ;; it under the terms of the GNU General Public License as published by
     14 ;; the Free Software Foundation, either version 3 of the License, or
     15 ;; (at your option) any later version.
     16 
     17 ;; GNU Emacs is distributed in the hope that it will be useful,
     18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     20 ;; GNU General Public License for more details.
     21 
     22 ;; You should have received a copy of the GNU General Public License
     23 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
     24 
     25 ;;; Commentary:
     26 
     27 ;; NOTE: The project API is still experimental and can change in major,
     28 ;; backward-incompatible ways.  Everyone is encouraged to try it, and
     29 ;; report to us any problems or use cases we hadn't anticipated, by
     30 ;; sending an email to emacs-devel, or `M-x report-emacs-bug'.
     31 ;;
     32 ;; This file contains generic infrastructure for dealing with
     33 ;; projects, some utility functions, and commands using that
     34 ;; infrastructure.
     35 ;;
     36 ;; The goal is to make it easier for Lisp programs to operate on the
     37 ;; current project, without having to know which package handles
     38 ;; detection of that project type, parsing its config files, etc.
     39 ;;
     40 ;; This file consists of following parts:
     41 ;;
     42 ;; Infrastructure (the public API):
     43 ;;
     44 ;; Function `project-current' that returns the current project
     45 ;; instance based on the value of the hook `project-find-functions',
     46 ;; and several generic functions that act on it.
     47 ;;
     48 ;; `project-root' must be defined for every project.
     49 ;; `project-files' can be overridden for performance purposes.
     50 ;; `project-ignores' and `project-external-roots' describe the project
     51 ;; files and its relations to external directories.  `project-files'
     52 ;; should be consistent with `project-ignores'.
     53 ;;
     54 ;; `project-buffers' can be overridden if the project has some unusual
     55 ;; shape (e.g. it contains files residing outside of its root, or some
     56 ;; files inside the root must not be considered a part of it).  It
     57 ;; should be consistent with `project-files'.
     58 ;;
     59 ;; This list can change in future versions.
     60 ;;
     61 ;; Transient project:
     62 ;;
     63 ;; An instance of this type can be returned by `project-current' if no
     64 ;; project was detected automatically, and the user had to pick a
     65 ;; directory manually.  The fileset it describes is the whole
     66 ;; directory, with the exception of some standard ignored files and
     67 ;; directories.  This type has little purpose otherwise, as the only
     68 ;; generic function it provides an override for is `project-root'.
     69 ;;
     70 ;; VC-aware project:
     71 ;;
     72 ;; Originally conceived as an example implementation, now it's a
     73 ;; relatively fast backend that delegates to 'git ls-files' or 'hg
     74 ;; status' to list the project's files.  It honors the VC ignore
     75 ;; files, but supports additions to the list using the user option
     76 ;; `project-vc-ignores' (usually through .dir-locals.el).  See the
     77 ;; customization group `project-vc' for other options that control its
     78 ;; behavior.
     79 ;;
     80 ;; If the repository is using any other VCS than Git or Hg, the file
     81 ;; listing uses the default mechanism based on `find-program'.
     82 ;;
     83 ;; This project type can also be used for non-VCS controlled
     84 ;; directories, see the variable `project-vc-extra-root-markers'.
     85 ;;
     86 ;; Utils:
     87 ;;
     88 ;; `project-combine-directories' and `project-subtract-directories',
     89 ;; mainly for use in the abovementioned generics' implementations.
     90 ;;
     91 ;; `project-known-project-roots' and `project-remember-project' to
     92 ;; interact with the "known projects" list.
     93 ;;
     94 ;; Commands:
     95 ;;
     96 ;; `project-prefix-map' contains the full list of commands defined in
     97 ;; this package.  This map uses the prefix `C-x p' by default.
     98 ;; Type `C-x p f' to find file in the current project.
     99 ;; Type `C-x p C-h' to see all available commands and bindings.
    100 ;;
    101 ;; All commands defined in this package are implemented using the
    102 ;; public API only.  As a result, they will work with any project
    103 ;; backend that follows the protocol.
    104 ;;
    105 ;; Any third-party code that wants to use this package should likewise
    106 ;; target the public API.  Use any of the built-in commands as the
    107 ;; example.
    108 ;;
    109 ;; How to create a new backend:
    110 ;;
    111 ;; - Consider whether you really should, or whether there are other
    112 ;; ways to reach your goals.  If the backend's performance is
    113 ;; significantly lower than that of the built-in one, and it's first
    114 ;; in the list, it will affect all commands that use it.  Unless you
    115 ;; are going to be using it only yourself or in special circumstances,
    116 ;; you will probably want it to be fast, and it's unlikely to be a
    117 ;; trivial endeavor.  `project-files' is the method to optimize (the
    118 ;; default implementation gets slower the more files the directory
    119 ;; has, and the longer the list of ignores is).
    120 ;;
    121 ;; - Choose the format of the value that represents a project for your
    122 ;; backend (we call it project instance).  Don't use any of the
    123 ;; formats from other backends.  The format can be arbitrary, as long
    124 ;; as the datatype is something `cl-defmethod' can dispatch on.  The
    125 ;; value should be stable (when compared with `equal') across
    126 ;; invocations, meaning calls to that function from buffers belonging
    127 ;; to the same project should return equal values.
    128 ;;
    129 ;; - Write a new function that will determine the current project
    130 ;; based on the directory and add it to `project-find-functions'
    131 ;; (which see) using `add-hook'.  It is a good idea to depend on the
    132 ;; directory only, and not on the current major mode, for example.
    133 ;; Because the usual expectation is that all files in the directory
    134 ;; belong to the same project (even if some/most of them are ignored).
    135 ;;
    136 ;; - Define new methods for some or all generic functions for this
    137 ;; backend using `cl-defmethod'.  A `project-root' method is
    138 ;; mandatory, `project-files' is recommended, the rest are optional.
    139 
    140 ;;; TODO:
    141 
    142 ;; * Reliably cache the list of files in the project, probably using
    143 ;;   filenotify.el (if supported) to invalidate.  And avoiding caching
    144 ;;   if it's not available (manual cache invalidation is not nice).
    145 ;;
    146 ;; * Build tool related functionality.  Start with a `project-build'
    147 ;;   command, which should provide completions on tasks to run, and
    148 ;;   maybe allow entering some additional arguments.  This might
    149 ;;   be handled better with a separate API, though.  Then we won't
    150 ;;   force every project backend to be aware of the build tool(s) the
    151 ;;   project is using.
    152 ;;
    153 ;; * Command to (re)build the tag files in all project roots.  To that
    154 ;;   end, we might need to add a way to provide file whitelist
    155 ;;   wildcards for each root to limit etags to certain files (in
    156 ;;   addition to the blacklist provided by ignores), and/or allow
    157 ;;   specifying additional tag regexps.
    158 ;;
    159 ;; * UI for the user to be able to pick the current project for the
    160 ;;   whole Emacs session, independent of the current directory.  Or,
    161 ;;   in the more advanced case, open a set of projects, and have some
    162 ;;   project-related commands to use them all.  E.g., have a command
    163 ;;   to search for a regexp across all open projects.
    164 ;;
    165 ;; * Support for project-local variables: a UI to edit them, and a
    166 ;;   utility function to retrieve a value.  Probably useless without
    167 ;;   support in various built-in commands.  In the API, we might get
    168 ;;   away with only adding a `project-configuration-directory' method,
    169 ;;   defaulting to the project root the current file/buffer is in.
    170 ;;   And prompting otherwise.  How to best mix that with backends that
    171 ;;   want to set/provide certain variables themselves, is up for
    172 ;;   discussion.
    173 
    174 ;;; Code:
    175 
    176 (require 'cl-generic)
    177 (require 'cl-lib)
    178 (require 'seq)
    179 (eval-when-compile (require 'subr-x))
    180 
    181 (defgroup project nil
    182   "Operations on the current project."
    183   :version "28.1"
    184   :group 'tools)
    185 
    186 (defvar project-find-functions (list #'project-try-vc)
    187   "Special hook to find the project containing a given directory.
    188 Each functions on this hook is called in turn with one
    189 argument, the directory in which to look, and should return
    190 either nil to mean that it is not applicable, or a project instance.
    191 The exact form of the project instance is up to each respective
    192 function; the only practical limitation is to use values that
    193 `cl-defmethod' can dispatch on, like a cons cell, or a list, or a
    194 CL struct.")
    195 
    196 (define-obsolete-variable-alias
    197   'project-current-inhibit-prompt
    198   'project-current-directory-override
    199   "29.1")
    200 
    201 (defvar project-current-directory-override nil
    202   "Value to use instead of `default-directory' when detecting the project.
    203 When it is non-nil, `project-current' will always skip prompting too.")
    204 
    205 ;;;###autoload
    206 (defun project-current (&optional maybe-prompt directory)
    207   "Return the project instance in DIRECTORY, defaulting to `default-directory'.
    208 
    209 When no project is found in that directory, the result depends on
    210 the value of MAYBE-PROMPT: if it is nil or omitted, return nil,
    211 else ask the user for a directory in which to look for the
    212 project, and if no project is found there, return a \"transient\"
    213 project instance.
    214 
    215 The \"transient\" project instance is a special kind of value
    216 which denotes a project rooted in that directory and includes all
    217 the files under the directory except for those that match entries
    218 in `vc-directory-exclusion-list' or `grep-find-ignored-files'.
    219 
    220 See the doc string of `project-find-functions' for the general form
    221 of the project instance object."
    222   (unless directory (setq directory (or project-current-directory-override
    223                                         default-directory)))
    224   (let ((pr (project--find-in-directory directory)))
    225     (cond
    226      (pr)
    227      ((unless project-current-directory-override
    228         maybe-prompt)
    229       (setq directory (project-prompt-project-dir)
    230             pr (project--find-in-directory directory))))
    231     (when maybe-prompt
    232       (if pr
    233           (project-remember-project pr)
    234         (project--remove-from-project-list
    235          directory "Project `%s' not found; removed from list")
    236         (setq pr (cons 'transient directory))))
    237     pr))
    238 
    239 (defun project--find-in-directory (dir)
    240   (run-hook-with-args-until-success 'project-find-functions dir))
    241 
    242 (defvar project--within-roots-fallback nil)
    243 
    244 (cl-defgeneric project-root (project)
    245   "Return root directory of the current project.
    246 
    247 It usually contains the main build file, dependencies
    248 configuration file, etc. Though neither is mandatory.
    249 
    250 The directory name must be absolute.")
    251 
    252 (cl-defmethod project-root (project
    253                             &context (project--within-roots-fallback
    254                                       (eql nil)))
    255   (car (project-roots project)))
    256 
    257 (cl-defgeneric project-roots (project)
    258   "Return the list containing the current project root.
    259 
    260 The function is obsolete, all projects have one main root anyway,
    261 and the rest should be possible to express through
    262 `project-external-roots'."
    263   ;; FIXME: Can we specify project's version here?
    264   ;; FIXME: Could we make this affect cl-defmethod calls too?
    265   (declare (obsolete project-root "0.3.0"))
    266   (let ((project--within-roots-fallback t))
    267     (list (project-root project))))
    268 
    269 ;; FIXME: Add MODE argument, like in `ede-source-paths'?
    270 (cl-defgeneric project-external-roots (_project)
    271   "Return the list of external roots for PROJECT.
    272 
    273 It's the list of directories outside of the project that are
    274 still related to it.  If the project deals with source code then,
    275 depending on the languages used, this list should include the
    276 headers search path, load path, class path, and so on."
    277   nil)
    278 
    279 (cl-defgeneric project-name (project)
    280   "A human-readable name for the project.
    281 Nominally unique, but not enforced."
    282   (file-name-nondirectory (directory-file-name (project-root project))))
    283 
    284 (cl-defgeneric project-ignores (_project _dir)
    285   "Return the list of glob patterns to ignore inside DIR.
    286 Patterns can match both regular files and directories.
    287 To root an entry, start it with `./'.  To match directories only,
    288 end it with `/'.  DIR must be either `project-root' or one of
    289 `project-external-roots'."
    290   ;; TODO: Document and support regexp ignores as used by Hg.
    291   ;; TODO: Support whitelist entries.
    292   (require 'grep)
    293   (defvar grep-find-ignored-files)
    294   (nconc
    295    (mapcar
    296     (lambda (dir)
    297       (concat dir "/"))
    298     vc-directory-exclusion-list)
    299    grep-find-ignored-files))
    300 
    301 (defun project--file-completion-table (all-files)
    302   (lambda (string pred action)
    303     (cond
    304      ((eq action 'metadata)
    305       '(metadata . ((category . project-file))))
    306      (t
    307       (complete-with-action action all-files string pred)))))
    308 
    309 (cl-defmethod project-root ((project (head transient)))
    310   (cdr project))
    311 
    312 (cl-defgeneric project-files (project &optional dirs)
    313   "Return a list of files in directories DIRS in PROJECT.
    314 DIRS is a list of absolute directories; it should be some
    315 subset of the project root and external roots.
    316 
    317 The default implementation uses `find-program'.  PROJECT is used
    318 to find the list of ignores for each directory."
    319   (mapcan
    320    (lambda (dir)
    321      (project--files-in-directory dir
    322                                   (project--dir-ignores project dir)))
    323    (or dirs
    324        (list (project-root project)))))
    325 
    326 (defun project--files-in-directory (dir ignores &optional files)
    327   (require 'find-dired)
    328   (require 'xref)
    329   (let* ((default-directory dir)
    330          ;; Make sure ~/ etc. in local directory name is
    331          ;; expanded and not left for the shell command
    332          ;; to interpret.
    333          (localdir (file-name-unquote (file-local-name (expand-file-name dir))))
    334          (dfn (directory-file-name localdir))
    335          (command (format "%s -H . %s -type f %s -print0"
    336                           find-program
    337                           (xref--find-ignores-arguments ignores "./")
    338                           (if files
    339                               (concat (shell-quote-argument "(")
    340                                       " -name "
    341                                       (mapconcat
    342                                        #'shell-quote-argument
    343                                        (split-string files)
    344                                        (concat " -o -name "))
    345                                       " "
    346                                       (shell-quote-argument ")"))
    347                             "")))
    348          res)
    349     (with-temp-buffer
    350       (let ((status
    351              (process-file-shell-command command nil t))
    352             (pt (point-min)))
    353         (unless (zerop status)
    354           (goto-char (point-min))
    355           (if (and
    356                (not (eql status 127))
    357                (search-forward "Permission denied\n" nil t))
    358               (let ((end (1- (point))))
    359                 (re-search-backward "\\`\\|\0")
    360                 (error "File listing failed: %s"
    361                        (buffer-substring (1+ (point)) end)))
    362             (error "File listing failed: %s" (buffer-string))))
    363         (goto-char pt)
    364         (while (search-forward "\0" nil t)
    365           (push (buffer-substring-no-properties (1+ pt) (1- (point)))
    366                 res)
    367           (setq pt (point)))))
    368     (project--remote-file-names
    369      (mapcar (lambda (s) (concat dfn s))
    370              (sort res #'string<)))))
    371 
    372 (defun project--remote-file-names (local-files)
    373   "Return LOCAL-FILES as if they were on the system of `default-directory'.
    374 Also quote LOCAL-FILES if `default-directory' is quoted."
    375   (let ((remote-id (file-remote-p default-directory)))
    376     (if (not remote-id)
    377         (if (file-name-quoted-p default-directory)
    378             (mapcar #'file-name-quote local-files)
    379           local-files)
    380       (mapcar (lambda (file)
    381                 (concat remote-id file))
    382               local-files))))
    383 
    384 (cl-defgeneric project-buffers (project)
    385   "Return the list of all live buffers that belong to PROJECT.
    386 
    387 The default implementation matches each buffer to PROJECT root using
    388 the buffer's value of `default-directory'."
    389   (let ((root (expand-file-name (file-name-as-directory (project-root project))))
    390         bufs)
    391     (dolist (buf (buffer-list))
    392       (when (string-prefix-p root (expand-file-name
    393                                    (buffer-local-value 'default-directory buf)))
    394         (push buf bufs)))
    395     (nreverse bufs)))
    396 
    397 (defgroup project-vc nil
    398   "VC-aware project implementation."
    399   :version "25.1"
    400   :group 'project)
    401 
    402 (defcustom project-vc-ignores nil
    403   "List of patterns to add to `project-ignores'."
    404   :type '(repeat string)
    405   :safe #'listp)
    406 
    407 (defcustom project-vc-merge-submodules t
    408   "Non-nil to consider submodules part of the parent project.
    409 
    410 After changing this variable (using Customize or .dir-locals.el)
    411 you might have to restart Emacs to see the effect."
    412   :type 'boolean
    413   :version "28.1"
    414   :package-version '(project . "0.2.0")
    415   :safe #'booleanp)
    416 
    417 (defcustom project-vc-include-untracked t
    418   "When non-nil, the VC-aware project backend includes untracked files."
    419   :type 'boolean
    420   :version "29.1"
    421   :safe #'booleanp)
    422 
    423 (defcustom project-vc-name nil
    424   "When non-nil, the name of the current VC-aware project.
    425 
    426 The best way to change the value a VC-aware project reports as
    427 its name, is by setting this in .dir-locals.el."
    428   :type '(choice (const :tag "Default to the base name" nil)
    429                  (string :tag "Custom name"))
    430   :version "29.1"
    431   :package-version '(project . "0.9.0")
    432   :safe #'stringp)
    433 
    434 ;; Not using regexps because these wouldn't work in Git pathspecs, in
    435 ;; case we decide we need to be able to list nested projects.
    436 (defcustom project-vc-extra-root-markers nil
    437   "List of additional markers to signal project roots.
    438 
    439 A marker is either a base file name or a glob pattern for such.
    440 
    441 A directory containing such a marker file or a file matching a
    442 marker pattern will be recognized as the root of a VC-aware
    443 project.
    444 
    445 Example values: \".dir-locals.el\", \"package.json\", \"pom.xml\",
    446 \"requirements.txt\", \"Gemfile\", \"*.gemspec\", \"autogen.sh\".
    447 
    448 These will be used in addition to regular directory markers such
    449 as \".git\", \".hg\", and so on, depending on the value of
    450 `vc-handled-backends'.  It is most useful when a project has
    451 subdirectories inside it that need to be considered as separate
    452 projects.  It can also be used for projects outside of VC
    453 repositories.
    454 
    455 In either case, their behavior will still obey the relevant
    456 variables, such as `project-vc-ignores' or `project-vc-name'."
    457   :type '(repeat string)
    458   :version "29.1"
    459   :package-version '(project . "0.9.0")
    460   :safe (lambda (val) (and (listp val) (cl-every #'stringp val))))
    461 
    462 ;; FIXME: Using the current approach, major modes are supposed to set
    463 ;; this variable to a buffer-local value.  So we don't have access to
    464 ;; the "external roots" of language A from buffers of language B, which
    465 ;; seems desirable in multi-language projects, at least for some
    466 ;; potential uses, like "jump to a file in project or external dirs".
    467 ;;
    468 ;; We could add a second argument to this function: a file extension,
    469 ;; or a language name.  Some projects will know the set of languages
    470 ;; used in them; for others, like the VC-aware type, we'll need
    471 ;; auto-detection.  I see two options:
    472 ;;
    473 ;; - That could be implemented as a separate second hook, with a
    474 ;;   list of functions that return file extensions.
    475 ;;
    476 ;; - This variable will be turned into a hook with "append" semantics,
    477 ;;   and each function in it will perform auto-detection when passed
    478 ;;   nil instead of an actual file extension.  Then this hook will, in
    479 ;;   general, be modified globally, and not from major mode functions.
    480 ;;
    481 ;; The second option seems simpler, but the first one has the
    482 ;; advantage that the user could override the list of languages used
    483 ;; in a project via a directory-local variable, thus skipping
    484 ;; languages they're not working on personally (in a big project), or
    485 ;; working around problems in language detection (the detection logic
    486 ;; might be imperfect for the project in question, or it might work
    487 ;; too slowly for the user's taste).
    488 (defvar project-vc-external-roots-function (lambda () tags-table-list)
    489   "Function that returns a list of external roots.
    490 
    491 It should return a list of directory roots that contain source
    492 files related to the current buffer.
    493 
    494 The directory names should be absolute.  Used in the VC-aware
    495 project backend implementation of `project-external-roots'.")
    496 
    497 (defun project-try-vc (dir)
    498   (defvar vc-svn-admin-directory)
    499   (require 'vc-svn)
    500   ;; FIXME: Learn to invalidate when the value of
    501   ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'
    502   ;; changes.
    503   (or (vc-file-getprop dir 'project-vc)
    504       (let* ((backend-markers-alist `((Git . ".git")
    505                                       (Hg . ".hg")
    506                                       (Bzr . ".bzr")
    507                                       (SVN . ,vc-svn-admin-directory)
    508                                       (DARCS . "_darcs")
    509                                       (Fossil . ".fslckout")))
    510              (backend-markers
    511               (delete
    512                nil
    513                (mapcar
    514                 (lambda (b) (assoc-default b backend-markers-alist))
    515                 vc-handled-backends)))
    516              (marker-re
    517               (mapconcat
    518                (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m)))
    519                (append backend-markers
    520                        (project--value-in-dir 'project-vc-extra-root-markers dir))
    521                "\\|"))
    522              (locate-dominating-stop-dir-regexp
    523               (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))
    524              last-matches
    525              (root
    526               (locate-dominating-file
    527                dir
    528                (lambda (d)
    529                  ;; Maybe limit count to 100 when we can drop Emacs < 28.
    530                  (setq last-matches (directory-files d nil marker-re t)))))
    531              (backend
    532               (cl-find-if
    533                (lambda (b)
    534                  (member (assoc-default b backend-markers-alist)
    535                          last-matches))
    536                vc-handled-backends))
    537              project)
    538         (when (and
    539                (eq backend 'Git)
    540                (project--vc-merge-submodules-p root)
    541                (project--submodule-p root))
    542           (let* ((parent (file-name-directory (directory-file-name root))))
    543             (setq root (vc-call-backend 'Git 'root parent))))
    544         (when root
    545           (setq project (list 'vc backend root))
    546           ;; FIXME: Cache for a shorter time.
    547           (vc-file-setprop dir 'project-vc project)
    548           project))))
    549 
    550 (defun project--submodule-p (root)
    551   ;; XXX: We only support Git submodules for now.
    552   ;;
    553   ;; For submodules, at least, we expect the users to prefer them to
    554   ;; be considered part of the parent project.  For those who don't,
    555   ;; there is the custom var now.
    556   ;;
    557   ;; Some users may also set up things equivalent to Git submodules
    558   ;; using "git worktree" (for example).  However, we expect that most
    559   ;; of them would prefer to treat those as separate projects anyway.
    560   (let* ((gitfile (expand-file-name ".git" root)))
    561     (cond
    562      ((file-directory-p gitfile)
    563       nil)
    564      ((with-temp-buffer
    565         (insert-file-contents gitfile)
    566         (goto-char (point-min))
    567         ;; Kind of a hack to distinguish a submodule from
    568         ;; other cases of .git files pointing elsewhere.
    569         (looking-at "gitdir: [./]+/\\.git/modules/"))
    570       t)
    571      (t nil))))
    572 
    573 (cl-defmethod project-root ((project (head vc)))
    574   (nth 2 project))
    575 
    576 (cl-defmethod project-external-roots ((project (head vc)))
    577   (project-subtract-directories
    578    (project-combine-directories
    579     (mapcar
    580      #'file-name-as-directory
    581      (funcall project-vc-external-roots-function)))
    582    (list (project-root project))))
    583 
    584 (cl-defmethod project-files ((project (head vc)) &optional dirs)
    585   (mapcan
    586    (lambda (dir)
    587      (let ((ignores (project--value-in-dir 'project-vc-ignores (nth 2 project)))
    588            (backend (cadr project)))
    589        (when backend
    590          (require (intern (concat "vc-" (downcase (symbol-name backend))))))
    591        (if (and (file-equal-p dir (nth 2 project))
    592                 (cond
    593                  ((eq backend 'Hg))
    594                  ((and (eq backend 'Git)
    595                        (or
    596                         (not ignores)
    597                         (version<= "1.9" (vc-git--program-version)))))))
    598            (project--vc-list-files dir backend ignores)
    599          (project--files-in-directory
    600           dir
    601           (project--dir-ignores project dir)))))
    602    (or dirs
    603        (list (project-root project)))))
    604 
    605 (declare-function vc-git--program-version "vc-git")
    606 (declare-function vc-git--run-command-string "vc-git")
    607 (declare-function vc-hg-command "vc-hg")
    608 
    609 (defun project--vc-list-files (dir backend extra-ignores)
    610   (defvar vc-git-use-literal-pathspecs)
    611   (pcase backend
    612     (`Git
    613      (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
    614             (args '("-z"))
    615             (vc-git-use-literal-pathspecs nil)
    616             (include-untracked (project--value-in-dir
    617                                 'project-vc-include-untracked
    618                                 dir))
    619             files)
    620        (setq args (append args
    621                           '("-c" "--exclude-standard")
    622                           (and include-untracked '("-o"))))
    623        (when extra-ignores
    624          (setq args (append args
    625                             (cons "--"
    626                                   (mapcar
    627                                    (lambda (i)
    628                                      (format
    629                                       ":(exclude,glob,top)%s"
    630                                       (if (string-match "\\*\\*" i)
    631                                           ;; Looks like pathspec glob
    632                                           ;; format already.
    633                                           i
    634                                         (if (string-match "\\./" i)
    635                                             ;; ./abc -> abc
    636                                             (setq i (substring i 2))
    637                                           ;; abc -> **/abc
    638                                           (setq i (concat "**/" i))
    639                                           ;; FIXME: '**/abc' should also
    640                                           ;; match a directory with that
    641                                           ;; name, but doesn't (git 2.25.1).
    642                                           ;; Maybe we should replace
    643                                           ;; such entries with two.
    644                                           (if (string-match "/\\'" i)
    645                                               ;; abc/ -> abc/**
    646                                               (setq i (concat i "**"))))
    647                                         i)))
    648                                    extra-ignores)))))
    649        (setq files
    650              (mapcar
    651               (lambda (file) (concat default-directory file))
    652               (split-string
    653                (apply #'vc-git--run-command-string nil "ls-files" args)
    654                "\0" t)))
    655        (when (project--vc-merge-submodules-p default-directory)
    656          ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
    657          (let* ((submodules (project--git-submodules))
    658                 (sub-files
    659                  (mapcar
    660                   (lambda (module)
    661                     (when (file-directory-p module)
    662                       (project--vc-list-files
    663                        (concat default-directory module)
    664                        backend
    665                        extra-ignores)))
    666                   submodules)))
    667            (setq files
    668                  (apply #'nconc files sub-files))))
    669        ;; 'git ls-files' returns duplicate entries for merge conflicts.
    670        ;; XXX: Better solutions welcome, but this seems cheap enough.
    671        (delete-consecutive-dups files)))
    672     (`Hg
    673      (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
    674             (include-untracked (project--value-in-dir
    675                                 'project-vc-include-untracked
    676                                 dir))
    677             (args (list (concat "-mcard" (and include-untracked "u"))
    678                         "--no-status"
    679                         "-0")))
    680        (when extra-ignores
    681          (setq args (nconc args
    682                            (mapcan
    683                             (lambda (i)
    684                               (list "--exclude" i))
    685                             extra-ignores))))
    686        (with-temp-buffer
    687          (apply #'vc-hg-command t 0 "." "status" args)
    688          (mapcar
    689           (lambda (s) (concat default-directory s))
    690           (split-string (buffer-string) "\0" t)))))))
    691 
    692 (defun project--vc-merge-submodules-p (dir)
    693   (project--value-in-dir
    694    'project-vc-merge-submodules
    695    dir))
    696 
    697 (defun project--git-submodules ()
    698   ;; 'git submodule foreach' is much slower.
    699   (condition-case nil
    700       (with-temp-buffer
    701         (insert-file-contents ".gitmodules")
    702         (let (res)
    703           (goto-char (point-min))
    704           (while (re-search-forward "^[ \t]*path *= *\\(.+\\)" nil t)
    705             (push (match-string 1) res))
    706           (nreverse res)))
    707     (file-missing nil)))
    708 
    709 (cl-defmethod project-ignores ((project (head vc)) dir)
    710   (let* ((root (nth 2 project))
    711          backend)
    712     (append
    713      (when (and backend
    714                 (file-equal-p dir root))
    715        (setq backend (cadr project))
    716        (delq
    717         nil
    718         (mapcar
    719          (lambda (entry)
    720            (cond
    721             ((eq ?! (aref entry 0))
    722              ;; No support for whitelisting (yet).
    723              nil)
    724             ((string-match "\\(/\\)[^/]" entry)
    725              ;; FIXME: This seems to be Git-specific.
    726              ;; And / in the entry (start or even the middle) means
    727              ;; the pattern is "rooted".  Or actually it is then
    728              ;; relative to its respective .gitignore (of which there
    729              ;; could be several), but we only support .gitignore at
    730              ;; the root.
    731              (if (= (match-beginning 0) 0)
    732                  (replace-match "./" t t entry 1)
    733                (concat "./" entry)))
    734             (t entry)))
    735          (condition-case nil
    736              (vc-call-backend backend 'ignore-completion-table root)
    737            (vc-not-supported () nil)))))
    738      (project--value-in-dir 'project-vc-ignores root)
    739      (mapcar
    740       (lambda (dir)
    741         (concat dir "/"))
    742       vc-directory-exclusion-list))))
    743 
    744 (defun project-combine-directories (&rest lists-of-dirs)
    745   "Return a sorted and culled list of directory names.
    746 Appends the elements of LISTS-OF-DIRS together, removes
    747 non-existing directories, as well as directories a parent of
    748 whose is already in the list."
    749   (let* ((dirs (sort
    750                 (mapcar
    751                  (lambda (dir)
    752                    (file-name-as-directory (expand-file-name dir)))
    753                  (apply #'append lists-of-dirs))
    754                 #'string<))
    755          (ref dirs))
    756     ;; Delete subdirectories from the list.
    757     (while (cdr ref)
    758       (if (string-prefix-p (car ref) (cadr ref))
    759           (setcdr ref (cddr ref))
    760         (setq ref (cdr ref))))
    761     (cl-delete-if-not #'file-exists-p dirs)))
    762 
    763 (defun project-subtract-directories (files dirs)
    764   "Return a list of elements from FILES that are outside of DIRS.
    765 DIRS must contain directory names."
    766   ;; Sidestep the issue of expanded/abbreviated file names here.
    767   (cl-set-difference files dirs :test #'file-in-directory-p))
    768 
    769 (defun project--value-in-dir (var dir)
    770   (with-temp-buffer
    771     (setq default-directory dir)
    772     (let ((enable-local-variables :all))
    773       (hack-dir-local-variables-non-file-buffer))
    774     (symbol-value var)))
    775 
    776 (cl-defmethod project-buffers ((project (head vc)))
    777   (let* ((root (expand-file-name (file-name-as-directory (project-root project))))
    778          (modules (unless (or (project--vc-merge-submodules-p root)
    779                               (project--submodule-p root))
    780                     (mapcar
    781                      (lambda (m) (format "%s%s/" root m))
    782                      (project--git-submodules))))
    783          dd
    784          bufs)
    785     (dolist (buf (buffer-list))
    786       (setq dd (expand-file-name (buffer-local-value 'default-directory buf)))
    787       (when (and (string-prefix-p root dd)
    788                  (not (cl-find-if (lambda (module) (string-prefix-p module dd))
    789                                   modules)))
    790         (push buf bufs)))
    791     (nreverse bufs)))
    792 
    793 (cl-defmethod project-name ((_project (head vc)))
    794   (or project-vc-name
    795       (cl-call-next-method)))
    796 
    797 
    798 ;;; Project commands
    799 
    800 ;;;###autoload
    801 (defvar project-prefix-map
    802   (let ((map (make-sparse-keymap)))
    803     (define-key map "!" 'project-shell-command)
    804     (define-key map "&" 'project-async-shell-command)
    805     (define-key map "f" 'project-find-file)
    806     (define-key map "F" 'project-or-external-find-file)
    807     (define-key map "b" 'project-switch-to-buffer)
    808     (define-key map "s" 'project-shell)
    809     (define-key map "d" 'project-find-dir)
    810     (define-key map "D" 'project-dired)
    811     (define-key map "v" 'project-vc-dir)
    812     (define-key map "c" 'project-compile)
    813     (define-key map "e" 'project-eshell)
    814     (define-key map "k" 'project-kill-buffers)
    815     (define-key map "p" 'project-switch-project)
    816     (define-key map "g" 'project-find-regexp)
    817     (define-key map "G" 'project-or-external-find-regexp)
    818     (define-key map "r" 'project-query-replace-regexp)
    819     (define-key map "x" 'project-execute-extended-command)
    820     (define-key map "\C-b" 'project-list-buffers)
    821     map)
    822   "Keymap for project commands.")
    823 
    824 ;;;###autoload (define-key ctl-x-map "p" project-prefix-map)
    825 
    826 ;; We can't have these place-specific maps inherit from
    827 ;; project-prefix-map because project--other-place-command needs to
    828 ;; know which map the key binding came from, as if it came from one of
    829 ;; these maps, we don't want to set display-buffer-overriding-action
    830 
    831 (defvar project-other-window-map
    832   (let ((map (make-sparse-keymap)))
    833     (define-key map "\C-o" #'project-display-buffer)
    834     map)
    835   "Keymap for project commands that display buffers in other windows.")
    836 
    837 (defvar project-other-frame-map
    838   (let ((map (make-sparse-keymap)))
    839     (define-key map "\C-o" #'project-display-buffer-other-frame)
    840     map)
    841   "Keymap for project commands that display buffers in other frames.")
    842 
    843 (defun project--other-place-command (action &optional map)
    844   (let* ((key (read-key-sequence-vector nil t))
    845          (place-cmd (lookup-key map key))
    846          (generic-cmd (lookup-key project-prefix-map key))
    847          (switch-to-buffer-obey-display-actions t)
    848          (display-buffer-overriding-action (unless place-cmd action)))
    849     (if-let ((cmd (or place-cmd generic-cmd)))
    850         (call-interactively cmd)
    851       (user-error "%s is undefined" (key-description key)))))
    852 
    853 ;;;###autoload
    854 (defun project-other-window-command ()
    855   "Run project command, displaying resultant buffer in another window.
    856 
    857 The following commands are available:
    858 
    859 \\{project-prefix-map}
    860 \\{project-other-window-map}"
    861   (interactive)
    862   (project--other-place-command '((display-buffer-pop-up-window)
    863                                   (inhibit-same-window . t))
    864                                 project-other-window-map))
    865 
    866 ;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command)
    867 
    868 ;;;###autoload
    869 (defun project-other-frame-command ()
    870   "Run project command, displaying resultant buffer in another frame.
    871 
    872 The following commands are available:
    873 
    874 \\{project-prefix-map}
    875 \\{project-other-frame-map}"
    876   (interactive)
    877   (project--other-place-command '((display-buffer-pop-up-frame))
    878                                 project-other-frame-map))
    879 
    880 ;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command)
    881 
    882 ;;;###autoload
    883 (defun project-other-tab-command ()
    884   "Run project command, displaying resultant buffer in a new tab.
    885 
    886 The following commands are available:
    887 
    888 \\{project-prefix-map}"
    889   (interactive)
    890   (project--other-place-command '((display-buffer-in-new-tab))))
    891 
    892 ;;;###autoload
    893 (when (bound-and-true-p tab-prefix-map)
    894   (define-key tab-prefix-map "p" #'project-other-tab-command))
    895 
    896 (declare-function grep-read-files "grep")
    897 (declare-function xref--find-ignores-arguments "xref")
    898 
    899 ;;;###autoload
    900 (defun project-find-regexp (regexp)
    901   "Find all matches for REGEXP in the current project's roots.
    902 With \\[universal-argument] prefix, you can specify the directory
    903 to search in, and the file name pattern to search for.  The
    904 pattern may use abbreviations defined in `grep-files-aliases',
    905 e.g. entering `ch' is equivalent to `*.[ch]'.  As whitespace
    906 triggers completion when entering a pattern, including it
    907 requires quoting, e.g. `\\[quoted-insert]<space>'."
    908   (interactive (list (project--read-regexp)))
    909   (require 'xref)
    910   (require 'grep)
    911   (let* ((caller-dir default-directory)
    912          (pr (project-current t))
    913          (default-directory (project-root pr))
    914          (files
    915           (if (not current-prefix-arg)
    916               (project-files pr)
    917             (let ((dir (read-directory-name "Base directory: "
    918                                             caller-dir nil t)))
    919               (project--files-in-directory dir
    920                                            nil
    921                                            (grep-read-files regexp))))))
    922     (xref-show-xrefs
    923      (apply-partially #'project--find-regexp-in-files regexp files)
    924      nil)))
    925 
    926 (defun project--dir-ignores (project dir)
    927   (let ((root (project-root project)))
    928     (if (not (file-in-directory-p dir root))
    929         (project-ignores nil nil)       ;The defaults.
    930       (let ((ignores (project-ignores project root)))
    931         (if (file-equal-p root dir)
    932             ignores
    933           ;; FIXME: Update the "rooted" ignores to relate to DIR instead.
    934           (cl-delete-if (lambda (str) (string-prefix-p "./" str))
    935                         ignores))))))
    936 
    937 ;;;###autoload
    938 (defun project-or-external-find-regexp (regexp)
    939   "Find all matches for REGEXP in the project roots or external roots.
    940 With \\[universal-argument] prefix, you can specify the file name
    941 pattern to search for."
    942   (interactive (list (project--read-regexp)))
    943   (require 'xref)
    944   (let* ((pr (project-current t))
    945          (default-directory (project-root pr))
    946          (files
    947           (project-files pr (cons
    948                              (project-root pr)
    949                              (project-external-roots pr)))))
    950     (xref-show-xrefs
    951      (apply-partially #'project--find-regexp-in-files regexp files)
    952      nil)))
    953 
    954 (defun project--find-regexp-in-files (regexp files)
    955   (unless files
    956     (user-error "Empty file list"))
    957   (let ((xrefs (xref-matches-in-files regexp files)))
    958     (unless xrefs
    959       (user-error "No matches for: %s" regexp))
    960     xrefs))
    961 
    962 (defvar project-regexp-history-variable 'grep-regexp-history)
    963 
    964 (defun project--read-regexp ()
    965   (let ((sym (thing-at-point 'symbol t)))
    966     (read-regexp "Find regexp" (and sym (regexp-quote sym))
    967                  project-regexp-history-variable)))
    968 
    969 ;;;###autoload
    970 (defun project-find-file (&optional include-all)
    971   "Visit a file (with completion) in the current project.
    972 
    973 The filename at point (determined by `thing-at-point'), if any,
    974 is available as part of \"future history\".
    975 
    976 If INCLUDE-ALL is non-nil, or with prefix argument when called
    977 interactively, include all files under the project root, except
    978 for VCS directories listed in `vc-directory-exclusion-list'."
    979   (interactive "P")
    980   (let* ((pr (project-current t))
    981          (root (project-root pr))
    982          (dirs (list root)))
    983     (project-find-file-in
    984      (or (thing-at-point 'filename)
    985          (and buffer-file-name (file-relative-name buffer-file-name root)))
    986      dirs pr include-all)))
    987 
    988 ;;;###autoload
    989 (defun project-or-external-find-file (&optional include-all)
    990   "Visit a file (with completion) in the current project or external roots.
    991 
    992 The filename at point (determined by `thing-at-point'), if any,
    993 is available as part of \"future history\".
    994 
    995 If INCLUDE-ALL is non-nil, or with prefix argument when called
    996 interactively, include all files under the project root, except
    997 for VCS directories listed in `vc-directory-exclusion-list'."
    998   (interactive "P")
    999   (let* ((pr (project-current t))
   1000          (dirs (cons
   1001                 (project-root pr)
   1002                 (project-external-roots pr))))
   1003     (project-find-file-in (thing-at-point 'filename) dirs pr include-all)))
   1004 
   1005 (defcustom project-read-file-name-function #'project--read-file-cpd-relative
   1006   "Function to call to read a file name from a list.
   1007 For the arguments list, see `project--read-file-cpd-relative'."
   1008   :type '(choice (const :tag "Read with completion from relative names"
   1009                         project--read-file-cpd-relative)
   1010                  (const :tag "Read with completion from absolute names"
   1011                         project--read-file-absolute)
   1012                  (function :tag "Custom function" nil))
   1013   :group 'project
   1014   :version "27.1")
   1015 
   1016 (defun project--read-file-cpd-relative (prompt
   1017                                         all-files &optional predicate
   1018                                         hist mb-default)
   1019   "Read a file name, prompting with PROMPT.
   1020 ALL-FILES is a list of possible file name completions.
   1021 
   1022 PREDICATE and HIST have the same meaning as in `completing-read'.
   1023 
   1024 MB-DEFAULT is used as part of \"future history\", to be inserted
   1025 by the user at will."
   1026   (let* ((common-parent-directory
   1027           (let ((common-prefix (try-completion "" all-files)))
   1028             (if (> (length common-prefix) 0)
   1029                 (file-name-directory common-prefix))))
   1030          (cpd-length (length common-parent-directory))
   1031          (prompt (if (zerop cpd-length)
   1032                      prompt
   1033                    (concat prompt (format " in %s" common-parent-directory))))
   1034          (included-cpd (when (member common-parent-directory all-files)
   1035                          (setq all-files
   1036                                (delete common-parent-directory all-files))
   1037                          t))
   1038          (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
   1039          (_ (when included-cpd
   1040               (setq substrings (cons "./" substrings))))
   1041          (new-collection (project--file-completion-table substrings))
   1042          (abbr-cpd (abbreviate-file-name common-parent-directory))
   1043          (abbr-cpd-length (length abbr-cpd))
   1044          (relname (cl-letf ((history-add-new-input nil)
   1045                             ((symbol-value hist)
   1046                              (mapcan
   1047                               (lambda (s)
   1048                                 (and (string-prefix-p abbr-cpd s)
   1049                                      (not (eq abbr-cpd-length (length s)))
   1050                                      (list (substring s abbr-cpd-length))))
   1051                               (symbol-value hist))))
   1052                     (project--completing-read-strict prompt
   1053                                                      new-collection
   1054                                                      predicate
   1055                                                      hist mb-default)))
   1056          (absname (expand-file-name relname common-parent-directory)))
   1057     (when (and hist history-add-new-input)
   1058       (add-to-history hist (abbreviate-file-name absname)))
   1059     absname))
   1060 
   1061 (defun project--read-file-absolute (prompt
   1062                                     all-files &optional predicate
   1063                                     hist mb-default)
   1064   (project--completing-read-strict prompt
   1065                                    (project--file-completion-table all-files)
   1066                                    predicate
   1067                                    hist mb-default))
   1068 
   1069 (defun project-find-file-in (suggested-filename dirs project &optional include-all)
   1070   "Complete a file name in DIRS in PROJECT and visit the result.
   1071 
   1072 SUGGESTED-FILENAME is a relative file name, or part of it, which
   1073 is used as part of \"future history\".
   1074 
   1075 If INCLUDE-ALL is non-nil, or with prefix argument when called
   1076 interactively, include all files from DIRS, except for VCS
   1077 directories listed in `vc-directory-exclusion-list'."
   1078   (let* ((vc-dirs-ignores (mapcar
   1079                            (lambda (dir)
   1080                              (concat dir "/"))
   1081                            vc-directory-exclusion-list))
   1082          (all-files
   1083           (if include-all
   1084               (mapcan
   1085                (lambda (dir) (project--files-in-directory dir vc-dirs-ignores))
   1086                dirs)
   1087             (project-files project dirs)))
   1088          (completion-ignore-case read-file-name-completion-ignore-case)
   1089          (file (funcall project-read-file-name-function
   1090                         "Find file" all-files nil 'file-name-history
   1091                         suggested-filename)))
   1092     (if (string= file "")
   1093         (user-error "You didn't specify the file")
   1094       (find-file file))))
   1095 
   1096 (defun project--completing-read-strict (prompt
   1097                                         collection &optional predicate
   1098                                         hist mb-default)
   1099   (minibuffer-with-setup-hook
   1100       (lambda ()
   1101         (setq-local minibuffer-default-add-function
   1102                     (lambda ()
   1103                       (let ((minibuffer-default mb-default))
   1104                         (minibuffer-default-add-completions)))))
   1105     (completing-read (format "%s: " prompt)
   1106                      collection predicate 'confirm
   1107                      nil
   1108                      hist)))
   1109 
   1110 ;;;###autoload
   1111 (defun project-find-dir ()
   1112   "Start Dired in a directory inside the current project."
   1113   (interactive)
   1114   (let* ((project (project-current t))
   1115          (all-files (project-files project))
   1116          (completion-ignore-case read-file-name-completion-ignore-case)
   1117          ;; FIXME: This misses directories without any files directly
   1118          ;; inside.  Consider DIRS-ONLY as an argument for
   1119          ;; `project-files-filtered', and see
   1120          ;; https://stackoverflow.com/a/50685235/615245 for possible
   1121          ;; implementation.
   1122          (all-dirs (mapcar #'file-name-directory all-files))
   1123          (dir (funcall project-read-file-name-function
   1124                        "Dired"
   1125                        ;; Some completion UIs show duplicates.
   1126                        (delete-dups all-dirs)
   1127                        nil 'file-name-history)))
   1128     (dired dir)))
   1129 
   1130 ;;;###autoload
   1131 (defun project-dired ()
   1132   "Start Dired in the current project's root."
   1133   (interactive)
   1134   (dired (project-root (project-current t))))
   1135 
   1136 ;;;###autoload
   1137 (defun project-vc-dir ()
   1138   "Run VC-Dir in the current project's root."
   1139   (interactive)
   1140   (vc-dir (project-root (project-current t))))
   1141 
   1142 (declare-function comint-check-proc "comint")
   1143 
   1144 ;;;###autoload
   1145 (defun project-shell ()
   1146   "Start an inferior shell in the current project's root directory.
   1147 If a buffer already exists for running a shell in the project's root,
   1148 switch to it.  Otherwise, create a new shell buffer.
   1149 With \\[universal-argument] prefix arg, create a new inferior shell buffer even
   1150 if one already exists."
   1151   (interactive)
   1152   (require 'comint)
   1153   (let* ((default-directory (project-root (project-current t)))
   1154          (default-project-shell-name (project-prefixed-buffer-name "shell"))
   1155          (shell-buffer (get-buffer default-project-shell-name)))
   1156     (if (and shell-buffer (not current-prefix-arg))
   1157         (if (comint-check-proc shell-buffer)
   1158             (pop-to-buffer shell-buffer (bound-and-true-p display-comint-buffer-action))
   1159           (shell shell-buffer))
   1160       (shell (generate-new-buffer-name default-project-shell-name)))))
   1161 
   1162 ;;;###autoload
   1163 (defun project-eshell ()
   1164   "Start Eshell in the current project's root directory.
   1165 If a buffer already exists for running Eshell in the project's root,
   1166 switch to it.  Otherwise, create a new Eshell buffer.
   1167 With \\[universal-argument] prefix arg, create a new Eshell buffer even
   1168 if one already exists."
   1169   (interactive)
   1170   (defvar eshell-buffer-name)
   1171   (let* ((default-directory (project-root (project-current t)))
   1172          (eshell-buffer-name (project-prefixed-buffer-name "eshell"))
   1173          (eshell-buffer (get-buffer eshell-buffer-name)))
   1174     (if (and eshell-buffer (not current-prefix-arg))
   1175         (pop-to-buffer eshell-buffer (bound-and-true-p display-comint-buffer-action))
   1176       (eshell t))))
   1177 
   1178 ;;;###autoload
   1179 (defun project-async-shell-command ()
   1180   "Run `async-shell-command' in the current project's root directory."
   1181   (declare (interactive-only async-shell-command))
   1182   (interactive)
   1183   (let ((default-directory (project-root (project-current t))))
   1184     (call-interactively #'async-shell-command)))
   1185 
   1186 ;;;###autoload
   1187 (defun project-shell-command ()
   1188   "Run `shell-command' in the current project's root directory."
   1189   (declare (interactive-only shell-command))
   1190   (interactive)
   1191   (let ((default-directory (project-root (project-current t))))
   1192     (call-interactively #'shell-command)))
   1193 
   1194 (declare-function fileloop-continue "fileloop" ())
   1195 
   1196 ;;;###autoload
   1197 (defun project-search (regexp)
   1198   "Search for REGEXP in all the files of the project.
   1199 Stops when a match is found.
   1200 To continue searching for the next match, use the
   1201 command \\[fileloop-continue]."
   1202   (interactive "sSearch (regexp): ")
   1203   (fileloop-initialize-search
   1204    regexp (project-files (project-current t)) 'default)
   1205   (fileloop-continue))
   1206 
   1207 ;;;###autoload
   1208 (defun project-query-replace-regexp (from to)
   1209   "Query-replace REGEXP in all the files of the project.
   1210 Stops when a match is found and prompts for whether to replace it.
   1211 At that prompt, the user must type a character saying what to do
   1212 with the match.  Type SPC or `y' to replace the match,
   1213 DEL or `n' to skip and go to the next match.  For more directions,
   1214 type \\[help-command] at that time.
   1215 If you exit the `query-replace', you can later continue the
   1216 `query-replace' loop using the command \\[fileloop-continue]."
   1217   (interactive
   1218    (let ((query-replace-read-from-regexp-default 'find-tag-default-as-regexp))
   1219      (pcase-let ((`(,from ,to)
   1220                   (query-replace-read-args "Query replace (regexp)" t t)))
   1221        (list from to))))
   1222   (fileloop-initialize-replace
   1223    from to
   1224    ;; XXX: Filter out Git submodules, which are not regular files.
   1225    ;; `project-files' can return those, which is arguably suboptimal,
   1226    ;; but removing them eagerly has performance cost.
   1227    (cl-delete-if-not #'file-regular-p (project-files (project-current t)))
   1228    'default)
   1229   (fileloop-continue))
   1230 
   1231 (defvar compilation-read-command)
   1232 (declare-function compilation-read-command "compile")
   1233 
   1234 (defun project-prefixed-buffer-name (mode)
   1235   (concat "*"
   1236           (file-name-nondirectory
   1237            (directory-file-name default-directory))
   1238           "-"
   1239           (downcase mode)
   1240           "*"))
   1241 
   1242 (defcustom project-compilation-buffer-name-function nil
   1243   "Function to compute the name of a project compilation buffer.
   1244 If non-nil, it overrides `compilation-buffer-name-function' for
   1245 `project-compile'."
   1246   :version "28.1"
   1247   :group 'project
   1248   :type '(choice (const :tag "Default" nil)
   1249                  (const :tag "Prefixed with root directory name"
   1250                         project-prefixed-buffer-name)
   1251                  (function :tag "Custom function")))
   1252 
   1253 ;;;###autoload
   1254 (defun project-compile ()
   1255   "Run `compile' in the project root."
   1256   (declare (interactive-only compile))
   1257   (interactive)
   1258   (let ((default-directory (project-root (project-current t)))
   1259         (compilation-buffer-name-function
   1260          (or project-compilation-buffer-name-function
   1261              compilation-buffer-name-function)))
   1262     (call-interactively #'compile)))
   1263 
   1264 (defcustom project-ignore-buffer-conditions nil
   1265   "List of conditions to filter the buffers to be switched to.
   1266 If any of these conditions are satisfied for a buffer in the
   1267 current project, `project-switch-to-buffer',
   1268 `project-display-buffer' and `project-display-buffer-other-frame'
   1269 ignore it.
   1270 See the doc string of `project-kill-buffer-conditions' for the
   1271 general form of conditions."
   1272   :type '(repeat (choice regexp function symbol
   1273                          (cons :tag "Major mode"
   1274                                (const major-mode) symbol)
   1275                          (cons :tag "Derived mode"
   1276                                (const derived-mode) symbol)
   1277                          (cons :tag "Negation"
   1278                                (const not) sexp)
   1279                          (cons :tag "Conjunction"
   1280                                (const and) sexp)
   1281                          (cons :tag "Disjunction"
   1282                                (const or) sexp)))
   1283   :version "29.1"
   1284   :group 'project
   1285   :package-version '(project . "0.8.2"))
   1286 
   1287 (defun project--read-project-buffer ()
   1288   (let* ((pr (project-current t))
   1289          (current-buffer (current-buffer))
   1290          (other-buffer (other-buffer current-buffer))
   1291          (other-name (buffer-name other-buffer))
   1292          (buffers (project-buffers pr))
   1293          (predicate
   1294           (lambda (buffer)
   1295             ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist.
   1296             (and (memq (cdr buffer) buffers)
   1297                  (not
   1298                   (project--buffer-check
   1299                    (cdr buffer) project-ignore-buffer-conditions))))))
   1300     (read-buffer
   1301      "Switch to buffer: "
   1302      (when (funcall predicate (cons other-name other-buffer))
   1303        other-name)
   1304      nil
   1305      predicate)))
   1306 
   1307 ;;;###autoload
   1308 (defun project-switch-to-buffer (buffer-or-name)
   1309   "Display buffer BUFFER-OR-NAME in the selected window.
   1310 When called interactively, prompts for a buffer belonging to the
   1311 current project.  Two buffers belong to the same project if their
   1312 project instances, as reported by `project-current' in each
   1313 buffer, are identical."
   1314   (interactive (list (project--read-project-buffer)))
   1315   (switch-to-buffer buffer-or-name))
   1316 
   1317 ;;;###autoload
   1318 (defun project-display-buffer (buffer-or-name)
   1319   "Display BUFFER-OR-NAME in some window, without selecting it.
   1320 When called interactively, prompts for a buffer belonging to the
   1321 current project.  Two buffers belong to the same project if their
   1322 project instances, as reported by `project-current' in each
   1323 buffer, are identical.
   1324 
   1325 This function uses `display-buffer' as a subroutine, which see
   1326 for how it is determined where the buffer will be displayed."
   1327   (interactive (list (project--read-project-buffer)))
   1328   (display-buffer buffer-or-name))
   1329 
   1330 ;;;###autoload
   1331 (defun project-display-buffer-other-frame (buffer-or-name)
   1332   "Display BUFFER-OR-NAME preferably in another frame.
   1333 When called interactively, prompts for a buffer belonging to the
   1334 current project.  Two buffers belong to the same project if their
   1335 project instances, as reported by `project-current' in each
   1336 buffer, are identical.
   1337 
   1338 This function uses `display-buffer-other-frame' as a subroutine,
   1339 which see for how it is determined where the buffer will be
   1340 displayed."
   1341   (interactive (list (project--read-project-buffer)))
   1342   (display-buffer-other-frame buffer-or-name))
   1343 
   1344 ;;;###autoload
   1345 (defun project-list-buffers (&optional arg)
   1346   "Display a list of project buffers.
   1347 The list is displayed in a buffer named \"*Buffer List*\".
   1348 
   1349 By default, all project buffers are listed except those whose names
   1350 start with a space (which are for internal use).  With prefix argument
   1351 ARG, show only buffers that are visiting files."
   1352   (interactive "P")
   1353   (let* ((pr (project-current t))
   1354          (buffer-list-function
   1355           (lambda ()
   1356             (seq-filter
   1357              (lambda (buffer)
   1358                (let ((name (buffer-name buffer))
   1359                      (file (buffer-file-name buffer)))
   1360                  (and (or (not (string= (substring name 0 1) " "))
   1361                           file)
   1362                       (not (eq buffer (current-buffer)))
   1363                       (or file (not Buffer-menu-files-only)))))
   1364              (project-buffers pr)))))
   1365     (display-buffer
   1366      (if (version< emacs-version "29.0.50")
   1367          (let ((buf (list-buffers-noselect
   1368                      arg (with-current-buffer
   1369                              (get-buffer-create "*Buffer List*")
   1370                            (let ((Buffer-menu-files-only arg))
   1371                              (funcall buffer-list-function))))))
   1372            (with-current-buffer buf
   1373              (setq-local revert-buffer-function
   1374                          (lambda (&rest _ignored)
   1375                            (list-buffers--refresh
   1376                             (funcall buffer-list-function))
   1377                            (tabulated-list-print t))))
   1378            buf)
   1379        (list-buffers-noselect arg buffer-list-function)))))
   1380 
   1381 (defcustom project-kill-buffer-conditions
   1382   '(buffer-file-name    ; All file-visiting buffers are included.
   1383     ;; Most of temp and logging buffers (aside from hidden ones):
   1384     (and
   1385      (major-mode . fundamental-mode)
   1386      "\\`[^ ]")
   1387     ;; non-text buffer such as xref, occur, vc, log, ...
   1388     (and (derived-mode . special-mode)
   1389          (not (major-mode . help-mode))
   1390          (not (derived-mode . gnus-mode)))
   1391     (derived-mode . compilation-mode)
   1392     (derived-mode . dired-mode)
   1393     (derived-mode . diff-mode)
   1394     (derived-mode . comint-mode)
   1395     (derived-mode . eshell-mode)
   1396     (derived-mode . change-log-mode))
   1397   "List of conditions to kill buffers related to a project.
   1398 This list is used by `project-kill-buffers'.
   1399 Each condition is either:
   1400 - a regular expression, to match a buffer name,
   1401 - a predicate function that takes a buffer object as argument
   1402   and returns non-nil if the buffer should be killed,
   1403 - a cons-cell, where the car describes how to interpret the cdr.
   1404   The car can be one of the following:
   1405   * `major-mode': the buffer is killed if the buffer's major
   1406     mode is eq to the cons-cell's cdr.
   1407   * `derived-mode': the buffer is killed if the buffer's major
   1408     mode is derived from the major mode in the cons-cell's cdr.
   1409   * `not': the cdr is interpreted as a negation of a condition.
   1410   * `and': the cdr is a list of recursive conditions, that all have
   1411     to be met.
   1412   * `or': the cdr is a list of recursive conditions, of which at
   1413     least one has to be met.
   1414 
   1415 If any of these conditions are satisfied for a buffer in the
   1416 current project, it will be killed."
   1417   :type '(repeat (choice regexp function symbol
   1418                          (cons :tag "Major mode"
   1419                                (const major-mode) symbol)
   1420                          (cons :tag "Derived mode"
   1421                                (const derived-mode) symbol)
   1422                          (cons :tag "Negation"
   1423                                (const not) sexp)
   1424                          (cons :tag "Conjunction"
   1425                                (const and) sexp)
   1426                          (cons :tag "Disjunction"
   1427                                (const or) sexp)))
   1428   :version "29.1"
   1429   :group 'project
   1430   :package-version '(project . "0.8.2"))
   1431 
   1432 (defcustom project-kill-buffers-display-buffer-list nil
   1433   "Non-nil to display list of buffers to kill before killing project buffers.
   1434 Used by `project-kill-buffers'."
   1435   :type 'boolean
   1436   :version "29.1"
   1437   :group 'project
   1438   :package-version '(project . "0.8.2")
   1439   :safe #'booleanp)
   1440 
   1441 (defun project--buffer-check (buf conditions)
   1442   "Check if buffer BUF matches any element of the list CONDITIONS.
   1443 See `project-kill-buffer-conditions' or
   1444 `project-ignore-buffer-conditions' for more details on the
   1445 form of CONDITIONS."
   1446   (catch 'match
   1447     (dolist (c conditions)
   1448       (when (cond
   1449              ((stringp c)
   1450               (string-match-p c (buffer-name buf)))
   1451              ((functionp c)
   1452               (funcall c buf))
   1453              ((eq (car-safe c) 'major-mode)
   1454               (eq (buffer-local-value 'major-mode buf)
   1455                   (cdr c)))
   1456              ((eq (car-safe c) 'derived-mode)
   1457               (provided-mode-derived-p
   1458                (buffer-local-value 'major-mode buf)
   1459                (cdr c)))
   1460              ((eq (car-safe c) 'not)
   1461               (not (project--buffer-check buf (cdr c))))
   1462              ((eq (car-safe c) 'or)
   1463               (project--buffer-check buf (cdr c)))
   1464              ((eq (car-safe c) 'and)
   1465               (seq-every-p
   1466                (apply-partially #'project--buffer-check
   1467                                 buf)
   1468                (mapcar #'list (cdr c)))))
   1469         (throw 'match t)))))
   1470 
   1471 (defun project--buffers-to-kill (pr)
   1472   "Return list of buffers in project PR to kill.
   1473 What buffers should or should not be killed is described
   1474 in `project-kill-buffer-conditions'."
   1475   (let (bufs)
   1476     (dolist (buf (project-buffers pr))
   1477       (when (project--buffer-check buf project-kill-buffer-conditions)
   1478         (push buf bufs)))
   1479     bufs))
   1480 
   1481 ;;;###autoload
   1482 (defun project-kill-buffers (&optional no-confirm)
   1483   "Kill the buffers belonging to the current project.
   1484 Two buffers belong to the same project if their project
   1485 instances, as reported by `project-current' in each buffer, are
   1486 identical.  Only the buffers that match a condition in
   1487 `project-kill-buffer-conditions' will be killed.  If NO-CONFIRM
   1488 is non-nil, the command will not ask the user for confirmation.
   1489 NO-CONFIRM is always nil when the command is invoked
   1490 interactively.
   1491 
   1492 Also see the `project-kill-buffers-display-buffer-list' variable."
   1493   (interactive)
   1494   (let* ((pr (project-current t))
   1495          (bufs (project--buffers-to-kill pr))
   1496          (query-user (lambda ()
   1497                        (yes-or-no-p
   1498                         (format "Kill %d buffers in %s? "
   1499                                 (length bufs)
   1500                                 (project-root pr))))))
   1501     (cond (no-confirm
   1502            (mapc #'kill-buffer bufs))
   1503           ((null bufs)
   1504            (message "No buffers to kill"))
   1505           (project-kill-buffers-display-buffer-list
   1506            (when
   1507                (with-current-buffer-window
   1508                    (get-buffer-create "*Buffer List*")
   1509                    `(display-buffer--maybe-at-bottom
   1510                      (dedicated . t)
   1511                      (window-height . (fit-window-to-buffer))
   1512                      (preserve-size . (nil . t))
   1513                      (body-function
   1514                       . ,#'(lambda (_window)
   1515                              (list-buffers-noselect nil bufs))))
   1516                    #'(lambda (window _value)
   1517                        (with-selected-window window
   1518                          (unwind-protect
   1519                              (funcall query-user)
   1520                            (when (window-live-p window)
   1521                              (quit-restore-window window 'kill))))))
   1522              (mapc #'kill-buffer bufs)))
   1523           ((funcall query-user)
   1524            (mapc #'kill-buffer bufs)))))
   1525 
   1526 
   1527 ;;; Project list
   1528 
   1529 (defcustom project-list-file (locate-user-emacs-file "projects")
   1530   "File in which to save the list of known projects."
   1531   :type 'file
   1532   :version "28.1"
   1533   :group 'project)
   1534 
   1535 (defvar project--list 'unset
   1536   "List structure containing root directories of known projects.
   1537 With some possible metadata (to be decided).")
   1538 
   1539 (defun project--read-project-list ()
   1540   "Initialize `project--list' using contents of `project-list-file'."
   1541   (let ((filename project-list-file))
   1542     (setq project--list
   1543           (when (file-exists-p filename)
   1544             (with-temp-buffer
   1545               (insert-file-contents filename)
   1546               (read (current-buffer)))))
   1547     (unless (seq-every-p
   1548              (lambda (elt) (stringp (car-safe elt)))
   1549              project--list)
   1550       (warn "Contents of %s are in wrong format, resetting"
   1551             project-list-file)
   1552       (setq project--list nil))))
   1553 
   1554 (defun project--ensure-read-project-list ()
   1555   "Initialize `project--list' if it isn't already initialized."
   1556   (when (eq project--list 'unset)
   1557     (project--read-project-list)))
   1558 
   1559 (defun project--write-project-list ()
   1560   "Save `project--list' in `project-list-file'."
   1561   (let ((filename project-list-file))
   1562     (with-temp-buffer
   1563       (insert ";;; -*- lisp-data -*-\n")
   1564       (let ((print-length nil)
   1565             (print-level nil))
   1566         (pp project--list (current-buffer)))
   1567       (write-region nil nil filename nil 'silent))))
   1568 
   1569 ;;;###autoload
   1570 (defun project-remember-project (pr &optional no-write)
   1571   "Add project PR to the front of the project list.
   1572 Save the result in `project-list-file' if the list of projects
   1573 has changed, and NO-WRITE is nil."
   1574   (project--ensure-read-project-list)
   1575   (let ((dir (project-root pr)))
   1576     (unless (equal (caar project--list) dir)
   1577       (dolist (ent project--list)
   1578         (when (equal dir (car ent))
   1579           (setq project--list (delq ent project--list))))
   1580       (push (list dir) project--list)
   1581       (unless no-write
   1582         (project--write-project-list)))))
   1583 
   1584 (defun project--remove-from-project-list (project-root report-message)
   1585   "Remove directory PROJECT-ROOT of a missing project from the project list.
   1586 If the directory was in the list before the removal, save the
   1587 result in `project-list-file'.  Announce the project's removal
   1588 from the list using REPORT-MESSAGE, which is a format string
   1589 passed to `message' as its first argument."
   1590   (project--ensure-read-project-list)
   1591   (when-let ((ent (assoc project-root project--list)))
   1592     (setq project--list (delq ent project--list))
   1593     (message report-message project-root)
   1594     (project--write-project-list)))
   1595 
   1596 ;;;###autoload
   1597 (defun project-forget-project (project-root)
   1598   "Remove directory PROJECT-ROOT from the project list.
   1599 PROJECT-ROOT is the root directory of a known project listed in
   1600 the project list."
   1601   (interactive (list (project-prompt-project-dir)))
   1602   (project--remove-from-project-list
   1603    project-root "Project `%s' removed from known projects"))
   1604 
   1605 (defun project-prompt-project-dir ()
   1606   "Prompt the user for a directory that is one of the known project roots.
   1607 The project is chosen among projects known from the project list,
   1608 see `project-list-file'.
   1609 It's also possible to enter an arbitrary directory not in the list."
   1610   (project--ensure-read-project-list)
   1611   (let* ((dir-choice "... (choose a dir)")
   1612          (choices
   1613           ;; XXX: Just using this for the category (for the substring
   1614           ;; completion style).
   1615           (project--file-completion-table
   1616            (append project--list `(,dir-choice))))
   1617          (pr-dir ""))
   1618     (while (equal pr-dir "")
   1619       ;; If the user simply pressed RET, do this again until they don't.
   1620       (setq pr-dir (completing-read "Select project: " choices nil t)))
   1621     (if (equal pr-dir dir-choice)
   1622         (read-directory-name "Select directory: " default-directory nil t)
   1623       pr-dir)))
   1624 
   1625 ;;;###autoload
   1626 (defun project-known-project-roots ()
   1627   "Return the list of root directories of all known projects."
   1628   (project--ensure-read-project-list)
   1629   (mapcar #'car project--list))
   1630 
   1631 ;;;###autoload
   1632 (defun project-execute-extended-command ()
   1633   "Execute an extended command in project root."
   1634   (declare (interactive-only command-execute))
   1635   (interactive)
   1636   (let ((default-directory (project-root (project-current t))))
   1637     (call-interactively #'execute-extended-command)))
   1638 
   1639 (defun project-remember-projects-under (dir &optional recursive)
   1640   "Index all projects below a directory DIR.
   1641 If RECURSIVE is non-nil, recurse into all subdirectories to find
   1642 more projects.  After finishing, a message is printed summarizing
   1643 the progress.  The function returns the number of detected
   1644 projects."
   1645   (interactive "DDirectory: \nP")
   1646   (project--ensure-read-project-list)
   1647   (let ((queue (list dir))
   1648         (count 0)
   1649         (known (make-hash-table
   1650                 :size (* 2 (length project--list))
   1651                 :test #'equal )))
   1652     (dolist (project (mapcar #'car project--list))
   1653       (puthash project t known))
   1654     (while queue
   1655       (when-let ((subdir (pop queue))
   1656                  ((file-directory-p subdir)))
   1657         (when-let ((project (project--find-in-directory subdir))
   1658                    (project-root (project-root project))
   1659                    ((not (gethash project-root known))))
   1660           (project-remember-project project t)
   1661           (puthash project-root t known)
   1662           (message "Found %s..." project-root)
   1663           (setq count (1+ count)))
   1664         (when (and recursive (file-directory-p subdir))
   1665           (setq queue
   1666                 (nconc
   1667                  (directory-files
   1668                   subdir t directory-files-no-dot-files-regexp t)
   1669                  queue)))))
   1670     (unless (eq recursive 'in-progress)
   1671       (if (zerop count)
   1672           (message "No projects were found")
   1673         (project--write-project-list)
   1674         (message "%d project%s were found"
   1675                  count (if (= count 1) "" "s"))))
   1676     count))
   1677 
   1678 (defun project-forget-zombie-projects ()
   1679   "Forget all known projects that don't exist any more."
   1680   (interactive)
   1681   (dolist (proj (project-known-project-roots))
   1682     (unless (file-exists-p proj)
   1683       (project-forget-project proj))))
   1684 
   1685 (defun project-forget-projects-under (dir &optional recursive)
   1686   "Forget all known projects below a directory DIR.
   1687 If RECURSIVE is non-nil, recurse into all subdirectories to
   1688 remove all known projects.  After finishing, a message is printed
   1689 summarizing the progress.  The function returns the number of
   1690 forgotten projects."
   1691   (interactive "DDirectory: \nP")
   1692   (let ((count 0))
   1693     (if recursive
   1694         (dolist (proj (project-known-project-roots))
   1695           (when (file-in-directory-p proj dir)
   1696             (project-forget-project proj)
   1697             (setq count (1+ count))))
   1698       (dolist (proj (project-known-project-roots))
   1699         (when (file-equal-p (file-name-directory proj) dir)
   1700           (project-forget-project proj)
   1701           (setq count (1+ count)))))
   1702     (if (zerop count)
   1703         (message "No projects were forgotten")
   1704       (project--write-project-list)
   1705       (message "%d project%s were forgotten"
   1706                count (if (= count 1) "" "s")))
   1707     count))
   1708 
   1709 
   1710 ;;; Project switching
   1711 
   1712 (defcustom project-switch-commands
   1713   '((project-find-file "Find file")
   1714     (project-find-regexp "Find regexp")
   1715     (project-find-dir "Find directory")
   1716     (project-vc-dir "VC-Dir")
   1717     (project-eshell "Eshell"))
   1718   "Alist mapping commands to descriptions.
   1719 Used by `project-switch-project' to construct a dispatch menu of
   1720 commands available upon \"switching\" to another project.
   1721 
   1722 Each element is of the form (COMMAND LABEL &optional KEY) where
   1723 COMMAND is the command to run when KEY is pressed.  LABEL is used
   1724 to distinguish the menu entries in the dispatch menu.  If KEY is
   1725 absent, COMMAND must be bound in `project-prefix-map', and the
   1726 key is looked up in that map.
   1727 
   1728 The value can also be a symbol, the name of the command to be
   1729 invoked immediately without any dispatch menu."
   1730   :version "28.1"
   1731   :group 'project
   1732   :package-version '(project . "0.6.0")
   1733   :type '(choice
   1734           (repeat :tag "Commands menu"
   1735            (list
   1736             (symbol :tag "Command")
   1737             (string :tag "Label")
   1738             (choice :tag "Key to press"
   1739                     (const :tag "Infer from the keymap" nil)
   1740                     (character :tag "Explicit key"))))
   1741           (symbol :tag "Single command")))
   1742 
   1743 (defcustom project-switch-use-entire-map nil
   1744   "Make `project-switch-project' use entire `project-prefix-map'.
   1745 If nil, `project-switch-project' will only recognize commands
   1746 listed in `project-switch-commands' and signal an error when
   1747 others are invoked.  Otherwise, all keys in `project-prefix-map'
   1748 are legal even if they aren't listed in the dispatch menu."
   1749   :type 'boolean
   1750   :group 'project
   1751   :version "28.1")
   1752 
   1753 (defun project--keymap-prompt ()
   1754   "Return a prompt for the project switching dispatch menu."
   1755   (mapconcat
   1756    (pcase-lambda (`(,cmd ,label ,key))
   1757      (when (characterp cmd) ; Old format, apparently user-customized.
   1758        (let ((tmp cmd))
   1759          ;; TODO: Add a deprecation warning, probably.
   1760          (setq cmd key
   1761                key tmp)))
   1762      (let ((key (if key
   1763                     (vector key)
   1764                   (where-is-internal cmd (list project-prefix-map) t))))
   1765        (format "[%s] %s"
   1766                (propertize (key-description key) 'face 'bold)
   1767                label)))
   1768    project-switch-commands
   1769    "  "))
   1770 
   1771 (defun project--switch-project-command ()
   1772   (let* ((commands-menu
   1773           (mapcar
   1774            (lambda (row)
   1775              (if (characterp (car row))
   1776                  ;; Deprecated format.
   1777                  ;; XXX: Add a warning about it?
   1778                  (reverse row)
   1779                row))
   1780            project-switch-commands))
   1781          (commands-map
   1782           (let ((temp-map (make-sparse-keymap)))
   1783             (set-keymap-parent temp-map project-prefix-map)
   1784             (dolist (row commands-menu temp-map)
   1785               (when-let ((cmd (nth 0 row))
   1786                          (keychar (nth 2 row)))
   1787                 (define-key temp-map (vector keychar) cmd)))))
   1788          command)
   1789     (while (not command)
   1790       (let* ((overriding-local-map commands-map)
   1791              (choice (read-key-sequence (project--keymap-prompt))))
   1792         (when (setq command (lookup-key commands-map choice))
   1793           (unless (or project-switch-use-entire-map
   1794                       (assq command commands-menu))
   1795             ;; TODO: Add some hint to the prompt, like "key not
   1796             ;; recognized" or something.
   1797             (setq command nil)))
   1798         (let ((global-command (lookup-key (current-global-map) choice)))
   1799           (when (memq global-command
   1800                       '(keyboard-quit keyboard-escape-quit))
   1801             (call-interactively global-command)))))
   1802     command))
   1803 
   1804 ;;;###autoload
   1805 (defun project-switch-project (dir)
   1806   "\"Switch\" to another project by running an Emacs command.
   1807 The available commands are presented as a dispatch menu
   1808 made from `project-switch-commands'.
   1809 
   1810 When called in a program, it will use the project corresponding
   1811 to directory DIR."
   1812   (interactive (list (project-prompt-project-dir)))
   1813   (let ((command (if (symbolp project-switch-commands)
   1814                      project-switch-commands
   1815                    (project--switch-project-command))))
   1816     (let ((project-current-directory-override dir))
   1817       (call-interactively command))))
   1818 
   1819 (provide 'project)
   1820 ;;; project.el ends here
	dotemacs My Emacs configuration
	git clone git://git.entf.net/dotemacs
	Log \| Files \| Refs \| LICENSE