project.el - dotemacs - My Emacs configuration

project.el (73946B)
      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.8
      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 (defvar project-vc-backend-markers-alist
    498   `((Git . ".git")
    499     (Hg . ".hg")
    500     (Bzr . ".bzr")
    501     ;; See the comment above `vc-svn-admin-directory' for why we're
    502     ;; duplicating the definition.
    503     (SVN . ,(if (and (memq system-type '(cygwin windows-nt ms-dos))
    504                      (getenv "SVN_ASP_DOT_NET_HACK"))
    505                 "_svn"
    506               ".svn"))
    507     (DARCS . "_darcs")
    508     (Fossil . ".fslckout")
    509     (Got . ".got"))
    510   "Associative list assigning root markers to VC backend symbols.
    511 
    512 See `project-vc-extra-root-markers' for the marker value format.")
    513 
    514 (defun project-try-vc (dir)
    515   ;; FIXME: Learn to invalidate when the value of
    516   ;; `project-vc-merge-submodules' or `project-vc-extra-root-markers'
    517   ;; changes.
    518   (or (vc-file-getprop dir 'project-vc)
    519       (let* ((backend-markers
    520               (delete
    521                nil
    522                (mapcar
    523                 (lambda (b) (assoc-default b project-vc-backend-markers-alist))
    524                 vc-handled-backends)))
    525              (marker-re
    526               (concat
    527                "\\`"
    528                (mapconcat
    529                 (lambda (m) (format "\\(%s\\)" (wildcard-to-regexp m)))
    530                 (append backend-markers
    531                         (project--value-in-dir 'project-vc-extra-root-markers dir))
    532                 "\\|")
    533                "\\'"))
    534              (locate-dominating-stop-dir-regexp
    535               (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp))
    536              last-matches
    537              (root
    538               (locate-dominating-file
    539                dir
    540                (lambda (d)
    541                  ;; Maybe limit count to 100 when we can drop Emacs < 28.
    542                  (setq last-matches
    543                        (condition-case nil
    544                            (directory-files d nil marker-re t)
    545                          (file-missing nil))))))
    546              (backend
    547               (cl-find-if
    548                (lambda (b)
    549                  (member (assoc-default b project-vc-backend-markers-alist)
    550                          last-matches))
    551                vc-handled-backends))
    552              project)
    553         (when (and
    554                (eq backend 'Git)
    555                (project--vc-merge-submodules-p root)
    556                (project--submodule-p root))
    557           (let* ((parent (file-name-directory (directory-file-name root))))
    558             (setq root (vc-call-backend 'Git 'root parent))))
    559         (when root
    560           (setq project (list 'vc backend root))
    561           ;; FIXME: Cache for a shorter time.
    562           (vc-file-setprop dir 'project-vc project)
    563           project))))
    564 
    565 (defun project--submodule-p (root)
    566   ;; XXX: We only support Git submodules for now.
    567   ;;
    568   ;; For submodules, at least, we expect the users to prefer them to
    569   ;; be considered part of the parent project.  For those who don't,
    570   ;; there is the custom var now.
    571   ;;
    572   ;; Some users may also set up things equivalent to Git submodules
    573   ;; using "git worktree" (for example).  However, we expect that most
    574   ;; of them would prefer to treat those as separate projects anyway.
    575   (let* ((gitfile (expand-file-name ".git" root)))
    576     (cond
    577      ((file-directory-p gitfile)
    578       nil)
    579      ((with-temp-buffer
    580         (insert-file-contents gitfile)
    581         (goto-char (point-min))
    582         ;; Kind of a hack to distinguish a submodule from
    583         ;; other cases of .git files pointing elsewhere.
    584         (looking-at "gitdir: [./]+/\\.git/modules/"))
    585       t)
    586      (t nil))))
    587 
    588 (cl-defmethod project-root ((project (head vc)))
    589   (nth 2 project))
    590 
    591 (cl-defmethod project-external-roots ((project (head vc)))
    592   (project-subtract-directories
    593    (project-combine-directories
    594     (mapcar
    595      #'file-name-as-directory
    596      (funcall project-vc-external-roots-function)))
    597    (list (project-root project))))
    598 
    599 (cl-defmethod project-files ((project (head vc)) &optional dirs)
    600   (mapcan
    601    (lambda (dir)
    602      (let ((ignores (project--value-in-dir 'project-vc-ignores (nth 2 project)))
    603            (backend (cadr project)))
    604        (when backend
    605          (require (intern (concat "vc-" (downcase (symbol-name backend))))))
    606        (if (and (file-equal-p dir (nth 2 project))
    607                 (cond
    608                  ((eq backend 'Hg))
    609                  ((and (eq backend 'Git)
    610                        (or
    611                         (not ignores)
    612                         (version<= "1.9" (vc-git--program-version)))))))
    613            (project--vc-list-files dir backend ignores)
    614          (project--files-in-directory
    615           dir
    616           (project--dir-ignores project dir)))))
    617    (or dirs
    618        (list (project-root project)))))
    619 
    620 (declare-function vc-git--program-version "vc-git")
    621 (declare-function vc-git--run-command-string "vc-git")
    622 (declare-function vc-hg-command "vc-hg")
    623 
    624 (defun project--vc-list-files (dir backend extra-ignores)
    625   (defvar vc-git-use-literal-pathspecs)
    626   (pcase backend
    627     (`Git
    628      (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
    629             (args '("-z"))
    630             (vc-git-use-literal-pathspecs nil)
    631             (include-untracked (project--value-in-dir
    632                                 'project-vc-include-untracked
    633                                 dir))
    634             files)
    635        (setq args (append args
    636                           '("-c" "--exclude-standard")
    637                           (and include-untracked '("-o"))))
    638        (when extra-ignores
    639          (setq args (append args
    640                             (cons "--"
    641                                   (mapcar
    642                                    (lambda (i)
    643                                      (format
    644                                       ":(exclude,glob,top)%s"
    645                                       (if (string-match "\\*\\*" i)
    646                                           ;; Looks like pathspec glob
    647                                           ;; format already.
    648                                           i
    649                                         (if (string-match "\\./" i)
    650                                             ;; ./abc -> abc
    651                                             (setq i (substring i 2))
    652                                           ;; abc -> **/abc
    653                                           (setq i (concat "**/" i))
    654                                           ;; FIXME: '**/abc' should also
    655                                           ;; match a directory with that
    656                                           ;; name, but doesn't (git 2.25.1).
    657                                           ;; Maybe we should replace
    658                                           ;; such entries with two.
    659                                           (if (string-match "/\\'" i)
    660                                               ;; abc/ -> abc/**
    661                                               (setq i (concat i "**"))))
    662                                         i)))
    663                                    extra-ignores)))))
    664        (setq files
    665              (mapcar
    666               (lambda (file) (concat default-directory file))
    667               (split-string
    668                (apply #'vc-git--run-command-string nil "ls-files" args)
    669                "\0" t)))
    670        (when (project--vc-merge-submodules-p default-directory)
    671          ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'.
    672          (let* ((submodules (project--git-submodules))
    673                 (sub-files
    674                  (mapcar
    675                   (lambda (module)
    676                     (when (file-directory-p module)
    677                       (project--vc-list-files
    678                        (concat default-directory module)
    679                        backend
    680                        extra-ignores)))
    681                   submodules)))
    682            (setq files
    683                  (apply #'nconc files sub-files))))
    684        ;; 'git ls-files' returns duplicate entries for merge conflicts.
    685        ;; XXX: Better solutions welcome, but this seems cheap enough.
    686        (delete-consecutive-dups files)))
    687     (`Hg
    688      (let* ((default-directory (expand-file-name (file-name-as-directory dir)))
    689             (include-untracked (project--value-in-dir
    690                                 'project-vc-include-untracked
    691                                 dir))
    692             (args (list (concat "-mcard" (and include-untracked "u"))
    693                         "--no-status"
    694                         "-0")))
    695        (when extra-ignores
    696          (setq args (nconc args
    697                            (mapcan
    698                             (lambda (i)
    699                               (list "--exclude" i))
    700                             extra-ignores))))
    701        (with-temp-buffer
    702          (apply #'vc-hg-command t 0 "." "status" args)
    703          (mapcar
    704           (lambda (s) (concat default-directory s))
    705           (split-string (buffer-string) "\0" t)))))))
    706 
    707 (defun project--vc-merge-submodules-p (dir)
    708   (project--value-in-dir
    709    'project-vc-merge-submodules
    710    dir))
    711 
    712 (defun project--git-submodules ()
    713   ;; 'git submodule foreach' is much slower.
    714   (condition-case nil
    715       (with-temp-buffer
    716         (insert-file-contents ".gitmodules")
    717         (let (res)
    718           (goto-char (point-min))
    719           (while (re-search-forward "^[ \t]*path *= *\\(.+\\)" nil t)
    720             (push (match-string 1) res))
    721           (nreverse res)))
    722     (file-missing nil)))
    723 
    724 (cl-defmethod project-ignores ((project (head vc)) dir)
    725   (let* ((root (nth 2 project))
    726          backend)
    727     (append
    728      (when (and backend
    729                 (file-equal-p dir root))
    730        (setq backend (cadr project))
    731        (delq
    732         nil
    733         (mapcar
    734          (lambda (entry)
    735            (cond
    736             ((eq ?! (aref entry 0))
    737              ;; No support for whitelisting (yet).
    738              nil)
    739             ((string-match "\\(/\\)[^/]" entry)
    740              ;; FIXME: This seems to be Git-specific.
    741              ;; And / in the entry (start or even the middle) means
    742              ;; the pattern is "rooted".  Or actually it is then
    743              ;; relative to its respective .gitignore (of which there
    744              ;; could be several), but we only support .gitignore at
    745              ;; the root.
    746              (if (= (match-beginning 0) 0)
    747                  (replace-match "./" t t entry 1)
    748                (concat "./" entry)))
    749             (t entry)))
    750          (condition-case nil
    751              (vc-call-backend backend 'ignore-completion-table root)
    752            (vc-not-supported () nil)))))
    753      (project--value-in-dir 'project-vc-ignores root)
    754      (mapcar
    755       (lambda (dir)
    756         (concat dir "/"))
    757       vc-directory-exclusion-list))))
    758 
    759 (defun project-combine-directories (&rest lists-of-dirs)
    760   "Return a sorted and culled list of directory names.
    761 Appends the elements of LISTS-OF-DIRS together, removes
    762 non-existing directories, as well as directories a parent of
    763 whose is already in the list."
    764   (let* ((dirs (sort
    765                 (mapcar
    766                  (lambda (dir)
    767                    (file-name-as-directory (expand-file-name dir)))
    768                  (apply #'append lists-of-dirs))
    769                 #'string<))
    770          (ref dirs))
    771     ;; Delete subdirectories from the list.
    772     (while (cdr ref)
    773       (if (string-prefix-p (car ref) (cadr ref))
    774           (setcdr ref (cddr ref))
    775         (setq ref (cdr ref))))
    776     (cl-delete-if-not #'file-exists-p dirs)))
    777 
    778 (defun project-subtract-directories (files dirs)
    779   "Return a list of elements from FILES that are outside of DIRS.
    780 DIRS must contain directory names."
    781   ;; Sidestep the issue of expanded/abbreviated file names here.
    782   (cl-set-difference files dirs :test #'file-in-directory-p))
    783 
    784 (defun project--value-in-dir (var dir)
    785   (with-temp-buffer
    786     (setq default-directory dir)
    787     (let ((enable-local-variables :all))
    788       (hack-dir-local-variables-non-file-buffer))
    789     (symbol-value var)))
    790 
    791 (cl-defmethod project-buffers ((project (head vc)))
    792   (let* ((root (expand-file-name (file-name-as-directory (project-root project))))
    793          (modules (unless (or (project--vc-merge-submodules-p root)
    794                               (project--submodule-p root))
    795                     (mapcar
    796                      (lambda (m) (format "%s%s/" root m))
    797                      (project--git-submodules))))
    798          dd
    799          bufs)
    800     (dolist (buf (buffer-list))
    801       (setq dd (expand-file-name (buffer-local-value 'default-directory buf)))
    802       (when (and (string-prefix-p root dd)
    803                  (not (cl-find-if (lambda (module) (string-prefix-p module dd))
    804                                   modules)))
    805         (push buf bufs)))
    806     (nreverse bufs)))
    807 
    808 (cl-defmethod project-name ((_project (head vc)))
    809   (or project-vc-name
    810       (cl-call-next-method)))
    811 
    812 
    813 ;;; Project commands
    814 
    815 ;;;###autoload
    816 (defvar project-prefix-map
    817   (let ((map (make-sparse-keymap)))
    818     (define-key map "!" 'project-shell-command)
    819     (define-key map "&" 'project-async-shell-command)
    820     (define-key map "f" 'project-find-file)
    821     (define-key map "F" 'project-or-external-find-file)
    822     (define-key map "b" 'project-switch-to-buffer)
    823     (define-key map "s" 'project-shell)
    824     (define-key map "d" 'project-find-dir)
    825     (define-key map "D" 'project-dired)
    826     (define-key map "v" 'project-vc-dir)
    827     (define-key map "c" 'project-compile)
    828     (define-key map "e" 'project-eshell)
    829     (define-key map "k" 'project-kill-buffers)
    830     (define-key map "p" 'project-switch-project)
    831     (define-key map "g" 'project-find-regexp)
    832     (define-key map "G" 'project-or-external-find-regexp)
    833     (define-key map "r" 'project-query-replace-regexp)
    834     (define-key map "x" 'project-execute-extended-command)
    835     (define-key map "\C-b" 'project-list-buffers)
    836     map)
    837   "Keymap for project commands.")
    838 
    839 ;;;###autoload (define-key ctl-x-map "p" project-prefix-map)
    840 
    841 ;; We can't have these place-specific maps inherit from
    842 ;; project-prefix-map because project--other-place-command needs to
    843 ;; know which map the key binding came from, as if it came from one of
    844 ;; these maps, we don't want to set display-buffer-overriding-action
    845 
    846 (defvar project-other-window-map
    847   (let ((map (make-sparse-keymap)))
    848     (define-key map "\C-o" #'project-display-buffer)
    849     map)
    850   "Keymap for project commands that display buffers in other windows.")
    851 
    852 (defvar project-other-frame-map
    853   (let ((map (make-sparse-keymap)))
    854     (define-key map "\C-o" #'project-display-buffer-other-frame)
    855     map)
    856   "Keymap for project commands that display buffers in other frames.")
    857 
    858 (defun project--other-place-command (action &optional map)
    859   (let* ((key (read-key-sequence-vector nil t))
    860          (place-cmd (lookup-key map key))
    861          (generic-cmd (lookup-key project-prefix-map key))
    862          (switch-to-buffer-obey-display-actions t)
    863          (display-buffer-overriding-action (unless place-cmd action)))
    864     (if-let ((cmd (or place-cmd generic-cmd)))
    865         (call-interactively cmd)
    866       (user-error "%s is undefined" (key-description key)))))
    867 
    868 ;;;###autoload
    869 (defun project-other-window-command ()
    870   "Run project command, displaying resultant buffer in another window.
    871 
    872 The following commands are available:
    873 
    874 \\{project-prefix-map}
    875 \\{project-other-window-map}"
    876   (interactive)
    877   (project--other-place-command '((display-buffer-pop-up-window)
    878                                   (inhibit-same-window . t))
    879                                 project-other-window-map))
    880 
    881 ;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command)
    882 
    883 ;;;###autoload
    884 (defun project-other-frame-command ()
    885   "Run project command, displaying resultant buffer in another frame.
    886 
    887 The following commands are available:
    888 
    889 \\{project-prefix-map}
    890 \\{project-other-frame-map}"
    891   (interactive)
    892   (project--other-place-command '((display-buffer-pop-up-frame))
    893                                 project-other-frame-map))
    894 
    895 ;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command)
    896 
    897 ;;;###autoload
    898 (defun project-other-tab-command ()
    899   "Run project command, displaying resultant buffer in a new tab.
    900 
    901 The following commands are available:
    902 
    903 \\{project-prefix-map}"
    904   (interactive)
    905   (project--other-place-command '((display-buffer-in-new-tab))))
    906 
    907 ;;;###autoload
    908 (when (bound-and-true-p tab-prefix-map)
    909   (define-key tab-prefix-map "p" #'project-other-tab-command))
    910 
    911 (declare-function grep-read-files "grep")
    912 (declare-function xref--find-ignores-arguments "xref")
    913 
    914 ;;;###autoload
    915 (defun project-find-regexp (regexp)
    916   "Find all matches for REGEXP in the current project's roots.
    917 With \\[universal-argument] prefix, you can specify the directory
    918 to search in, and the file name pattern to search for.  The
    919 pattern may use abbreviations defined in `grep-files-aliases',
    920 e.g. entering `ch' is equivalent to `*.[ch]'.  As whitespace
    921 triggers completion when entering a pattern, including it
    922 requires quoting, e.g. `\\[quoted-insert]<space>'."
    923   (interactive (list (project--read-regexp)))
    924   (require 'xref)
    925   (require 'grep)
    926   (let* ((caller-dir default-directory)
    927          (pr (project-current t))
    928          (default-directory (project-root pr))
    929          (files
    930           (if (not current-prefix-arg)
    931               (project-files pr)
    932             (let ((dir (read-directory-name "Base directory: "
    933                                             caller-dir nil t)))
    934               (project--files-in-directory dir
    935                                            nil
    936                                            (grep-read-files regexp))))))
    937     (xref-show-xrefs
    938      (apply-partially #'project--find-regexp-in-files regexp files)
    939      nil)))
    940 
    941 (defun project--dir-ignores (project dir)
    942   (let ((root (project-root project)))
    943     (if (not (file-in-directory-p dir root))
    944         (project-ignores nil nil)       ;The defaults.
    945       (let ((ignores (project-ignores project root)))
    946         (if (file-equal-p root dir)
    947             ignores
    948           ;; FIXME: Update the "rooted" ignores to relate to DIR instead.
    949           (cl-delete-if (lambda (str) (string-prefix-p "./" str))
    950                         ignores))))))
    951 
    952 ;;;###autoload
    953 (defun project-or-external-find-regexp (regexp)
    954   "Find all matches for REGEXP in the project roots or external roots.
    955 With \\[universal-argument] prefix, you can specify the file name
    956 pattern to search for."
    957   (interactive (list (project--read-regexp)))
    958   (require 'xref)
    959   (let* ((pr (project-current t))
    960          (default-directory (project-root pr))
    961          (files
    962           (project-files pr (cons
    963                              (project-root pr)
    964                              (project-external-roots pr)))))
    965     (xref-show-xrefs
    966      (apply-partially #'project--find-regexp-in-files regexp files)
    967      nil)))
    968 
    969 (defun project--find-regexp-in-files (regexp files)
    970   (unless files
    971     (user-error "Empty file list"))
    972   (let ((xrefs (xref-matches-in-files regexp files)))
    973     (unless xrefs
    974       (user-error "No matches for: %s" regexp))
    975     xrefs))
    976 
    977 (defvar project-regexp-history-variable 'grep-regexp-history)
    978 
    979 (defun project--read-regexp ()
    980   (let ((sym (thing-at-point 'symbol t)))
    981     (read-regexp "Find regexp" (and sym (regexp-quote sym))
    982                  project-regexp-history-variable)))
    983 
    984 ;;;###autoload
    985 (defun project-find-file (&optional include-all)
    986   "Visit a file (with completion) in the current project.
    987 
    988 The filename at point (determined by `thing-at-point'), if any,
    989 is available as part of \"future history\".
    990 
    991 If INCLUDE-ALL is non-nil, or with prefix argument when called
    992 interactively, include all files under the project root, except
    993 for VCS directories listed in `vc-directory-exclusion-list'."
    994   (interactive "P")
    995   (let* ((pr (project-current t))
    996          (root (project-root pr))
    997          (dirs (list root)))
    998     (project-find-file-in
    999      (or (thing-at-point 'filename)
   1000          (and buffer-file-name (file-relative-name buffer-file-name root)))
   1001      dirs pr include-all)))
   1002 
   1003 ;;;###autoload
   1004 (defun project-or-external-find-file (&optional include-all)
   1005   "Visit a file (with completion) in the current project or external roots.
   1006 
   1007 The filename at point (determined by `thing-at-point'), if any,
   1008 is available as part of \"future history\".
   1009 
   1010 If INCLUDE-ALL is non-nil, or with prefix argument when called
   1011 interactively, include all files under the project root, except
   1012 for VCS directories listed in `vc-directory-exclusion-list'."
   1013   (interactive "P")
   1014   (let* ((pr (project-current t))
   1015          (dirs (cons
   1016                 (project-root pr)
   1017                 (project-external-roots pr))))
   1018     (project-find-file-in (thing-at-point 'filename) dirs pr include-all)))
   1019 
   1020 (defcustom project-read-file-name-function #'project--read-file-cpd-relative
   1021   "Function to call to read a file name from a list.
   1022 For the arguments list, see `project--read-file-cpd-relative'."
   1023   :type '(choice (const :tag "Read with completion from relative names"
   1024                         project--read-file-cpd-relative)
   1025                  (const :tag "Read with completion from absolute names"
   1026                         project--read-file-absolute)
   1027                  (function :tag "Custom function" nil))
   1028   :group 'project
   1029   :version "27.1")
   1030 
   1031 (defun project--read-file-cpd-relative (prompt
   1032                                         all-files &optional predicate
   1033                                         hist mb-default)
   1034   "Read a file name, prompting with PROMPT.
   1035 ALL-FILES is a list of possible file name completions.
   1036 
   1037 PREDICATE and HIST have the same meaning as in `completing-read'.
   1038 
   1039 MB-DEFAULT is used as part of \"future history\", to be inserted
   1040 by the user at will."
   1041   (let* ((common-parent-directory
   1042           (let ((common-prefix (try-completion "" all-files)))
   1043             (if (> (length common-prefix) 0)
   1044                 (file-name-directory common-prefix))))
   1045          (cpd-length (length common-parent-directory))
   1046          (prompt (if (zerop cpd-length)
   1047                      prompt
   1048                    (concat prompt (format " in %s" common-parent-directory))))
   1049          (included-cpd (when (member common-parent-directory all-files)
   1050                          (setq all-files
   1051                                (delete common-parent-directory all-files))
   1052                          t))
   1053          (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files))
   1054          (_ (when included-cpd
   1055               (setq substrings (cons "./" substrings))))
   1056          (new-collection (project--file-completion-table substrings))
   1057          (abbr-cpd (abbreviate-file-name common-parent-directory))
   1058          (abbr-cpd-length (length abbr-cpd))
   1059          (relname (cl-letf ((history-add-new-input nil)
   1060                             ((symbol-value hist)
   1061                              (mapcan
   1062                               (lambda (s)
   1063                                 (and (string-prefix-p abbr-cpd s)
   1064                                      (not (eq abbr-cpd-length (length s)))
   1065                                      (list (substring s abbr-cpd-length))))
   1066                               (symbol-value hist))))
   1067                     (project--completing-read-strict prompt
   1068                                                      new-collection
   1069                                                      predicate
   1070                                                      hist mb-default)))
   1071          (absname (expand-file-name relname common-parent-directory)))
   1072     (when (and hist history-add-new-input)
   1073       (add-to-history hist (abbreviate-file-name absname)))
   1074     absname))
   1075 
   1076 (defun project--read-file-absolute (prompt
   1077                                     all-files &optional predicate
   1078                                     hist mb-default)
   1079   (project--completing-read-strict prompt
   1080                                    (project--file-completion-table all-files)
   1081                                    predicate
   1082                                    hist mb-default))
   1083 
   1084 (defun project-find-file-in (suggested-filename dirs project &optional include-all)
   1085   "Complete a file name in DIRS in PROJECT and visit the result.
   1086 
   1087 SUGGESTED-FILENAME is a relative file name, or part of it, which
   1088 is used as part of \"future history\".
   1089 
   1090 If INCLUDE-ALL is non-nil, or with prefix argument when called
   1091 interactively, include all files from DIRS, except for VCS
   1092 directories listed in `vc-directory-exclusion-list'."
   1093   (let* ((vc-dirs-ignores (mapcar
   1094                            (lambda (dir)
   1095                              (concat dir "/"))
   1096                            vc-directory-exclusion-list))
   1097          (all-files
   1098           (if include-all
   1099               (mapcan
   1100                (lambda (dir) (project--files-in-directory dir vc-dirs-ignores))
   1101                dirs)
   1102             (project-files project dirs)))
   1103          (completion-ignore-case read-file-name-completion-ignore-case)
   1104          (file (funcall project-read-file-name-function
   1105                         "Find file" all-files nil 'file-name-history
   1106                         suggested-filename)))
   1107     (if (string= file "")
   1108         (user-error "You didn't specify the file")
   1109       (find-file file))))
   1110 
   1111 (defun project--completing-read-strict (prompt
   1112                                         collection &optional predicate
   1113                                         hist mb-default)
   1114   (minibuffer-with-setup-hook
   1115       (lambda ()
   1116         (setq-local minibuffer-default-add-function
   1117                     (lambda ()
   1118                       (let ((minibuffer-default mb-default))
   1119                         (minibuffer-default-add-completions)))))
   1120     (completing-read (format "%s: " prompt)
   1121                      collection predicate 'confirm
   1122                      nil
   1123                      hist)))
   1124 
   1125 ;;;###autoload
   1126 (defun project-find-dir ()
   1127   "Start Dired in a directory inside the current project."
   1128   (interactive)
   1129   (let* ((project (project-current t))
   1130          (all-files (project-files project))
   1131          (completion-ignore-case read-file-name-completion-ignore-case)
   1132          ;; FIXME: This misses directories without any files directly
   1133          ;; inside.  Consider DIRS-ONLY as an argument for
   1134          ;; `project-files-filtered', and see
   1135          ;; https://stackoverflow.com/a/50685235/615245 for possible
   1136          ;; implementation.
   1137          (all-dirs (mapcar #'file-name-directory all-files))
   1138          (dir (funcall project-read-file-name-function
   1139                        "Dired"
   1140                        ;; Some completion UIs show duplicates.
   1141                        (delete-dups all-dirs)
   1142                        nil 'file-name-history)))
   1143     (dired dir)))
   1144 
   1145 ;;;###autoload
   1146 (defun project-dired ()
   1147   "Start Dired in the current project's root."
   1148   (interactive)
   1149   (dired (project-root (project-current t))))
   1150 
   1151 ;;;###autoload
   1152 (defun project-vc-dir ()
   1153   "Run VC-Dir in the current project's root."
   1154   (interactive)
   1155   (vc-dir (project-root (project-current t))))
   1156 
   1157 (declare-function comint-check-proc "comint")
   1158 
   1159 ;;;###autoload
   1160 (defun project-shell ()
   1161   "Start an inferior shell in the current project's root directory.
   1162 If a buffer already exists for running a shell in the project's root,
   1163 switch to it.  Otherwise, create a new shell buffer.
   1164 With \\[universal-argument] prefix arg, create a new inferior shell buffer even
   1165 if one already exists."
   1166   (interactive)
   1167   (require 'comint)
   1168   (let* ((default-directory (project-root (project-current t)))
   1169          (default-project-shell-name (project-prefixed-buffer-name "shell"))
   1170          (shell-buffer (get-buffer default-project-shell-name)))
   1171     (if (and shell-buffer (not current-prefix-arg))
   1172         (if (comint-check-proc shell-buffer)
   1173             (pop-to-buffer shell-buffer (bound-and-true-p display-comint-buffer-action))
   1174           (shell shell-buffer))
   1175       (shell (generate-new-buffer-name default-project-shell-name)))))
   1176 
   1177 ;;;###autoload
   1178 (defun project-eshell ()
   1179   "Start Eshell in the current project's root directory.
   1180 If a buffer already exists for running Eshell in the project's root,
   1181 switch to it.  Otherwise, create a new Eshell buffer.
   1182 With \\[universal-argument] prefix arg, create a new Eshell buffer even
   1183 if one already exists."
   1184   (interactive)
   1185   (defvar eshell-buffer-name)
   1186   (let* ((default-directory (project-root (project-current t)))
   1187          (eshell-buffer-name (project-prefixed-buffer-name "eshell"))
   1188          (eshell-buffer (get-buffer eshell-buffer-name)))
   1189     (if (and eshell-buffer (not current-prefix-arg))
   1190         (pop-to-buffer eshell-buffer (bound-and-true-p display-comint-buffer-action))
   1191       (eshell t))))
   1192 
   1193 ;;;###autoload
   1194 (defun project-async-shell-command ()
   1195   "Run `async-shell-command' in the current project's root directory."
   1196   (declare (interactive-only async-shell-command))
   1197   (interactive)
   1198   (let ((default-directory (project-root (project-current t))))
   1199     (call-interactively #'async-shell-command)))
   1200 
   1201 ;;;###autoload
   1202 (defun project-shell-command ()
   1203   "Run `shell-command' in the current project's root directory."
   1204   (declare (interactive-only shell-command))
   1205   (interactive)
   1206   (let ((default-directory (project-root (project-current t))))
   1207     (call-interactively #'shell-command)))
   1208 
   1209 (declare-function fileloop-continue "fileloop" ())
   1210 
   1211 ;;;###autoload
   1212 (defun project-search (regexp)
   1213   "Search for REGEXP in all the files of the project.
   1214 Stops when a match is found.
   1215 To continue searching for the next match, use the
   1216 command \\[fileloop-continue]."
   1217   (interactive "sSearch (regexp): ")
   1218   (fileloop-initialize-search
   1219    regexp (project-files (project-current t)) 'default)
   1220   (fileloop-continue))
   1221 
   1222 ;;;###autoload
   1223 (defun project-query-replace-regexp (from to)
   1224   "Query-replace REGEXP in all the files of the project.
   1225 Stops when a match is found and prompts for whether to replace it.
   1226 At that prompt, the user must type a character saying what to do
   1227 with the match.  Type SPC or `y' to replace the match,
   1228 DEL or `n' to skip and go to the next match.  For more directions,
   1229 type \\[help-command] at that time.
   1230 If you exit the `query-replace', you can later continue the
   1231 `query-replace' loop using the command \\[fileloop-continue]."
   1232   (interactive
   1233    (let ((query-replace-read-from-regexp-default 'find-tag-default-as-regexp))
   1234      (pcase-let ((`(,from ,to)
   1235                   (query-replace-read-args "Query replace (regexp)" t t)))
   1236        (list from to))))
   1237   (fileloop-initialize-replace
   1238    from to
   1239    ;; XXX: Filter out Git submodules, which are not regular files.
   1240    ;; `project-files' can return those, which is arguably suboptimal,
   1241    ;; but removing them eagerly has performance cost.
   1242    (cl-delete-if-not #'file-regular-p (project-files (project-current t)))
   1243    'default)
   1244   (fileloop-continue))
   1245 
   1246 (defvar compilation-read-command)
   1247 (declare-function compilation-read-command "compile")
   1248 
   1249 (defun project-prefixed-buffer-name (mode)
   1250   (concat "*"
   1251           (file-name-nondirectory
   1252            (directory-file-name default-directory))
   1253           "-"
   1254           (downcase mode)
   1255           "*"))
   1256 
   1257 (defcustom project-compilation-buffer-name-function nil
   1258   "Function to compute the name of a project compilation buffer.
   1259 If non-nil, it overrides `compilation-buffer-name-function' for
   1260 `project-compile'."
   1261   :version "28.1"
   1262   :group 'project
   1263   :type '(choice (const :tag "Default" nil)
   1264                  (const :tag "Prefixed with root directory name"
   1265                         project-prefixed-buffer-name)
   1266                  (function :tag "Custom function")))
   1267 
   1268 ;;;###autoload
   1269 (defun project-compile ()
   1270   "Run `compile' in the project root."
   1271   (declare (interactive-only compile))
   1272   (interactive)
   1273   (let ((default-directory (project-root (project-current t)))
   1274         (compilation-buffer-name-function
   1275          (or project-compilation-buffer-name-function
   1276              compilation-buffer-name-function)))
   1277     (call-interactively #'compile)))
   1278 
   1279 (defcustom project-ignore-buffer-conditions nil
   1280   "List of conditions to filter the buffers to be switched to.
   1281 If any of these conditions are satisfied for a buffer in the
   1282 current project, `project-switch-to-buffer',
   1283 `project-display-buffer' and `project-display-buffer-other-frame'
   1284 ignore it.
   1285 See the doc string of `project-kill-buffer-conditions' for the
   1286 general form of conditions."
   1287   :type '(repeat (choice regexp function symbol
   1288                          (cons :tag "Major mode"
   1289                                (const major-mode) symbol)
   1290                          (cons :tag "Derived mode"
   1291                                (const derived-mode) symbol)
   1292                          (cons :tag "Negation"
   1293                                (const not) sexp)
   1294                          (cons :tag "Conjunction"
   1295                                (const and) sexp)
   1296                          (cons :tag "Disjunction"
   1297                                (const or) sexp)))
   1298   :version "29.1"
   1299   :group 'project
   1300   :package-version '(project . "0.8.2"))
   1301 
   1302 (defun project--read-project-buffer ()
   1303   (let* ((pr (project-current t))
   1304          (current-buffer (current-buffer))
   1305          (other-buffer (other-buffer current-buffer))
   1306          (other-name (buffer-name other-buffer))
   1307          (buffers (project-buffers pr))
   1308          (predicate
   1309           (lambda (buffer)
   1310             ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist.
   1311             (and (memq (cdr buffer) buffers)
   1312                  (not
   1313                   (project--buffer-check
   1314                    (cdr buffer) project-ignore-buffer-conditions))))))
   1315     (read-buffer
   1316      "Switch to buffer: "
   1317      (when (funcall predicate (cons other-name other-buffer))
   1318        other-name)
   1319      nil
   1320      predicate)))
   1321 
   1322 ;;;###autoload
   1323 (defun project-switch-to-buffer (buffer-or-name)
   1324   "Display buffer BUFFER-OR-NAME in the selected window.
   1325 When called interactively, prompts for a buffer belonging to the
   1326 current project.  Two buffers belong to the same project if their
   1327 project instances, as reported by `project-current' in each
   1328 buffer, are identical."
   1329   (interactive (list (project--read-project-buffer)))
   1330   (switch-to-buffer buffer-or-name))
   1331 
   1332 ;;;###autoload
   1333 (defun project-display-buffer (buffer-or-name)
   1334   "Display BUFFER-OR-NAME in some window, without selecting it.
   1335 When called interactively, prompts for a buffer belonging to the
   1336 current project.  Two buffers belong to the same project if their
   1337 project instances, as reported by `project-current' in each
   1338 buffer, are identical.
   1339 
   1340 This function uses `display-buffer' as a subroutine, which see
   1341 for how it is determined where the buffer will be displayed."
   1342   (interactive (list (project--read-project-buffer)))
   1343   (display-buffer buffer-or-name))
   1344 
   1345 ;;;###autoload
   1346 (defun project-display-buffer-other-frame (buffer-or-name)
   1347   "Display BUFFER-OR-NAME preferably in another frame.
   1348 When called interactively, prompts for a buffer belonging to the
   1349 current project.  Two buffers belong to the same project if their
   1350 project instances, as reported by `project-current' in each
   1351 buffer, are identical.
   1352 
   1353 This function uses `display-buffer-other-frame' as a subroutine,
   1354 which see for how it is determined where the buffer will be
   1355 displayed."
   1356   (interactive (list (project--read-project-buffer)))
   1357   (display-buffer-other-frame buffer-or-name))
   1358 
   1359 ;;;###autoload
   1360 (defun project-list-buffers (&optional arg)
   1361   "Display a list of project buffers.
   1362 The list is displayed in a buffer named \"*Buffer List*\".
   1363 
   1364 By default, all project buffers are listed except those whose names
   1365 start with a space (which are for internal use).  With prefix argument
   1366 ARG, show only buffers that are visiting files."
   1367   (interactive "P")
   1368   (let* ((pr (project-current t))
   1369          (buffer-list-function
   1370           (lambda ()
   1371             (seq-filter
   1372              (lambda (buffer)
   1373                (let ((name (buffer-name buffer))
   1374                      (file (buffer-file-name buffer)))
   1375                  (and (or (not (string= (substring name 0 1) " "))
   1376                           file)
   1377                       (not (eq buffer (current-buffer)))
   1378                       (or file (not Buffer-menu-files-only)))))
   1379              (project-buffers pr)))))
   1380     (display-buffer
   1381      (if (version< emacs-version "29.0.50")
   1382          (let ((buf (list-buffers-noselect
   1383                      arg (with-current-buffer
   1384                              (get-buffer-create "*Buffer List*")
   1385                            (let ((Buffer-menu-files-only arg))
   1386                              (funcall buffer-list-function))))))
   1387            (with-current-buffer buf
   1388              (setq-local revert-buffer-function
   1389                          (lambda (&rest _ignored)
   1390                            (list-buffers--refresh
   1391                             (funcall buffer-list-function))
   1392                            (tabulated-list-print t))))
   1393            buf)
   1394        (list-buffers-noselect arg buffer-list-function)))))
   1395 
   1396 (defcustom project-kill-buffer-conditions
   1397   '(buffer-file-name    ; All file-visiting buffers are included.
   1398     ;; Most of temp and logging buffers (aside from hidden ones):
   1399     (and
   1400      (major-mode . fundamental-mode)
   1401      "\\`[^ ]")
   1402     ;; non-text buffer such as xref, occur, vc, log, ...
   1403     (and (derived-mode . special-mode)
   1404          (not (major-mode . help-mode))
   1405          (not (derived-mode . gnus-mode)))
   1406     (derived-mode . compilation-mode)
   1407     (derived-mode . dired-mode)
   1408     (derived-mode . diff-mode)
   1409     (derived-mode . comint-mode)
   1410     (derived-mode . eshell-mode)
   1411     (derived-mode . change-log-mode))
   1412   "List of conditions to kill buffers related to a project.
   1413 This list is used by `project-kill-buffers'.
   1414 Each condition is either:
   1415 - a regular expression, to match a buffer name,
   1416 - a predicate function that takes a buffer object as argument
   1417   and returns non-nil if the buffer should be killed,
   1418 - a cons-cell, where the car describes how to interpret the cdr.
   1419   The car can be one of the following:
   1420   * `major-mode': the buffer is killed if the buffer's major
   1421     mode is eq to the cons-cell's cdr.
   1422   * `derived-mode': the buffer is killed if the buffer's major
   1423     mode is derived from the major mode in the cons-cell's cdr.
   1424   * `not': the cdr is interpreted as a negation of a condition.
   1425   * `and': the cdr is a list of recursive conditions, that all have
   1426     to be met.
   1427   * `or': the cdr is a list of recursive conditions, of which at
   1428     least one has to be met.
   1429 
   1430 If any of these conditions are satisfied for a buffer in the
   1431 current project, it will be killed."
   1432   :type '(repeat (choice regexp function symbol
   1433                          (cons :tag "Major mode"
   1434                                (const major-mode) symbol)
   1435                          (cons :tag "Derived mode"
   1436                                (const derived-mode) symbol)
   1437                          (cons :tag "Negation"
   1438                                (const not) sexp)
   1439                          (cons :tag "Conjunction"
   1440                                (const and) sexp)
   1441                          (cons :tag "Disjunction"
   1442                                (const or) sexp)))
   1443   :version "29.1"
   1444   :group 'project
   1445   :package-version '(project . "0.8.2"))
   1446 
   1447 (defcustom project-kill-buffers-display-buffer-list nil
   1448   "Non-nil to display list of buffers to kill before killing project buffers.
   1449 Used by `project-kill-buffers'."
   1450   :type 'boolean
   1451   :version "29.1"
   1452   :group 'project
   1453   :package-version '(project . "0.8.2")
   1454   :safe #'booleanp)
   1455 
   1456 (defun project--buffer-check (buf conditions)
   1457   "Check if buffer BUF matches any element of the list CONDITIONS.
   1458 See `project-kill-buffer-conditions' or
   1459 `project-ignore-buffer-conditions' for more details on the
   1460 form of CONDITIONS."
   1461   (catch 'match
   1462     (dolist (c conditions)
   1463       (when (cond
   1464              ((stringp c)
   1465               (string-match-p c (buffer-name buf)))
   1466              ((functionp c)
   1467               (funcall c buf))
   1468              ((eq (car-safe c) 'major-mode)
   1469               (eq (buffer-local-value 'major-mode buf)
   1470                   (cdr c)))
   1471              ((eq (car-safe c) 'derived-mode)
   1472               (provided-mode-derived-p
   1473                (buffer-local-value 'major-mode buf)
   1474                (cdr c)))
   1475              ((eq (car-safe c) 'not)
   1476               (not (project--buffer-check buf (cdr c))))
   1477              ((eq (car-safe c) 'or)
   1478               (project--buffer-check buf (cdr c)))
   1479              ((eq (car-safe c) 'and)
   1480               (seq-every-p
   1481                (apply-partially #'project--buffer-check
   1482                                 buf)
   1483                (mapcar #'list (cdr c)))))
   1484         (throw 'match t)))))
   1485 
   1486 (defun project--buffers-to-kill (pr)
   1487   "Return list of buffers in project PR to kill.
   1488 What buffers should or should not be killed is described
   1489 in `project-kill-buffer-conditions'."
   1490   (let (bufs)
   1491     (dolist (buf (project-buffers pr))
   1492       (when (project--buffer-check buf project-kill-buffer-conditions)
   1493         (push buf bufs)))
   1494     bufs))
   1495 
   1496 ;;;###autoload
   1497 (defun project-kill-buffers (&optional no-confirm)
   1498   "Kill the buffers belonging to the current project.
   1499 Two buffers belong to the same project if their project
   1500 instances, as reported by `project-current' in each buffer, are
   1501 identical.  Only the buffers that match a condition in
   1502 `project-kill-buffer-conditions' will be killed.  If NO-CONFIRM
   1503 is non-nil, the command will not ask the user for confirmation.
   1504 NO-CONFIRM is always nil when the command is invoked
   1505 interactively.
   1506 
   1507 Also see the `project-kill-buffers-display-buffer-list' variable."
   1508   (interactive)
   1509   (let* ((pr (project-current t))
   1510          (bufs (project--buffers-to-kill pr))
   1511          (query-user (lambda ()
   1512                        (yes-or-no-p
   1513                         (format "Kill %d buffers in %s? "
   1514                                 (length bufs)
   1515                                 (project-root pr))))))
   1516     (cond (no-confirm
   1517            (mapc #'kill-buffer bufs))
   1518           ((null bufs)
   1519            (message "No buffers to kill"))
   1520           (project-kill-buffers-display-buffer-list
   1521            (when
   1522                (with-current-buffer-window
   1523                    (get-buffer-create "*Buffer List*")
   1524                    `(display-buffer--maybe-at-bottom
   1525                      (dedicated . t)
   1526                      (window-height . (fit-window-to-buffer))
   1527                      (preserve-size . (nil . t))
   1528                      (body-function
   1529                       . ,#'(lambda (_window)
   1530                              (list-buffers-noselect nil bufs))))
   1531                    #'(lambda (window _value)
   1532                        (with-selected-window window
   1533                          (unwind-protect
   1534                              (funcall query-user)
   1535                            (when (window-live-p window)
   1536                              (quit-restore-window window 'kill))))))
   1537              (mapc #'kill-buffer bufs)))
   1538           ((funcall query-user)
   1539            (mapc #'kill-buffer bufs)))))
   1540 
   1541 
   1542 ;;; Project list
   1543 
   1544 (defcustom project-list-file (locate-user-emacs-file "projects")
   1545   "File in which to save the list of known projects."
   1546   :type 'file
   1547   :version "28.1"
   1548   :group 'project)
   1549 
   1550 (defvar project--list 'unset
   1551   "List structure containing root directories of known projects.
   1552 With some possible metadata (to be decided).")
   1553 
   1554 (defun project--read-project-list ()
   1555   "Initialize `project--list' using contents of `project-list-file'."
   1556   (let ((filename project-list-file))
   1557     (setq project--list
   1558           (when (file-exists-p filename)
   1559             (with-temp-buffer
   1560               (insert-file-contents filename)
   1561               (read (current-buffer)))))
   1562     (unless (seq-every-p
   1563              (lambda (elt) (stringp (car-safe elt)))
   1564              project--list)
   1565       (warn "Contents of %s are in wrong format, resetting"
   1566             project-list-file)
   1567       (setq project--list nil))))
   1568 
   1569 (defun project--ensure-read-project-list ()
   1570   "Initialize `project--list' if it isn't already initialized."
   1571   (when (eq project--list 'unset)
   1572     (project--read-project-list)))
   1573 
   1574 (defun project--write-project-list ()
   1575   "Save `project--list' in `project-list-file'."
   1576   (let ((filename project-list-file))
   1577     (with-temp-buffer
   1578       (insert ";;; -*- lisp-data -*-\n")
   1579       (let ((print-length nil)
   1580             (print-level nil))
   1581         (pp project--list (current-buffer)))
   1582       (write-region nil nil filename nil 'silent))))
   1583 
   1584 ;;;###autoload
   1585 (defun project-remember-project (pr &optional no-write)
   1586   "Add project PR to the front of the project list.
   1587 Save the result in `project-list-file' if the list of projects
   1588 has changed, and NO-WRITE is nil."
   1589   (project--ensure-read-project-list)
   1590   (let ((dir (project-root pr)))
   1591     (unless (equal (caar project--list) dir)
   1592       (dolist (ent project--list)
   1593         (when (equal dir (car ent))
   1594           (setq project--list (delq ent project--list))))
   1595       (push (list dir) project--list)
   1596       (unless no-write
   1597         (project--write-project-list)))))
   1598 
   1599 (defun project--remove-from-project-list (project-root report-message)
   1600   "Remove directory PROJECT-ROOT of a missing project from the project list.
   1601 If the directory was in the list before the removal, save the
   1602 result in `project-list-file'.  Announce the project's removal
   1603 from the list using REPORT-MESSAGE, which is a format string
   1604 passed to `message' as its first argument."
   1605   (project--ensure-read-project-list)
   1606   (when-let ((ent (assoc project-root project--list)))
   1607     (setq project--list (delq ent project--list))
   1608     (message report-message project-root)
   1609     (project--write-project-list)))
   1610 
   1611 ;;;###autoload
   1612 (defun project-forget-project (project-root)
   1613   "Remove directory PROJECT-ROOT from the project list.
   1614 PROJECT-ROOT is the root directory of a known project listed in
   1615 the project list."
   1616   (interactive (list (project-prompt-project-dir)))
   1617   (project--remove-from-project-list
   1618    project-root "Project `%s' removed from known projects"))
   1619 
   1620 (defun project-prompt-project-dir ()
   1621   "Prompt the user for a directory that is one of the known project roots.
   1622 The project is chosen among projects known from the project list,
   1623 see `project-list-file'.
   1624 It's also possible to enter an arbitrary directory not in the list."
   1625   (project--ensure-read-project-list)
   1626   (let* ((dir-choice "... (choose a dir)")
   1627          (choices
   1628           ;; XXX: Just using this for the category (for the substring
   1629           ;; completion style).
   1630           (project--file-completion-table
   1631            (append project--list `(,dir-choice))))
   1632          (pr-dir ""))
   1633     (while (equal pr-dir "")
   1634       ;; If the user simply pressed RET, do this again until they don't.
   1635       (setq pr-dir (completing-read "Select project: " choices nil t)))
   1636     (if (equal pr-dir dir-choice)
   1637         (read-directory-name "Select directory: " default-directory nil t)
   1638       pr-dir)))
   1639 
   1640 ;;;###autoload
   1641 (defun project-known-project-roots ()
   1642   "Return the list of root directories of all known projects."
   1643   (project--ensure-read-project-list)
   1644   (mapcar #'car project--list))
   1645 
   1646 ;;;###autoload
   1647 (defun project-execute-extended-command ()
   1648   "Execute an extended command in project root."
   1649   (declare (interactive-only command-execute))
   1650   (interactive)
   1651   (let ((default-directory (project-root (project-current t))))
   1652     (call-interactively #'execute-extended-command)))
   1653 
   1654 (defun project-remember-projects-under (dir &optional recursive)
   1655   "Index all projects below a directory DIR.
   1656 If RECURSIVE is non-nil, recurse into all subdirectories to find
   1657 more projects.  After finishing, a message is printed summarizing
   1658 the progress.  The function returns the number of detected
   1659 projects."
   1660   (interactive "DDirectory: \nP")
   1661   (project--ensure-read-project-list)
   1662   (let ((queue (list dir))
   1663         (count 0)
   1664         (known (make-hash-table
   1665                 :size (* 2 (length project--list))
   1666                 :test #'equal )))
   1667     (dolist (project (mapcar #'car project--list))
   1668       (puthash project t known))
   1669     (while queue
   1670       (when-let ((subdir (pop queue))
   1671                  ((file-directory-p subdir)))
   1672         (when-let ((project (project--find-in-directory subdir))
   1673                    (project-root (project-root project))
   1674                    ((not (gethash project-root known))))
   1675           (project-remember-project project t)
   1676           (puthash project-root t known)
   1677           (message "Found %s..." project-root)
   1678           (setq count (1+ count)))
   1679         (when (and recursive (file-directory-p subdir))
   1680           (setq queue
   1681                 (nconc
   1682                  (directory-files
   1683                   subdir t directory-files-no-dot-files-regexp t)
   1684                  queue)))))
   1685     (unless (eq recursive 'in-progress)
   1686       (if (zerop count)
   1687           (message "No projects were found")
   1688         (project--write-project-list)
   1689         (message "%d project%s were found"
   1690                  count (if (= count 1) "" "s"))))
   1691     count))
   1692 
   1693 (defun project-forget-zombie-projects ()
   1694   "Forget all known projects that don't exist any more."
   1695   (interactive)
   1696   (dolist (proj (project-known-project-roots))
   1697     (unless (file-exists-p proj)
   1698       (project-forget-project proj))))
   1699 
   1700 (defun project-forget-projects-under (dir &optional recursive)
   1701   "Forget all known projects below a directory DIR.
   1702 If RECURSIVE is non-nil, recurse into all subdirectories to
   1703 remove all known projects.  After finishing, a message is printed
   1704 summarizing the progress.  The function returns the number of
   1705 forgotten projects."
   1706   (interactive "DDirectory: \nP")
   1707   (let ((count 0))
   1708     (if recursive
   1709         (dolist (proj (project-known-project-roots))
   1710           (when (file-in-directory-p proj dir)
   1711             (project-forget-project proj)
   1712             (setq count (1+ count))))
   1713       (dolist (proj (project-known-project-roots))
   1714         (when (file-equal-p (file-name-directory proj) dir)
   1715           (project-forget-project proj)
   1716           (setq count (1+ count)))))
   1717     (if (zerop count)
   1718         (message "No projects were forgotten")
   1719       (project--write-project-list)
   1720       (message "%d project%s were forgotten"
   1721                count (if (= count 1) "" "s")))
   1722     count))
   1723 
   1724 
   1725 ;;; Project switching
   1726 
   1727 (defcustom project-switch-commands
   1728   '((project-find-file "Find file")
   1729     (project-find-regexp "Find regexp")
   1730     (project-find-dir "Find directory")
   1731     (project-vc-dir "VC-Dir")
   1732     (project-eshell "Eshell"))
   1733   "Alist mapping commands to descriptions.
   1734 Used by `project-switch-project' to construct a dispatch menu of
   1735 commands available upon \"switching\" to another project.
   1736 
   1737 Each element is of the form (COMMAND LABEL &optional KEY) where
   1738 COMMAND is the command to run when KEY is pressed.  LABEL is used
   1739 to distinguish the menu entries in the dispatch menu.  If KEY is
   1740 absent, COMMAND must be bound in `project-prefix-map', and the
   1741 key is looked up in that map.
   1742 
   1743 The value can also be a symbol, the name of the command to be
   1744 invoked immediately without any dispatch menu."
   1745   :version "28.1"
   1746   :group 'project
   1747   :package-version '(project . "0.6.0")
   1748   :type '(choice
   1749           (repeat :tag "Commands menu"
   1750            (list
   1751             (symbol :tag "Command")
   1752             (string :tag "Label")
   1753             (choice :tag "Key to press"
   1754                     (const :tag "Infer from the keymap" nil)
   1755                     (character :tag "Explicit key"))))
   1756           (symbol :tag "Single command")))
   1757 
   1758 (defcustom project-switch-use-entire-map nil
   1759   "Make `project-switch-project' use entire `project-prefix-map'.
   1760 If nil, `project-switch-project' will only recognize commands
   1761 listed in `project-switch-commands' and signal an error when
   1762 others are invoked.  Otherwise, all keys in `project-prefix-map'
   1763 are legal even if they aren't listed in the dispatch menu."
   1764   :type 'boolean
   1765   :group 'project
   1766   :version "28.1")
   1767 
   1768 (defun project--keymap-prompt ()
   1769   "Return a prompt for the project switching dispatch menu."
   1770   (mapconcat
   1771    (pcase-lambda (`(,cmd ,label ,key))
   1772      (when (characterp cmd) ; Old format, apparently user-customized.
   1773        (let ((tmp cmd))
   1774          ;; TODO: Add a deprecation warning, probably.
   1775          (setq cmd key
   1776                key tmp)))
   1777      (let ((key (if key
   1778                     (vector key)
   1779                   (where-is-internal cmd (list project-prefix-map) t))))
   1780        (format "[%s] %s"
   1781                (propertize (key-description key) 'face 'bold)
   1782                label)))
   1783    project-switch-commands
   1784    "  "))
   1785 
   1786 (defun project--switch-project-command ()
   1787   (let* ((commands-menu
   1788           (mapcar
   1789            (lambda (row)
   1790              (if (characterp (car row))
   1791                  ;; Deprecated format.
   1792                  ;; XXX: Add a warning about it?
   1793                  (reverse row)
   1794                row))
   1795            project-switch-commands))
   1796          (commands-map
   1797           (let ((temp-map (make-sparse-keymap)))
   1798             (set-keymap-parent temp-map project-prefix-map)
   1799             (dolist (row commands-menu temp-map)
   1800               (when-let ((cmd (nth 0 row))
   1801                          (keychar (nth 2 row)))
   1802                 (define-key temp-map (vector keychar) cmd)))))
   1803          command)
   1804     (while (not command)
   1805       (let* ((overriding-local-map commands-map)
   1806              (choice (read-key-sequence (project--keymap-prompt))))
   1807         (when (setq command (lookup-key commands-map choice))
   1808           (unless (or project-switch-use-entire-map
   1809                       (assq command commands-menu))
   1810             ;; TODO: Add some hint to the prompt, like "key not
   1811             ;; recognized" or something.
   1812             (setq command nil)))
   1813         (let ((global-command (lookup-key (current-global-map) choice)))
   1814           (when (memq global-command
   1815                       '(keyboard-quit keyboard-escape-quit))
   1816             (call-interactively global-command)))))
   1817     command))
   1818 
   1819 ;;;###autoload
   1820 (defun project-switch-project (dir)
   1821   "\"Switch\" to another project by running an Emacs command.
   1822 The available commands are presented as a dispatch menu
   1823 made from `project-switch-commands'.
   1824 
   1825 When called in a program, it will use the project corresponding
   1826 to directory DIR."
   1827   (interactive (list (project-prompt-project-dir)))
   1828   (let ((command (if (symbolp project-switch-commands)
   1829                      project-switch-commands
   1830                    (project--switch-project-command))))
   1831     (let ((project-current-directory-override dir))
   1832       (call-interactively command))))
   1833 
   1834 (provide 'project)
   1835 ;;; project.el ends here
	dotemacs My Emacs configuration
	git clone git://git.entf.net/dotemacs
	Log \| Files \| Refs \| LICENSE