aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/emacs-lisp/package.el4583
1 files changed, 4583 insertions, 0 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
new file mode 100644
index 00000000000..14f7555a3f1
--- /dev/null
+++ b/lisp/emacs-lisp/package.el
@@ -0,0 +1,4583 @@
1;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
2
3;; Copyright (C) 2007-2026 Free Software Foundation, Inc.
4
5;; Author: Tom Tromey <tromey@redhat.com>
6;; Daniel Hackney <dan@haxney.org>
7;; Created: 10 Mar 2007
8;; Version: 1.1.0
9;; Keywords: tools
10;; Package-Requires: ((tabulated-list "1.0"))
11
12;; This file is part of GNU Emacs.
13
14;; GNU Emacs is free software: you can redistribute it and/or modify
15;; it under the terms of the GNU General Public License as published by
16;; the Free Software Foundation, either version 3 of the License, or
17;; (at your option) any later version.
18
19;; GNU Emacs is distributed in the hope that it will be useful,
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;; GNU General Public License for more details.
23
24;; You should have received a copy of the GNU General Public License
25;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26
27;;; Commentary:
28
29;; The idea behind package.el is to be able to download packages and
30;; install them. Packages are versioned and have versioned
31;; dependencies. Furthermore, this supports built-in packages which
32;; may or may not be newer than user-specified packages. This makes
33;; it possible to upgrade Emacs and automatically disable packages
34;; which have moved from external to core. (Note though that we don't
35;; currently register any of these, so this feature does not actually
36;; work.)
37
38;; A package is described by its name and version. The distribution
39;; format is either a tar file or a single .el file.
40
41;; A tar file should be named "NAME-VERSION.tar". The tar file must
42;; unpack into a directory named after the package and version:
43;; "NAME-VERSION". It must contain a file named "PACKAGE-pkg.el"
44;; which consists of a call to define-package. It may also contain a
45;; "dir" file and the info files it references.
46
47;; A .el file is named "NAME-VERSION.el" in the remote archive, but is
48;; installed as simply "NAME.el" in a directory named "NAME-VERSION".
49
50;; The downloader downloads all dependent packages. By default,
51;; packages come from the official GNU sources, but others may be
52;; added by customizing the `package-archives' alist. Packages get
53;; byte-compiled at install time.
54
55;; At activation time we will set up the load-path and the info path,
56;; and we will load the package's autoloads. If a package's
57;; dependencies are not available, we will not activate that package.
58
59;; Conceptually a package has multiple state transitions:
60;;
61;; * Download. Fetching the package from ELPA.
62;; * Install. Untar the package, or write the .el file, into
63;; ~/.emacs.d/elpa/ directory.
64;; * Autoload generation.
65;; * Byte compile. Currently this phase is done during install,
66;; but we may change this.
67;; * Activate. Evaluate the autoloads for the package to make it
68;; available to the user.
69;; * Load. Actually load the package and run some code from it.
70
71;; Other external functions you may want to use:
72;;
73;; M-x list-packages
74;; Enters a mode similar to buffer-menu which lets you manage
75;; packages. You can choose packages for install (mark with "i",
76;; then "x" to execute) or deletion, and you can see what packages
77;; are available. This will automatically fetch the latest list of
78;; packages from ELPA.
79;;
80;; M-x package-install-from-buffer
81;; Install a package consisting of a single .el file that appears
82;; in the current buffer. This only works for packages which
83;; define a Version header properly; package.el also supports the
84;; extension headers Package-Version (in case Version is an RCS id
85;; or similar), and Package-Requires (if the package requires other
86;; packages).
87;;
88;; M-x package-install-file
89;; Install a package from the indicated file. The package can be
90;; either a tar file or a .el file. A tar file must contain an
91;; appropriately-named "-pkg.el" file; a .el file must be properly
92;; formatted as with `package-install-from-buffer'.
93
94;;; Thanks:
95;;; (sorted by sort-lines):
96
97;; Jim Blandy <jimb@red-bean.com>
98;; Karl Fogel <kfogel@red-bean.com>
99;; Kevin Ryde <user42@zip.com.au>
100;; Lawrence Mitchell
101;; Michael Olson <mwolson@member.fsf.org>
102;; Sebastian Tennant <sebyte@smolny.plus.com>
103;; Stefan Monnier <monnier@iro.umontreal.ca>
104;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>
105;; Phil Hagelberg <phil@hagelb.org>
106
107;;; ToDo:
108
109;; - putting info dirs at the start of the info path means
110;; users see a weird ordering of categories. OTOH we want to
111;; override later entries. maybe emacs needs to enforce
112;; the standard layout?
113;; - put bytecode in a separate directory tree
114;; - perhaps give users a way to recompile their bytecode
115;; or do it automatically when emacs changes
116;; - give users a way to know whether a package is installed ok
117;; - give users a way to view a package's documentation when it
118;; only appears in the .el
119;; - use/extend checkdoc so people can tell if their package will work
120;; - "installed" instead of a blank in the status column
121;; - tramp needs its files to be compiled in a certain order.
122;; how to handle this? fix tramp?
123;; - maybe we need separate .elc directories for various emacs
124;; versions. That way conditional compilation can work. But would
125;; this break anything?
126;; - William Xu suggests being able to open a package file without
127;; installing it
128;; - Interface with desktop.el so that restarting after an install
129;; works properly
130;; - Use hierarchical layout. PKG/etc PKG/lisp PKG/info
131;; ... except maybe lisp?
132;; - It may be nice to have a macro that expands to the package's
133;; private data dir, aka ".../etc". Or, maybe data-directory
134;; needs to be a list (though this would be less nice)
135;; a few packages want this, eg sokoban
136;; - Allow multiple versions on the server, so that if a user doesn't
137;; meet the requirements for the most recent version they can still
138;; install an older one.
139;; - Allow optional package dependencies
140;; then if we require 'bbdb', bbdb-specific lisp in lisp/bbdb
141;; and just don't compile to add to load path ...?
142;; - Our treatment of the info path is somewhat bogus
143
144;;; Code:
145
146(require 'package-activate)
147
148(require 'cl-lib)
149(eval-when-compile (require 'subr-x))
150(eval-when-compile (require 'epg)) ;For setf accessors.
151(eval-when-compile (require 'inline)) ;For `define-inline'
152(require 'seq)
153
154(require 'tabulated-list)
155(require 'macroexp)
156(require 'url-handlers)
157(require 'browse-url)
158
159(defgroup package nil
160 "Manager for Emacs Lisp packages."
161 :group 'applications
162 :version "24.1")
163
164
165;;; Customization options
166
167;;;###autoload
168(defcustom package-enable-at-startup t
169 "Whether to make installed packages available when Emacs starts.
170If non-nil, packages are made available before reading the init
171file (but after reading the early init file). This means that if
172you wish to set this variable, you must do so in the early init
173file. Regardless of the value of this variable, packages are not
174made available if `user-init-file' is nil (e.g. Emacs was started
175with \"-q\").
176
177Even if the value is nil, you can type \\[package-initialize] to
178make installed packages available at any time, or you can
179call (package-activate-all) in your init-file.
180
181Note that this variable must be set to a non-default value in
182your early-init file, as the variable's value is used before
183loading the regular init file. Therefore, if you customize it
184via Customize, you should save your customized setting into
185your `early-init-file'."
186 :type 'boolean
187 :version "24.1")
188
189(defcustom package-archives `(("gnu" .
190 ,(format "http%s://elpa.gnu.org/packages/"
191 (if (gnutls-available-p) "s" "")))
192 ("nongnu" .
193 ,(format "http%s://elpa.nongnu.org/nongnu/"
194 (if (gnutls-available-p) "s" ""))))
195 "An alist of archives from which to fetch.
196The default value points to the GNU Emacs package repository.
197
198Each element has the form (ID . LOCATION).
199 ID is an archive name, as a string.
200 LOCATION specifies the base location for the archive.
201 If it starts with \"http(s):\", it is treated as an HTTP(S) URL;
202 otherwise it should be an absolute directory name.
203 (Other types of URL are currently not supported.)
204
205Only add locations that you trust, since fetching and installing
206a package can run arbitrary code.
207
208HTTPS URLs should be used where possible, as they offer superior
209security."
210 :type '(alist :key-type (string :tag "Archive name")
211 :value-type (string :tag "URL or directory name"))
212 :risky t
213 :version "28.1")
214
215(defcustom package-menu-hide-low-priority 'archive
216 "If non-nil, hide low priority packages from the packages menu.
217A package is considered low priority if there's another version
218of it available such that:
219 (a) the archive of the other package is higher priority than
220 this one, as per `package-archive-priorities';
221 or
222 (b) they both have the same archive priority but the other
223 package has a higher version number.
224
225This variable has three possible values:
226 nil: no packages are hidden;
227 `archive': only criterion (a) is used;
228 t: both criteria are used.
229
230This variable has no effect if `package-menu--hide-packages' is
231nil, so it can be toggled with \\<package-menu-mode-map>\\[package-menu-toggle-hiding]."
232 :type '(choice (const :tag "Don't hide anything" nil)
233 (const :tag "Hide per package-archive-priorities"
234 archive)
235 (const :tag "Hide per archive and version number" t))
236 :version "25.1")
237
238(defcustom package-archive-priorities nil
239 "An alist of priorities for packages.
240
241Each element has the form (ARCHIVE-ID . PRIORITY).
242
243When installing packages, the package with the highest version
244number from the archive with the highest priority is
245selected. When higher versions are available from archives with
246lower priorities, the user has to select those manually.
247
248Archives not in this list have the priority 0, as have packages
249that are already installed. If you use negative priorities for
250the archives, they will not be upgraded automatically.
251
252See also `package-menu-hide-low-priority'."
253 :type '(alist :key-type (string :tag "Archive name")
254 :value-type (integer :tag "Priority (default is 0)"))
255 :risky t
256 :version "25.1")
257
258(defcustom package-pinned-packages nil
259 "An alist of packages that are pinned to specific archives.
260This can be useful if you have multiple package archives enabled,
261and want to control which archive a given package gets installed from.
262
263Each element of the alist has the form (PACKAGE . ARCHIVE), where:
264 PACKAGE is a symbol representing a package
265 ARCHIVE is a string representing an archive (it should be the car of
266an element in `package-archives', e.g. \"gnu\").
267
268Adding an entry to this variable means that only ARCHIVE will be
269considered as a source for PACKAGE. If other archives provide PACKAGE,
270they are ignored (for this package). If ARCHIVE does not contain PACKAGE,
271the package will be unavailable."
272 :type '(alist :key-type (symbol :tag "Package")
273 :value-type (string :tag "Archive name"))
274 ;; This could prevent you from receiving updates for a package,
275 ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue
276 ;; if PACKAGE has a known vulnerability that is fixed in newer versions.
277 :risky t
278 :version "24.4")
279
280;;;###autoload
281(defcustom package-user-dir (locate-user-emacs-file "elpa")
282 "Directory containing the user's Emacs Lisp packages.
283The directory name should be absolute.
284Apart from this directory, Emacs also looks for system-wide
285packages in `package-directory-list'."
286 :type 'directory
287 :initialize #'custom-initialize-delay
288 :risky t
289 :group 'applications
290 :version "24.1")
291
292;;;###autoload
293(defcustom package-directory-list
294 ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
295 (let (result)
296 (dolist (f load-path)
297 (and (stringp f)
298 (equal (file-name-nondirectory f) "site-lisp")
299 (push (expand-file-name "elpa" f) result)))
300 (nreverse result))
301 "List of additional directories containing Emacs Lisp packages.
302Each directory name should be absolute.
303
304These directories contain packages intended for system-wide; in
305contrast, `package-user-dir' contains packages for personal use."
306 :type '(repeat directory)
307 :initialize #'custom-initialize-delay
308 :group 'applications
309 :risky t
310 :version "24.1")
311
312(declare-function epg-find-configuration "epg-config"
313 (protocol &optional no-cache program-alist))
314
315(defcustom package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)
316 "Directory containing GnuPG keyring or nil.
317This variable specifies the GnuPG home directory used by package.
318That directory is passed via the option \"--homedir\" to GnuPG.
319If nil, do not use the option \"--homedir\", but stick with GnuPG's
320default directory."
321 :type `(choice
322 (const
323 :tag "Default Emacs package management GnuPG home directory"
324 ,(expand-file-name "gnupg" package-user-dir))
325 (const
326 :tag "Default GnuPG directory (GnuPG option --homedir not used)"
327 nil)
328 (directory :tag "A specific GnuPG --homedir"))
329 :risky t
330 :version "26.1")
331
332(defcustom package-check-signature 'allow-unsigned
333 "Non-nil means to check package signatures when installing.
334
335This also applies to the \"archive-contents\" file that lists the
336contents of the archive.
337
338The value can be one of:
339
340 t Accept a package only if it comes with at least
341 one verified signature.
342
343 `all' Same as t, but verify all signatures if there
344 are more than one.
345
346 `allow-unsigned' Install a package even if it is unsigned,
347 but verify the signature if possible (that
348 is, if it is signed, we have the key for it,
349 and GnuPG is installed).
350
351 nil Package signatures are ignored."
352 :type '(choice (const :value nil :tag "Never")
353 (const :value allow-unsigned :tag "Allow unsigned")
354 (const :value t :tag "Check always")
355 (const :value all :tag "Check always (all signatures)"))
356 :risky t
357 :version "27.1")
358
359(defun package-check-signature ()
360 "Check whether we have a usable OpenPGP configuration.
361If so, and variable `package-check-signature' is
362`allow-unsigned', return `allow-unsigned', otherwise return the
363value of variable `package-check-signature'."
364 (if (eq package-check-signature 'allow-unsigned)
365 (and (epg-find-configuration 'OpenPGP)
366 'allow-unsigned)
367 package-check-signature))
368
369(defcustom package-unsigned-archives nil
370 "List of archives where we do not check for package signatures.
371This should be a list of strings matching the names of package
372archives in the variable `package-archives'."
373 :type '(repeat (string :tag "Archive name"))
374 :risky t
375 :version "24.4")
376
377(defcustom package-selected-packages nil
378 "Store here packages installed explicitly by user.
379This variable is fed automatically by Emacs when installing a new package.
380This variable is used by `package-autoremove' to decide
381which packages are no longer needed.
382You can use it to (re)install packages on other machines
383by running `package-install-selected-packages'.
384
385To check if a package is contained in this list here, use
386`package--user-selected-p', as it may populate the variable with
387a sane initial value."
388 :version "25.1"
389 :type '(repeat symbol))
390
391(defcustom package-native-compile nil
392 "Non-nil means to natively compile packages as part of their installation.
393This controls ahead-of-time compilation of packages when they are
394installed. If this option is nil, packages will be natively
395compiled when they are loaded for the first time.
396
397This option does not have any effect if Emacs was not built with
398native compilation support."
399 :type '(boolean)
400 :risky t
401 :version "28.1")
402
403(defcustom package-menu-async t
404 "If non-nil, package-menu will use async operations when possible.
405Currently, only the refreshing of archive contents supports
406asynchronous operations. Package transactions are still done
407synchronously."
408 :type 'boolean
409 :version "25.1")
410
411(defcustom package-name-column-width 30
412 "Column width for the Package name in the package menu."
413 :type 'natnum
414 :version "28.1")
415
416(defcustom package-version-column-width 14
417 "Column width for the Package version in the package menu."
418 :type 'natnum
419 :version "28.1")
420
421(defcustom package-status-column-width 12
422 "Column width for the Package status in the package menu."
423 :type 'natnum
424 :version "28.1")
425
426(defcustom package-archive-column-width 8
427 "Column width for the Package archive in the package menu."
428 :type 'natnum
429 :version "28.1")
430
431
432;;; `package-desc' object definition
433;; This is the struct used internally to represent packages.
434;; Functions that deal with packages should generally take this object
435;; as an argument. In some situations (e.g. commands that query the
436;; user) it makes sense to take the package name as a symbol instead,
437;; but keep in mind there could be multiple `package-desc's with the
438;; same name.
439
440(defun package--from-builtin (bi-desc)
441 "Create a `package-desc' object from BI-DESC.
442BI-DESC should be a `package--bi-desc' object."
443 (package-desc-create :name (pop bi-desc)
444 :version (package--bi-desc-version bi-desc)
445 :summary (package--bi-desc-summary bi-desc)
446 :dir 'builtin))
447
448(defun package-desc-suffix (pkg-desc)
449 "Return file-name extension of package-desc object PKG-DESC.
450Depending on the `package-desc-kind' of PKG-DESC, this is one of:
451
452 \\='single - \".el\"
453 \\='tar - \".tar\"
454 \\='dir - \"\"
455
456Signal an error if the kind is none of the above."
457 (pcase (package-desc-kind pkg-desc)
458 ('single ".el")
459 ('tar ".tar")
460 ('dir "")
461 (kind (error "Unknown package kind: %s" kind))))
462
463(defun package-desc--keywords (pkg-desc)
464 "Return keywords of package-desc object PKG-DESC.
465These keywords come from the foo-pkg.el file, and in general
466corresponds to the keywords in the \"Keywords\" header of the
467package."
468 (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc)))))
469 (if (eq (car-safe keywords) 'quote)
470 (nth 1 keywords)
471 keywords)))
472
473(defun package-desc-priority (pkg-desc)
474 "Return the priority of the archive of package-desc object PKG-DESC."
475 (package-archive-priority (package-desc-archive pkg-desc)))
476
477(defun package--parse-elpaignore (pkg-desc)
478 "Return a list of regular expressions to match files ignored by PKG-DESC."
479 (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
480 (ignore (expand-file-name ".elpaignore" pkg-dir))
481 files)
482 (when (file-exists-p ignore)
483 (with-temp-buffer
484 (insert-file-contents ignore)
485 (goto-char (point-min))
486 (while (not (eobp))
487 (push (wildcard-to-regexp
488 (let ((line (buffer-substring
489 (line-beginning-position)
490 (line-end-position))))
491 (file-name-concat pkg-dir (string-trim-left line "/"))))
492 files)
493 (forward-line)))
494 files)))
495
496(cl-defstruct (package--bi-desc
497 (:constructor package-make-builtin (version summary))
498 (:type vector))
499 "Package descriptor format used in finder-inf.el and package--builtins."
500 version
501 reqs
502 summary)
503
504
505;;; Installed packages
506
507;; The following functions are called on each installed package by
508;; `package-load-all-descriptors', which ultimately populates the
509;; `package-alist' variable.
510
511(declare-function package-vc-version "package-vc" (pkg))
512
513(defun package-process-define-package (exp)
514 "Process define-package expression EXP and push it to `package-alist'.
515EXP should be a form read from a foo-pkg.el file.
516Convert EXP into a `package-desc' object using the
517`package-desc-from-define' constructor before pushing it to
518`package-alist'.
519
520If there already exists a package by the same name in
521`package-alist', insert this object there such that the packages
522are sorted with the highest version first."
523 (when (eq (car-safe exp) 'define-package)
524 (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp)))
525 (name (package-desc-name new-pkg-desc))
526 (version (package-desc-version new-pkg-desc))
527 (old-pkgs (assq name package-alist)))
528 (if (null old-pkgs)
529 ;; If there's no old package, just add this to `package-alist'.
530 (push (list name new-pkg-desc) package-alist)
531 ;; If there is, insert the new package at the right place in the list.
532 (while
533 (if (and (cdr old-pkgs)
534 (version-list-< version
535 (package-desc-version (cadr old-pkgs))))
536 (setq old-pkgs (cdr old-pkgs))
537 (push new-pkg-desc (cdr old-pkgs))
538 nil)))
539 new-pkg-desc)))
540
541(declare-function package-vc-commit "package-vc" (pkg))
542
543(defun define-package ( _name-string _version-string
544 &optional _docstring _requirements
545 &rest _extra-properties)
546 "Define a new package.
547NAME-STRING is the name of the package, as a string.
548VERSION-STRING is the version of the package, as a string.
549DOCSTRING is a short description of the package, a string.
550REQUIREMENTS is a list of dependencies on other packages.
551 Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
552 where OTHER-VERSION is a string.
553
554EXTRA-PROPERTIES is currently unused."
555 (declare (obsolete nil "29.1") (indent defun))
556 (error "Don't call me!"))
557
558(defun package--active-built-in-p (package)
559 "Return non-nil if the built-in version of PACKAGE is used.
560If the built-in version of PACKAGE is used and PACKAGE is
561also available for installation from an archive, it is an
562indication that PACKAGE was never upgraded to any newer
563version from the archive."
564 (and (not (assq (cond
565 ((package-desc-p package)
566 (package-desc-name package))
567 ((stringp package) (intern package))
568 ((symbolp package) package)
569 ((error "Unknown package format: %S" package)))
570 (package--alist)))
571 (package-built-in-p package)))
572
573(defsubst package--library-stem (file)
574 (catch 'done
575 (let (result)
576 (dolist (suffix (get-load-suffixes) file)
577 (setq result (string-trim file nil suffix))
578 (unless (equal file result)
579 (throw 'done result))))))
580
581(defun package--reload-previously-loaded (pkg-desc &optional warn)
582 "Force reimportation of files in PKG-DESC already present in `load-history'.
583New editions of files contain macro definitions and
584redefinitions, the overlooking of which would cause
585byte-compilation of the new package to fail.
586If WARN is a string, display a warning (using WARN as a format string)
587before reloading the files. WARN must have two %-sequences
588corresponding to package name (a symbol) and a list of files loaded (as
589sexps)."
590 (with-demoted-errors "Error in package--load-files-for-activation: %s"
591 (let* (result
592 (dir (package-desc-dir pkg-desc))
593 ;; A previous implementation would skip `dir' itself.
594 ;; However, in normal use reloading from the same directory
595 ;; never happens anyway, while in certain cases external to
596 ;; Emacs a package in the same directory not necessary
597 ;; stays byte-identical, e.g. during development. Just
598 ;; don't special-case `dir'.
599 (effective-path (or (bound-and-true-p find-library-source-path)
600 load-path))
601 (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))
602 (history (mapcar #'file-truename
603 (cl-remove-if-not #'stringp
604 (mapcar #'car load-history)))))
605 (dolist (file files)
606 (when-let* ((library (package--library-stem
607 (file-relative-name file dir)))
608 (canonical (locate-library library nil effective-path))
609 (truename (file-truename canonical))
610 ;; Normally, all files in a package are compiled by
611 ;; now, but don't assume that. E.g. different
612 ;; versions can add or remove `no-byte-compile'.
613 (altname (if (string-suffix-p ".el" truename)
614 (replace-regexp-in-string
615 "\\.el\\'" ".elc" truename t)
616 (replace-regexp-in-string
617 "\\.elc\\'" ".el" truename t)))
618 (found (or (member truename history)
619 (and (not (string= altname truename))
620 (member altname history))))
621 (recent-index (length found)))
622 (unless (equal (file-name-base library)
623 (format "%s-autoloads" (package-desc-name pkg-desc)))
624 (push (cons (expand-file-name library dir) recent-index) result))))
625 (when (and result warn)
626 (display-warning 'package
627 (format warn (package-desc-name pkg-desc)
628 (mapcar #'car result))))
629 (mapc (lambda (c) (load (car c) nil t))
630 (sort result (lambda (x y) (< (cdr x) (cdr y))))))))
631
632
633;;; Installation -- Local operations
634;; This section contains a variety of features regarding installing a
635;; package to/from disk. This includes autoload generation,
636;; unpacking, compiling, as well as defining a package from the
637;; current buffer.
638
639;;;; Unpacking
640(defvar tar-parse-info)
641(declare-function tar-untar-buffer "tar-mode" ())
642(declare-function tar-header-name "tar-mode" (tar-header) t)
643(declare-function tar-header-link-type "tar-mode" (tar-header) t)
644
645(defun package-untar-buffer (dir)
646 "Untar the current buffer.
647This uses `tar-untar-buffer' from Tar mode. All files should
648untar into a directory named DIR; otherwise, signal an error."
649 (tar-mode)
650 (unwind-protect
651 (progn
652 ;; Make sure everything extracts into DIR.
653 (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
654 (case-fold-search (file-name-case-insensitive-p dir)))
655 (dolist (tar-data tar-parse-info)
656 (let ((name (expand-file-name (tar-header-name tar-data))))
657 (or (string-match regexp name)
658 ;; Tarballs created by some utilities don't list
659 ;; directories with a trailing slash (Bug#13136).
660 (and (string-equal (expand-file-name dir) name)
661 (eq (tar-header-link-type tar-data) 5))
662 (error "Package does not untar cleanly into directory %s/"
663 dir)))))
664 (tar-untar-buffer))
665 (fundamental-mode))) ; free auxiliary tar-mode data
666
667(defun package--alist-to-plist-args (alist)
668 (mapcar #'macroexp-quote
669 (apply #'nconc
670 (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
671
672(declare-function dired-get-marked-files "dired")
673
674(defun package-unpack (pkg-desc)
675 "Install the contents of the current buffer as a package."
676 (let* ((name (package-desc-name pkg-desc))
677 (dirname (package-desc-full-name pkg-desc))
678 (pkg-dir (expand-file-name dirname package-user-dir)))
679 (pcase (package-desc-kind pkg-desc)
680 ('dir
681 (make-directory pkg-dir t)
682 (let ((file-list
683 (or (and (derived-mode-p 'dired-mode)
684 (dired-get-marked-files nil 'marked))
685 (directory-files-recursively default-directory "" nil))))
686 (dolist (source-file file-list)
687 (let ((target (expand-file-name
688 (file-relative-name source-file default-directory)
689 pkg-dir)))
690 (make-directory (file-name-directory target) t)
691 (copy-file source-file target t)))
692 ;; Now that the files have been installed, this package is
693 ;; indistinguishable from a `tar' or a `single'. Let's make
694 ;; things simple by ensuring we're one of them.
695 (setf (package-desc-kind pkg-desc)
696 (if (length> file-list 1) 'tar 'single))))
697 ('tar
698 (make-directory package-user-dir t)
699 (let* ((default-directory (file-name-as-directory package-user-dir)))
700 (package-untar-buffer dirname)))
701 ('single
702 (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir)))
703 (make-directory pkg-dir t)
704 (package--write-file-no-coding el-file)))
705 (kind (error "Unknown package kind: %S" kind)))
706 (package--make-autoloads-and-stuff pkg-desc pkg-dir)
707 ;; Update package-alist.
708 (let ((new-desc (package-load-descriptor pkg-dir)))
709 (unless (equal (package-desc-full-name new-desc)
710 (package-desc-full-name pkg-desc))
711 (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')"
712 (package-desc-full-name new-desc) (package-desc-full-name pkg-desc)))
713 ;; Activation has to be done before compilation, so that if we're
714 ;; upgrading and macros have changed we load the new definitions
715 ;; before compiling.
716 (when (package-activate-1 new-desc :reload :deps)
717 ;; FIXME: Compilation should be done as a separate, optional, step.
718 ;; E.g. for multi-package installs, we should first install all packages
719 ;; and then compile them.
720 (package--compile new-desc)
721 (when package-native-compile
722 (package--native-compile-async new-desc))
723 ;; After compilation, load again any files loaded by
724 ;; `activate-1', so that we use the byte-compiled definitions.
725 (package--reload-previously-loaded new-desc)))
726 pkg-dir))
727
728(defun package-generate-description-file (pkg-desc pkg-file)
729 "Create the foo-pkg.el file PKG-FILE for single-file package PKG-DESC."
730 (let* ((name (package-desc-name pkg-desc)))
731 (let ((print-level nil)
732 (print-quoted t)
733 (print-length nil))
734 (write-region
735 (concat
736 ";;; Generated package description from "
737 (replace-regexp-in-string "-pkg\\.el\\'" ".el"
738 (file-name-nondirectory pkg-file))
739 " -*- no-byte-compile: t -*-\n"
740 (prin1-to-string
741 (nconc
742 (list 'define-package
743 (symbol-name name)
744 (package-version-join (package-desc-version pkg-desc))
745 (package-desc-summary pkg-desc)
746 (let ((requires (package-desc-reqs pkg-desc)))
747 (list 'quote
748 ;; Turn version lists into string form.
749 (mapcar
750 (lambda (elt)
751 (list (car elt)
752 (package-version-join (cadr elt))))
753 requires))))
754 (package--alist-to-plist-args
755 (package-desc-extras pkg-desc))))
756 "\n")
757 nil pkg-file nil 'silent))))
758
759
760;;;; Autoload
761(declare-function autoload-rubric "autoload" (file &optional type feature))
762
763(defun package-autoload-ensure-default-file (file)
764 "Make sure that the autoload file FILE exists and if not create it."
765 (declare (obsolete nil "29.1"))
766 (unless (file-exists-p file)
767 (require 'autoload)
768 (let ((coding-system-for-write 'utf-8-emacs-unix))
769 (with-suppressed-warnings ((obsolete autoload-rubric))
770 (write-region (autoload-rubric file "package" nil)
771 nil file nil 'silent))))
772 file)
773
774(defvar autoload-timestamps)
775(defvar version-control)
776
777(defun package-generate-autoloads (name pkg-dir)
778 "Generate autoloads in PKG-DIR for package named NAME."
779 (let* ((auto-name (format "%s-autoloads.el" name))
780 ;;(ignore-name (concat name "-pkg.el"))
781 (output-file (expand-file-name auto-name pkg-dir))
782 ;; We don't need 'em, and this makes the output reproducible.
783 (autoload-timestamps nil)
784 (backup-inhibited t)
785 (version-control 'never))
786 (loaddefs-generate
787 pkg-dir output-file nil
788 (prin1-to-string
789 '(add-to-list
790 'load-path
791 ;; Add the directory that will contain the autoload file to
792 ;; the load path. We don't hard-code `pkg-dir', to avoid
793 ;; issues if the package directory is moved around.
794 ;; `loaddefs-generate' has code to do this for us, but it's
795 ;; not currently exposed. (Bug#63625)
796 (or (and load-file-name
797 (directory-file-name
798 (file-name-directory load-file-name)))
799 (car load-path)))))
800 (let ((buf (find-buffer-visiting output-file)))
801 (when buf (kill-buffer buf)))
802 auto-name))
803
804(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir)
805 "Generate autoloads, description file, etc., for PKG-DESC installed at PKG-DIR."
806 (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir)
807 (let ((desc-file (expand-file-name (package--description-file pkg-dir)
808 pkg-dir)))
809 (unless (file-exists-p desc-file)
810 (package-generate-description-file pkg-desc desc-file)))
811 ;; FIXME: Create foo.info and dir file from foo.texi?
812 )
813
814;;;; Compilation
815(defvar warning-minimum-level)
816(defvar byte-compile-ignore-files)
817(defun package--compile (pkg-desc)
818 "Byte-compile installed package PKG-DESC.
819This assumes that `pkg-desc' has already been activated with
820`package-activate-1'."
821 (let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc))
822 (warning-minimum-level :error)
823 (load-path load-path))
824 (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
825
826(defun package--native-compile-async (pkg-desc)
827 "Native compile installed package PKG-DESC asynchronously.
828This assumes that `pkg-desc' has already been activated with
829`package-activate-1'."
830 (when (native-comp-available-p)
831 (let ((warning-minimum-level :error))
832 (native-compile-async (package-desc-dir pkg-desc) t))))
833
834;;;; Inferring package from current buffer
835(defun package-read-from-string (str)
836 "Read a Lisp expression from STR.
837Signal an error if the entire string was not used."
838 (pcase-let ((`(,expr . ,offset) (read-from-string str)))
839 (condition-case ()
840 ;; The call to `ignore' suppresses a compiler warning.
841 (progn (ignore (read-from-string str offset))
842 (error "Can't read whole string"))
843 (end-of-file expr))))
844
845(declare-function lm-header "lisp-mnt" (header))
846(declare-function lm-package-requires "lisp-mnt" (&optional file))
847(declare-function lm-package-version "lisp-mnt" (&optional file))
848(declare-function lm-website "lisp-mnt" (&optional file))
849(declare-function lm-keywords-list "lisp-mnt" (&optional file))
850(declare-function lm-maintainers "lisp-mnt" (&optional file))
851(declare-function lm-authors "lisp-mnt" (&optional file))
852
853(defun package-buffer-info ()
854 "Return a `package-desc' describing the package in the current buffer.
855
856If the buffer does not contain a conforming package, signal an
857error. If there is a package, narrow the buffer to the file's
858boundaries."
859 (goto-char (point-min))
860 (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
861 (error "Package lacks a file header"))
862 (let ((file-name (match-string-no-properties 1))
863 (desc (match-string-no-properties 2)))
864 (require 'lisp-mnt)
865 (let* ((version-info (lm-package-version))
866 (pkg-version (package-strip-rcs-id version-info))
867 (keywords (lm-keywords-list))
868 (website (lm-website)))
869 (unless pkg-version
870 (if version-info
871 (error "Unrecognized package version: %s" version-info)
872 (error "Package lacks a \"Version\" or \"Package-Version\" header")))
873 (package-desc-from-define
874 file-name pkg-version desc
875 (lm-package-requires)
876 :kind 'single
877 :url website
878 :keywords keywords
879 :maintainer
880 ;; For backward compatibility, use a single cons-cell if
881 ;; there's only one maintainer (the most common case).
882 (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints)))
883 :authors (lm-authors)))))
884
885(defun package--read-pkg-desc (kind)
886 "Read a `define-package' form in current buffer.
887Return the pkg-desc, with desc-kind set to KIND."
888 (goto-char (point-min))
889 (let* ((pkg-def-parsed (read (current-buffer)))
890 (pkg-desc
891 (when (eq (car pkg-def-parsed) 'define-package)
892 (apply #'package-desc-from-define
893 (append (cdr pkg-def-parsed))))))
894 (when pkg-desc
895 (setf (package-desc-kind pkg-desc) kind)
896 pkg-desc)))
897
898(declare-function tar-get-file-descriptor "tar-mode" (file))
899(declare-function tar--extract "tar-mode" (descriptor))
900
901(defun package-tar-file-info ()
902 "Find package information for a tar file.
903The return result is a `package-desc'."
904 (cl-assert (derived-mode-p 'tar-mode))
905 (let* ((dir-name (named-let loop
906 ((filename (tar-header-name (car tar-parse-info))))
907 (let ((dirname (file-name-directory filename)))
908 ;; The first file can be in a subdir: look for the top.
909 (if dirname (loop (directory-file-name dirname))
910 (file-name-as-directory filename)))))
911 (desc-file (package--description-file dir-name))
912 (tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
913 (unless tar-desc
914 (error "No package descriptor file found"))
915 (with-current-buffer (tar--extract tar-desc)
916 (unwind-protect
917 (or (package--read-pkg-desc 'tar)
918 (error "Can't find define-package in %s"
919 (tar-header-name tar-desc)))
920 (kill-buffer (current-buffer))))))
921
922(defun package-dir-info ()
923 "Find package information for a directory.
924The return result is a `package-desc'."
925 (cl-assert (derived-mode-p 'dired-mode))
926 (let* ((desc-file (package--description-file default-directory)))
927 (if (file-readable-p desc-file)
928 (with-temp-buffer
929 (insert-file-contents desc-file)
930 (package--read-pkg-desc 'dir))
931 (catch 'found
932 (let ((files (or (and (derived-mode-p 'dired-mode)
933 (dired-get-marked-files nil 'marked))
934 (directory-files default-directory t "\\.el\\'" t))))
935 ;; We sort the file names by length, to ensure that we check
936 ;; shorter file names first, as these are more likely to
937 ;; contain the package metadata.
938 (dolist (file (sort files :key #'length))
939 ;; The file may be a link to a nonexistent file; e.g., a
940 ;; lock file.
941 (when (file-exists-p file)
942 (with-temp-buffer
943 (insert-file-contents file)
944 ;; When we find the file with the data,
945 (when-let* ((info (ignore-errors (package-buffer-info))))
946 (setf (package-desc-kind info) 'dir)
947 (throw 'found info))))))
948 (error "No .el files with package headers in `%s'" default-directory)))))
949
950
951;;; Communicating with Archives
952;; Set of low-level functions for communicating with archives and
953;; signature checking.
954
955(defun package--write-file-no-coding (file-name)
956 "Write file FILE-NAME without encoding using coding system."
957 (let ((buffer-file-coding-system 'no-conversion))
958 (write-region (point-min) (point-max) file-name nil 'silent)))
959
960(declare-function url-http-file-exists-p "url-http" (url))
961
962(defun package--archive-file-exists-p (location file)
963 "Return t if FILE exists in remote LOCATION."
964 (let ((http (string-match "\\`https?:" location)))
965 (if http
966 (progn
967 (require 'url-http)
968 (url-http-file-exists-p (concat location file)))
969 (file-exists-p (expand-file-name file location)))))
970
971(declare-function epg-make-context "epg"
972 (&optional protocol armor textmode include-certs
973 cipher-algorithm
974 digest-algorithm
975 compress-algorithm))
976(declare-function epg-verify-string "epg" ( context signature
977 &optional signed-text))
978(declare-function epg-context-result-for "epg" (context name))
979(declare-function epg-signature-status "epg" (signature) t)
980(declare-function epg-signature-to-string "epg" (signature))
981
982(defun package--display-verify-error (context sig-file)
983 "Show error details with CONTEXT for failed verification of SIG-FILE.
984The details are shown in a new buffer called \"*Error\"."
985 (unless (equal (epg-context-error-output context) "")
986 (with-output-to-temp-buffer "*Error*"
987 (with-current-buffer standard-output
988 (if (epg-context-result-for context 'verify)
989 (insert (format "Failed to verify signature %s:\n" sig-file)
990 (mapconcat #'epg-signature-to-string
991 (epg-context-result-for context 'verify)
992 "\n"))
993 (insert (format "Error while verifying signature %s:\n" sig-file)))
994 (insert "\nCommand output:\n" (epg-context-error-output context))))))
995
996(defmacro package--with-work-buffer (location file &rest body)
997 "Run BODY in a buffer containing the contents of FILE at LOCATION.
998LOCATION is the base location of a package archive, and should be
999one of the URLs (or file names) specified in `package-archives'.
1000FILE is the name of a file relative to that base location.
1001
1002This macro retrieves FILE from LOCATION into a temporary buffer,
1003and evaluates BODY while that buffer is current. This work
1004buffer is killed afterwards. Return the last value in BODY."
1005 (declare (indent 2) (debug t)
1006 (obsolete package--with-response-buffer "25.1"))
1007 `(with-temp-buffer
1008 (if (string-match-p "\\`https?:" ,location)
1009 (url-insert-file-contents (concat ,location ,file))
1010 (unless (file-name-absolute-p ,location)
1011 (error "Archive location %s is not an absolute file name"
1012 ,location))
1013 (insert-file-contents (expand-file-name ,file ,location)))
1014 ,@body))
1015
1016(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
1017 "Access URL and run BODY in a buffer containing the response.
1018Point is after the headers when BODY runs.
1019FILE, if provided, is added to URL.
1020URL can be a local file name, which must be absolute.
1021ASYNC, if non-nil, runs the request asynchronously.
1022ERROR-FORM is run only if a connection error occurs. If NOERROR
1023is non-nil, don't propagate connection errors (does not apply to
1024errors signaled by ERROR-FORM or by BODY).
1025
1026\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
1027 (declare (indent defun) (debug (sexp body)))
1028 (while (keywordp (car body))
1029 (setq body (cdr (cdr body))))
1030 `(package--with-response-buffer-1 ,url (lambda () ,@body)
1031 :file ,file
1032 :async ,async
1033 :error-function (lambda () ,error-form)
1034 :noerror ,noerror))
1035
1036(defmacro package--unless-error (body &rest before-body)
1037 (declare (debug t) (indent 1))
1038 (let ((err (make-symbol "err")))
1039 `(with-temp-buffer
1040 (set-buffer-multibyte nil)
1041 (when (condition-case ,err
1042 (progn ,@before-body t)
1043 (error (funcall error-function)
1044 (unless noerror
1045 (signal (car ,err) (cdr ,err)))))
1046 (funcall ,body)))))
1047
1048(cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys)
1049 (if (string-match-p "\\`https?:" url)
1050 (let ((url (url-expand-file-name file url)))
1051 (if async
1052 (package--unless-error #'ignore
1053 (url-retrieve
1054 url
1055 (lambda (status)
1056 (let ((b (current-buffer)))
1057 (require 'url-handlers)
1058 (package--unless-error body
1059 (when-let* ((er (plist-get status :error)))
1060 (error "Error retrieving: %s %S" url er))
1061 (with-current-buffer b
1062 (goto-char (point-min))
1063 (unless (search-forward-regexp "^\r?\n\r?" nil t)
1064 (error "Error retrieving: %s %S"
1065 url "incomprehensible buffer")))
1066 (url-insert b)
1067 (kill-buffer b)
1068 (goto-char (point-min)))))
1069 nil
1070 'silent))
1071 (package--unless-error body
1072 ;; Copy&pasted from url-insert-file-contents,
1073 ;; except it calls `url-insert' because we want the contents
1074 ;; literally (but there's no url-insert-file-contents-literally).
1075 (let ((buffer (url-retrieve-synchronously url)))
1076 (unless buffer (signal 'file-error (list url "No Data")))
1077 (when (fboundp 'url-http--insert-file-helper)
1078 ;; XXX: This is HTTP/S specific and should be moved
1079 ;; to url-http instead. See bug#17549.
1080 (url-http--insert-file-helper buffer url))
1081 (url-insert buffer)
1082 (kill-buffer buffer)
1083 (goto-char (point-min))))))
1084 (package--unless-error body
1085 (unless (file-name-absolute-p url)
1086 (error "Location %s is not a url nor an absolute file name" url))
1087 (insert-file-contents-literally (expand-file-name file url)))))
1088
1089(define-error 'bad-signature "Failed to verify signature")
1090
1091(defun package--check-signature-content (content string &optional sig-file)
1092 "Check signature CONTENT against STRING.
1093SIG-FILE is the name of the signature file, used when signaling
1094errors."
1095 (let ((context (epg-make-context 'OpenPGP)))
1096 (when package-gnupghome-dir
1097 (setf (epg-context-home-directory context) package-gnupghome-dir))
1098 (condition-case error
1099 (epg-verify-string context content string)
1100 (error (package--display-verify-error context sig-file)
1101 (signal 'bad-signature error)))
1102 (let (good-signatures had-fatal-error)
1103 ;; The .sig file may contain multiple signatures. Success if one
1104 ;; of the signatures is good.
1105 (dolist (sig (epg-context-result-for context 'verify))
1106 (if (eq (epg-signature-status sig) 'good)
1107 (push sig good-signatures)
1108 ;; If `package-check-signature' is allow-unsigned, don't
1109 ;; signal error when we can't verify signature because of
1110 ;; missing public key. Other errors are still treated as
1111 ;; fatal (bug#17625).
1112 (unless (and (eq (package-check-signature) 'allow-unsigned)
1113 (eq (epg-signature-status sig) 'no-pubkey))
1114 (setq had-fatal-error t))))
1115 (when (or (null good-signatures)
1116 (and (eq (package-check-signature) 'all)
1117 had-fatal-error))
1118 (package--display-verify-error context sig-file)
1119 (signal 'bad-signature (list sig-file)))
1120 good-signatures)))
1121
1122(defun package--check-signature (location file &optional string async callback unwind)
1123 "Check signature of the current buffer.
1124Download the signature file from LOCATION by appending \".sig\"
1125to FILE.
1126GnuPG keyring location depends on `package-gnupghome-dir'.
1127STRING is the string to verify, it defaults to `buffer-string'.
1128If ASYNC is non-nil, the download of the signature file is
1129done asynchronously.
1130
1131If the signature does not verify, signal an error.
1132If the signature is verified and CALLBACK was provided, `funcall'
1133CALLBACK with the list of good signatures as argument (the list
1134can be empty).
1135If no signatures file is found, and `package-check-signature' is
1136`allow-unsigned', call CALLBACK with a nil argument.
1137Otherwise, an error is signaled.
1138
1139UNWIND, if provided, is a function to be called after everything
1140else, even if an error is signaled."
1141 (let ((sig-file (concat file ".sig"))
1142 (string (or string (buffer-string))))
1143 (package--with-response-buffer location :file sig-file
1144 :async async :noerror t
1145 ;; Connection error is assumed to mean "no sig-file".
1146 :error-form (let ((allow-unsigned
1147 (eq (package-check-signature) 'allow-unsigned)))
1148 (when (and callback allow-unsigned)
1149 (funcall callback nil))
1150 (when unwind (funcall unwind))
1151 (unless allow-unsigned
1152 (error "Unsigned file `%s' at %s" file location)))
1153 ;; OTOH, an error here means "bad signature", which we never
1154 ;; suppress. (Bug#22089)
1155 (unwind-protect
1156 (let ((sig (package--check-signature-content
1157 (buffer-substring (point) (point-max))
1158 string sig-file)))
1159 (when callback (funcall callback sig))
1160 sig)
1161 (when unwind (funcall unwind))))))
1162
1163;;; Packages on Archives
1164;; The following variables store information about packages available
1165;; from archives. The most important of these is
1166;; `package-archive-contents' which is initially populated by the
1167;; function `package-read-all-archive-contents' from a cache on disk.
1168;; The `package-initialize' command is also closely related to this
1169;; section, but it has its own section.
1170
1171(defconst package-archive-version 1
1172 "Version number of the package archive understood by package.el.
1173Lower version numbers than this will probably be understood as well.")
1174
1175;; We don't prime the cache since it tends to get out of date.
1176(defvar package-archive-contents nil
1177 "Cache of the contents of all archives in `package-archives'.
1178This is an alist mapping package names (symbols) to
1179non-empty lists of `package-desc' structures.")
1180(put 'package-archive-contents 'risky-local-variable t)
1181
1182(defvar package--compatibility-table nil
1183 "Hash table connecting package names to their compatibility.
1184Each key is a symbol, the name of a package.
1185
1186The value is either nil, representing an incompatible package, or
1187a version list, representing the highest compatible version of
1188that package which is available.
1189
1190A package is considered incompatible if it requires an Emacs
1191version higher than the one being used. To check for package
1192\(in)compatibility, don't read this table directly, use
1193`package--incompatible-p' which also checks dependencies.")
1194
1195(defun package--build-compatibility-table ()
1196 "Build `package--compatibility-table' with `package--mapc'."
1197 ;; Initialize the list of built-ins.
1198 (require 'finder-inf nil t)
1199 ;; Build compat table.
1200 (setq package--compatibility-table (make-hash-table :test 'eq))
1201 (package--mapc #'package--add-to-compatibility-table))
1202
1203(defun package--add-to-compatibility-table (pkg)
1204 "If PKG is compatible (without dependencies), add to the compatibility table.
1205PKG is a package-desc object.
1206Only adds if its version is higher than what's already stored in
1207the table."
1208 (unless (package--incompatible-p pkg 'shallow)
1209 (let* ((name (package-desc-name pkg))
1210 (version (or (package-desc-version pkg) '(0)))
1211 (table-version (gethash name package--compatibility-table)))
1212 (when (or (not table-version)
1213 (version-list-< table-version version))
1214 (puthash name version package--compatibility-table)))))
1215
1216;; Package descriptor objects used inside the "archive-contents" file.
1217;; Changing this defstruct implies changing the format of the
1218;; "archive-contents" files.
1219(cl-defstruct (package--ac-desc
1220 (:constructor package-make-ac-desc (version reqs summary kind extras))
1221 (:copier nil)
1222 (:type vector))
1223 version reqs summary kind extras)
1224
1225(defun package--append-to-alist (pkg-desc alist)
1226 "Append an entry for PKG-DESC to the start of ALIST and return it.
1227This entry takes the form (`package-desc-name' PKG-DESC).
1228
1229If ALIST already has an entry with this name, destructively add
1230PKG-DESC to the cdr of this entry instead, sorted by version
1231number."
1232 (let* ((name (package-desc-name pkg-desc))
1233 (priority-version (package-desc-priority-version pkg-desc))
1234 (existing-packages (assq name alist)))
1235 (if (not existing-packages)
1236 (cons (list name pkg-desc)
1237 alist)
1238 (while (if (and (cdr existing-packages)
1239 (version-list-< priority-version
1240 (package-desc-priority-version
1241 (cadr existing-packages))))
1242 (setq existing-packages (cdr existing-packages))
1243 (push pkg-desc (cdr existing-packages))
1244 nil))
1245 alist)))
1246
1247(defun package--add-to-archive-contents (package archive)
1248 "Add the PACKAGE from the given ARCHIVE if necessary.
1249PACKAGE should have the form (NAME . PACKAGE--AC-DESC).
1250Also, add the originating archive to the `package-desc' structure."
1251 (let* ((name (car package))
1252 (version (package--ac-desc-version (cdr package)))
1253 (pkg-desc
1254 (package-desc-create
1255 :name name
1256 :version version
1257 :reqs (package--ac-desc-reqs (cdr package))
1258 :summary (package--ac-desc-summary (cdr package))
1259 :kind (package--ac-desc-kind (cdr package))
1260 :archive archive
1261 :extras (and (> (length (cdr package)) 4)
1262 ;; Older archive-contents files have only 4
1263 ;; elements here.
1264 (package--ac-desc-extras (cdr package)))))
1265 (pinned-to-archive (assoc name package-pinned-packages)))
1266 ;; Skip entirely if pinned to another archive.
1267 (when (not (and pinned-to-archive
1268 (not (equal (cdr pinned-to-archive) archive))))
1269 (setq package-archive-contents
1270 (package--append-to-alist pkg-desc package-archive-contents)))))
1271
1272(defun package--read-archive-file (file)
1273 "Read cached archive FILE data, if it exists.
1274Return the data from the file, or nil if the file does not exist.
1275If the archive version is too new, signal an error."
1276 (let ((filename (expand-file-name file package-user-dir)))
1277 (when (file-exists-p filename)
1278 (with-temp-buffer
1279 (let ((coding-system-for-read 'utf-8))
1280 (insert-file-contents filename))
1281 (let ((contents (read (current-buffer))))
1282 (if (> (car contents) package-archive-version)
1283 (error "Package archive version %d is higher than %d"
1284 (car contents) package-archive-version))
1285 (cdr contents))))))
1286
1287(defun package-read-archive-contents (archive)
1288 "Read cached archive file for ARCHIVE.
1289If successful, set or update the variable `package-archive-contents'.
1290ARCHIVE should be a string matching the name of a package archive
1291in the variable `package-archives'.
1292If the archive version is too new, signal an error."
1293 ;; Version 1 of 'archive-contents' is identical to our internal
1294 ;; representation.
1295 (let* ((contents-file (format "archives/%s/archive-contents" archive))
1296 (contents (package--read-archive-file contents-file)))
1297 (when contents
1298 (dolist (package contents)
1299 (if package
1300 (package--add-to-archive-contents package archive)
1301 (lwarn '(package refresh) :warning
1302 "Ignoring nil package on `%s' package archive" archive))))))
1303
1304(defvar package--old-archive-priorities nil
1305 "Store currently used `package-archive-priorities'.
1306This is the value of `package-archive-priorities' last time
1307`package-read-all-archive-contents' was called. It can be used
1308by arbitrary functions to decide whether it is necessary to call
1309it again.")
1310
1311(defvar package-read-archive-hook (list #'package-read-archive-contents)
1312 "List of functions to call to read the archive contents.
1313Each function must take an optional argument, a symbol indicating
1314what archive to read in. The symbol ought to be a key in
1315`package-archives'.")
1316
1317(defun package-read-all-archive-contents ()
1318 "Read cached archive file for all archives in `package-archives'.
1319If successful, set or update `package-archive-contents'."
1320 (setq package-archive-contents nil)
1321 (setq package--old-archive-priorities package-archive-priorities)
1322 (dolist (archive package-archives)
1323 (run-hook-with-args 'package-read-archive-hook (car archive))))
1324
1325
1326;;;; Package Initialize
1327;; A bit of a milestone. This brings together some of the above
1328;; sections and populates all relevant lists of packages from contents
1329;; available on disk.
1330
1331(defvar package--initialized nil
1332 "Non-nil if `package-initialize' has been run.")
1333
1334;;;###autoload
1335(defun package-initialize (&optional no-activate)
1336 "Load Emacs Lisp packages, and activate them.
1337The variable `package-load-list' controls which packages to load.
1338If optional arg NO-ACTIVATE is non-nil, don't activate packages.
1339
1340It is not necessary to adjust `load-path' or `require' the
1341individual packages after calling `package-initialize' -- this is
1342taken care of by `package-initialize'.
1343
1344If `package-initialize' is called twice during Emacs startup,
1345signal a warning, since this is a bad idea except in highly
1346advanced use cases. To suppress the warning, remove the
1347superfluous call to `package-initialize' from your init-file. If
1348you have code which must run before `package-initialize', put
1349that code in the early init-file."
1350 (interactive)
1351 (when (and package--initialized (not after-init-time))
1352 (lwarn '(package reinitialization) :warning
1353 "Unnecessary call to `package-initialize' in init file"))
1354 (setq package-alist nil)
1355 (package-load-all-descriptors)
1356 (package-read-all-archive-contents)
1357 (setq package--initialized t)
1358 (unless no-activate
1359 (package-activate-all))
1360 ;; This uses `package--mapc' so it must be called after
1361 ;; `package--initialized' is t.
1362 (package--build-compatibility-table))
1363
1364
1365;;;; Populating `package-archive-contents' from archives
1366;; This subsection populates the variables listed above from the
1367;; actual archives, instead of from a local cache.
1368
1369(defvar package--downloads-in-progress nil
1370 "List of in-progress asynchronous downloads.")
1371
1372(declare-function epg-import-keys-from-file "epg" (context keys))
1373
1374;;;###autoload
1375(defun package-import-keyring (&optional file)
1376 "Import keys from FILE."
1377 (interactive "fFile: ")
1378 (setq file (expand-file-name file))
1379 (let ((context (epg-make-context 'OpenPGP)))
1380 (when package-gnupghome-dir
1381 (with-file-modes #o700
1382 (make-directory package-gnupghome-dir t))
1383 (setf (epg-context-home-directory context) package-gnupghome-dir))
1384 (message "Importing %s..." (file-name-nondirectory file))
1385 (epg-import-keys-from-file context file)
1386 (message "Importing %s...done" (file-name-nondirectory file))))
1387
1388(defvar package--post-download-archives-hook nil
1389 "Hook run after the archive contents are downloaded.
1390Don't run this hook directly. It is meant to be run as part of
1391`package--update-downloads-in-progress'.")
1392(put 'package--post-download-archives-hook 'risky-local-variable t)
1393
1394(defun package--update-downloads-in-progress (entry)
1395 "Remove ENTRY from `package--downloads-in-progress'.
1396Once it's empty, run `package--post-download-archives-hook'."
1397 ;; Keep track of the downloading progress.
1398 (setq package--downloads-in-progress
1399 (remove entry package--downloads-in-progress))
1400 ;; If this was the last download, run the hook.
1401 (unless package--downloads-in-progress
1402 (package-read-all-archive-contents)
1403 (package--build-compatibility-table)
1404 ;; We message before running the hook, so the hook can give
1405 ;; messages as well.
1406 (message "Package refresh done")
1407 (run-hooks 'package--post-download-archives-hook)))
1408
1409(defun package--download-one-archive (archive file &optional async)
1410 "Retrieve an archive file FILE from ARCHIVE, and cache it.
1411ARCHIVE should be a cons cell of the form (NAME . LOCATION),
1412similar to an entry in `package-alist'. Save the cached copy to
1413\"archives/NAME/FILE\" in `package-user-dir'."
1414 ;; The downloaded archive contents will be read as part of
1415 ;; `package--update-downloads-in-progress'.
1416 (when async
1417 (cl-pushnew (cons archive file) package--downloads-in-progress
1418 :test #'equal))
1419 (package--with-response-buffer (cdr archive) :file file
1420 :async async
1421 :error-form (package--update-downloads-in-progress (cons archive file))
1422 (let* ((location (cdr archive))
1423 (name (car archive))
1424 (content (buffer-string))
1425 (dir (expand-file-name (concat "archives/" name) package-user-dir))
1426 (local-file (expand-file-name file dir)))
1427 (when (listp (read content))
1428 (make-directory dir t)
1429 (if (or (not (package-check-signature))
1430 (member name package-unsigned-archives))
1431 ;; If we don't care about the signature, save the file and
1432 ;; we're done.
1433 (progn
1434 (cl-assert (not enable-multibyte-characters))
1435 (let ((coding-system-for-write 'binary))
1436 (write-region content nil local-file nil 'silent))
1437 (package--update-downloads-in-progress (cons archive file)))
1438 ;; If we care, check it (perhaps async) and *then* write the file.
1439 (package--check-signature
1440 location file content async
1441 ;; This function will be called after signature checking.
1442 (lambda (&optional good-sigs)
1443 (cl-assert (not enable-multibyte-characters))
1444 (let ((coding-system-for-write 'binary))
1445 (write-region content nil local-file nil 'silent))
1446 ;; Write out good signatures into archive-contents.signed file.
1447 (when good-sigs
1448 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
1449 nil (concat local-file ".signed") nil 'silent)))
1450 (lambda () (package--update-downloads-in-progress (cons archive file)))))))))
1451
1452(defun package--download-and-read-archives (&optional async)
1453 "Download descriptions of all `package-archives' and read them.
1454Populate `package-archive-contents' with the result.
1455
1456If optional argument ASYNC is non-nil, perform the downloads
1457asynchronously."
1458 (dolist (archive package-archives)
1459 (condition-case-unless-debug err
1460 (package--download-one-archive archive "archive-contents" async)
1461 (error (message "Failed to download `%s' archive: %s"
1462 (car archive)
1463 (error-message-string err))))))
1464
1465(defvar package-refresh-contents-hook (list #'package--download-and-read-archives)
1466 "List of functions to call to refresh the package archive.
1467Each function may take an optional argument indicating that the
1468operation ought to be executed asynchronously.")
1469
1470;;;###autoload
1471(defun package-refresh-contents (&optional async)
1472 "Download descriptions of all configured ELPA packages.
1473For each archive configured in the variable `package-archives',
1474inform Emacs about the latest versions of all packages it offers,
1475and make them available for download.
1476Optional argument ASYNC specifies whether to perform the
1477downloads in the background. This is always the case when the command
1478is invoked interactively."
1479 (interactive (list t))
1480 (when async
1481 (message "Refreshing package contents..."))
1482 (unless (file-exists-p package-user-dir)
1483 (make-directory package-user-dir t))
1484 (let ((default-keyring (expand-file-name "package-keyring.gpg"
1485 data-directory))
1486 (inhibit-message (or inhibit-message async)))
1487 (when (and (package-check-signature) (file-exists-p default-keyring))
1488 (condition-case-unless-debug error
1489 (package-import-keyring default-keyring)
1490 (error (message "Cannot import default keyring: %s"
1491 (error-message-string error))))))
1492 (run-hook-with-args 'package-refresh-contents-hook async))
1493
1494
1495;;; Dependency Management
1496;; Calculating the full transaction necessary for an installation,
1497;; keeping track of which packages were installed strictly as
1498;; dependencies, and determining which packages cannot be removed
1499;; because they are dependencies.
1500
1501(defun package-compute-transaction (packages requirements &optional seen)
1502 "Return a list of packages to be installed, including PACKAGES.
1503PACKAGES should be a list of `package-desc'.
1504
1505REQUIREMENTS should be a list of additional requirements; each
1506element in this list should have the form (PACKAGE VERSION-LIST),
1507where PACKAGE is a package name and VERSION-LIST is the required
1508version of that package.
1509
1510This function recursively computes the requirements of the
1511packages in REQUIREMENTS, and returns a list of all the packages
1512that must be installed. Packages that are already installed are
1513not included in this list.
1514
1515SEEN is used internally to detect infinite recursion."
1516 ;; FIXME: We really should use backtracking to explore the whole
1517 ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1
1518 ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0:
1519 ;; the current code might fail to see that it could install foo by using the
1520 ;; older bar-1.3).
1521 (dolist (elt requirements)
1522 (let* ((next-pkg (car elt))
1523 (next-version (cadr elt))
1524 (already ()))
1525 (dolist (pkg packages)
1526 (if (eq next-pkg (package-desc-name pkg))
1527 (setq already pkg)))
1528 (when already
1529 (if (version-list-<= next-version (package-desc-version already))
1530 ;; `next-pkg' is already in `packages', but its position there
1531 ;; means it might be installed too late: remove it from there, so
1532 ;; we re-add it (along with its dependencies) at an earlier place
1533 ;; below (bug#16994).
1534 (if (memq already seen) ;Avoid inf-loop on dependency cycles.
1535 (message "Dependency cycle going through %S"
1536 (package-desc-full-name already))
1537 (setq packages (delq already packages))
1538 (setq already nil))
1539 (error "Need package `%s-%s', but only %s is being installed"
1540 next-pkg (package-version-join next-version)
1541 (package-version-join (package-desc-version already)))))
1542 (cond
1543 (already nil)
1544 ((package-installed-p next-pkg next-version) nil)
1545
1546 (t
1547 ;; A package is required, but not installed. It might also be
1548 ;; blocked via `package-load-list'.
1549 (let ((pkg-descs (cdr (assq next-pkg package-archive-contents)))
1550 (found nil)
1551 (found-something nil)
1552 (problem nil))
1553 (while (and pkg-descs (not found))
1554 (let* ((pkg-desc (pop pkg-descs))
1555 (version (package-desc-version pkg-desc))
1556 (disabled (package-disabled-p next-pkg version)))
1557 (cond
1558 ((version-list-< version next-version)
1559 ;; pkg-descs is sorted by priority, not version, so
1560 ;; don't error just yet.
1561 (unless found-something
1562 (setq found-something (package-version-join version))))
1563 (disabled
1564 (unless problem
1565 (setq problem
1566 (if (stringp disabled)
1567 (format-message
1568 "Package `%s' held at version %s, but version %s required"
1569 next-pkg disabled
1570 (package-version-join next-version))
1571 (format-message "Required package `%s' is disabled"
1572 next-pkg)))))
1573 (t (setq found pkg-desc)))))
1574 (unless found
1575 (cond
1576 (problem (error "%s" problem))
1577 (found-something
1578 (error "Need package `%s-%s', but only %s is available"
1579 next-pkg (package-version-join next-version)
1580 found-something))
1581 (t
1582 (if (eq next-pkg 'emacs)
1583 (error "This package requires Emacs version %s"
1584 (package-version-join next-version))
1585 (error (if (not next-version)
1586 (format "Package `%s' is unavailable" next-pkg)
1587 (format "Package `%s' (version %s) is unavailable"
1588 next-pkg (package-version-join next-version))))))))
1589 (setq packages
1590 (package-compute-transaction (cons found packages)
1591 (package-desc-reqs found)
1592 (cons found seen))))))))
1593 packages)
1594
1595(defun package--find-non-dependencies ()
1596 "Return a list of installed packages which are not dependencies.
1597Finds all packages in `package-alist' which are not dependencies
1598of any other packages.
1599Used to populate `package-selected-packages'."
1600 (let ((dep-list
1601 (delete-dups
1602 (apply #'append
1603 (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p))))
1604 package-alist)))))
1605 (cl-loop for p in package-alist
1606 for name = (car p)
1607 unless (memq name dep-list)
1608 collect name)))
1609
1610(defun package--save-selected-packages (&optional value)
1611 "Set and save `package-selected-packages' to VALUE."
1612 (when (or value after-init-time)
1613 ;; It is valid to set it to nil, for example when the last package
1614 ;; is uninstalled. But it shouldn't be done at init time, to
1615 ;; avoid overwriting configurations that haven't yet been loaded.
1616 (setq package-selected-packages (sort value #'string<)))
1617 (if after-init-time
1618 (customize-save-variable 'package-selected-packages package-selected-packages)
1619 (add-hook 'after-init-hook #'package--save-selected-packages)))
1620
1621(defun package--user-selected-p (pkg)
1622 "Return non-nil if PKG is a package was installed by the user.
1623PKG is a package name.
1624This looks into `package-selected-packages', populating it first
1625if it is still empty."
1626 (unless (consp package-selected-packages)
1627 (package--save-selected-packages (package--find-non-dependencies)))
1628 (memq pkg package-selected-packages))
1629
1630(defun package--get-deps (pkgs)
1631 (let ((seen '()))
1632 (while pkgs
1633 (let ((pkg (pop pkgs)))
1634 (if (memq pkg seen)
1635 nil ;; Done already!
1636 (let ((pkg-desc (cadr (assq pkg package-alist))))
1637 (when pkg-desc
1638 (push pkg seen)
1639 (setq pkgs (append (mapcar #'car (package-desc-reqs pkg-desc))
1640 pkgs)))))))
1641 seen))
1642
1643(defun package--user-installed-p (package)
1644 "Return non-nil if PACKAGE is a user-installed package.
1645PACKAGE is the package name, a symbol. Check whether the package
1646was installed into `package-user-dir' where we assume to have
1647control over."
1648 (let* ((pkg-desc (cadr (assq package package-alist)))
1649 (dir (package-desc-dir pkg-desc)))
1650 (file-in-directory-p dir package-user-dir)))
1651
1652(defun package--removable-packages ()
1653 "Return a list of names of packages no longer needed.
1654These are packages which are neither contained in
1655`package-selected-packages' nor a dependency of one that is."
1656 (let ((needed (package--get-deps package-selected-packages)))
1657 (cl-loop for p in (mapcar #'car package-alist)
1658 unless (or (memq p needed)
1659 ;; Do not auto-remove external packages.
1660 (not (package--user-installed-p p)))
1661 collect p)))
1662
1663(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all)
1664 "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST.
1665Return the first package found in PKG-LIST of which PKG is a
1666dependency. If ALL is non-nil, return all such packages instead.
1667
1668When not specified, PKG-LIST defaults to `package-alist'
1669with PKG-DESC entry removed."
1670 (unless (string= (package-desc-status pkg-desc) "obsolete")
1671 (let* ((pkg (package-desc-name pkg-desc))
1672 (alist (or pkg-list
1673 (remove (assq pkg package-alist)
1674 package-alist))))
1675 (if all
1676 (cl-loop for p in alist
1677 if (assq pkg (package-desc-reqs (cadr p)))
1678 collect (cadr p))
1679 (cl-loop for p in alist thereis
1680 (and (assq pkg (package-desc-reqs (cadr p)))
1681 (cadr p)))))))
1682
1683(defun package--sort-deps-in-alist (package only)
1684 "Return a list of dependencies for PACKAGE sorted by dependency.
1685PACKAGE is included as the first element of the returned list.
1686ONLY is an alist associating package names to package objects.
1687Only these packages will be in the return value and their cdrs are
1688destructively set to nil in ONLY."
1689 (let ((out))
1690 (dolist (dep (package-desc-reqs package))
1691 (when-let* ((cell (assq (car dep) only))
1692 (dep-package (cdr-safe cell)))
1693 (setcdr cell nil)
1694 (setq out (append (package--sort-deps-in-alist dep-package only)
1695 out))))
1696 (cons package out)))
1697
1698(defun package--sort-by-dependence (package-list)
1699 "Return PACKAGE-LIST sorted by dependence.
1700That is, any element of the returned list is guaranteed to not
1701directly depend on any elements that come before it.
1702
1703PACKAGE-LIST is a list of `package-desc' objects.
1704Indirect dependencies are guaranteed to be returned in order only
1705if all the in-between dependencies are also in PACKAGE-LIST."
1706 (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list))
1707 out-list)
1708 (dolist (cell alist out-list)
1709 ;; `package--sort-deps-in-alist' destructively changes alist, so
1710 ;; some cells might already be empty. We check this here.
1711 (when-let* ((pkg-desc (cdr cell)))
1712 (setcdr cell nil)
1713 (setq out-list
1714 (append (package--sort-deps-in-alist pkg-desc alist)
1715 out-list))))))
1716
1717
1718;;; Installation Functions
1719;; As opposed to the previous section (which listed some underlying
1720;; functions necessary for installation), this one contains the actual
1721;; functions that install packages. The package itself can be
1722;; installed in a variety of ways (archives, buffer, file), but
1723;; requirements (dependencies) are always satisfied by looking in
1724;; `package-archive-contents'.
1725;;
1726;; If Emacs installs a package from a package archive, it might create
1727;; some files in addition to the package's contents. For example:
1728;;
1729;; - If the package archive provides a non-trivial long description for
1730;; some package in "PACKAGE-readme.txt", Emacs stores it in a file
1731;; named "README-elpa" in the package's content directory, unless the
1732;; package itself provides such a file.
1733;;
1734;; - If a package archive provides package signatures, Emacs stores
1735;; information on the signatures in files named "NAME-VERSION.signed"
1736;; below directory `package-user-dir'.
1737
1738(defun package-archive-base (desc)
1739 "Return the package described by DESC."
1740 (cdr (assoc (package-desc-archive desc) package-archives)))
1741
1742(defun package-install-from-archive (pkg-desc)
1743 "Download and install a package defined by PKG-DESC."
1744 ;; This won't happen, unless the archive is doing something wrong.
1745 (when (eq (package-desc-kind pkg-desc) 'dir)
1746 (error "Can't install directory package from archive"))
1747 (let* ((location (package-archive-base pkg-desc))
1748 (file (concat (package-desc-full-name pkg-desc)
1749 (package-desc-suffix pkg-desc))))
1750 (package--with-response-buffer location :file file
1751 (if (or (not (package-check-signature))
1752 (member (package-desc-archive pkg-desc)
1753 package-unsigned-archives))
1754 ;; If we don't care about the signature, unpack and we're
1755 ;; done.
1756 (let ((save-silently t))
1757 (package-unpack pkg-desc))
1758 ;; If we care, check it and *then* write the file.
1759 (let ((content (buffer-string)))
1760 (package--check-signature
1761 location file content nil
1762 ;; This function will be called after signature checking.
1763 (lambda (&optional good-sigs)
1764 ;; Signature checked, unpack now.
1765 (with-temp-buffer ;FIXME: Just use the previous current-buffer.
1766 (set-buffer-multibyte nil)
1767 (cl-assert (not (multibyte-string-p content)))
1768 (insert content)
1769 (let ((save-silently t))
1770 (package-unpack pkg-desc)))
1771 ;; Here the package has been installed successfully, mark it as
1772 ;; signed if appropriate.
1773 (when good-sigs
1774 ;; Write out good signatures into NAME-VERSION.signed file.
1775 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
1776 nil
1777 (expand-file-name
1778 (concat (package-desc-full-name pkg-desc) ".signed")
1779 package-user-dir)
1780 nil 'silent)
1781 ;; Update the old pkg-desc which will be shown on the description buffer.
1782 (setf (package-desc-signed pkg-desc) t)
1783 ;; Update the new (activated) pkg-desc as well.
1784 (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc)
1785 package-alist))))
1786 (setf (package-desc-signed (car pkg-descs)) t))))))))
1787 ;; fetch a backup of the readme file from the server. Slot `dir' is
1788 ;; not yet available in PKG-DESC, so cobble that up.
1789 (let* ((dirname (package-desc-full-name pkg-desc))
1790 (pkg-dir (expand-file-name dirname package-user-dir))
1791 (readme (expand-file-name "README-elpa" pkg-dir)))
1792 (unless (file-readable-p readme)
1793 (package--with-response-buffer (package-archive-base pkg-desc)
1794 :file (format "%s-readme.txt" (package-desc-name pkg-desc))
1795 :noerror t
1796 ;; do not write empty or whitespace-only readmes to give
1797 ;; `package--get-description' a chance to find another readme
1798 (unless (save-excursion
1799 (goto-char (point-min))
1800 (looking-at-p "[[:space:]]*\\'"))
1801 (write-region nil nil readme)))))))
1802
1803;;;###autoload
1804(defun package-installed-p (package &optional min-version)
1805 "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed.
1806If PACKAGE is a symbol, it is the package name and MIN-VERSION
1807should be a version list.
1808
1809If PACKAGE is a `package-desc' object, MIN-VERSION is ignored."
1810 (cond
1811 ((package-desc-p package)
1812 (let ((dir (package-desc-dir package)))
1813 (and (stringp dir)
1814 (file-exists-p dir))))
1815 ((and (not package--initialized)
1816 (null min-version)
1817 package-activated-list)
1818 ;; We used the quickstart: make it possible to use package-installed-p
1819 ;; even before package is fully initialized.
1820 (or
1821 (memq package package-activated-list)
1822 ;; Also check built-in packages.
1823 (package-built-in-p package min-version)))
1824 (t
1825 (or
1826 (let ((pkg-descs (cdr (assq package (package--alist)))))
1827 (and pkg-descs
1828 (version-list-<= min-version
1829 (package-desc-version (car pkg-descs)))))
1830 ;; Also check built-in packages.
1831 (package-built-in-p package min-version)))))
1832
1833(defun package-download-transaction (packages)
1834 "Download and install all the packages in PACKAGES.
1835PACKAGES should be a list of `package-desc'.
1836This function assumes that all package requirements in
1837PACKAGES are satisfied, i.e. that PACKAGES is computed
1838using `package-compute-transaction'."
1839 (mapc #'package-install-from-archive packages))
1840
1841(defun package--archives-initialize ()
1842 "Make sure the list of installed and remote packages are initialized."
1843 (unless package--initialized
1844 (package-initialize t))
1845 (unless package-archive-contents
1846 (package-refresh-contents)))
1847
1848(defcustom package-install-upgrade-built-in nil
1849 "Non-nil means that built-in packages can be upgraded via a package archive.
1850If disabled, then `package-install' will raise an error when trying to
1851replace a built-in package with a (possibly newer) version from a
1852package archive."
1853 :type 'boolean
1854 :version "29.1")
1855
1856;;;###autoload
1857(defun package-install (pkg &optional dont-select)
1858 "Install the package PKG.
1859
1860PKG can be a `package-desc', or a symbol naming one of the available
1861packages in an archive in `package-archives'.
1862
1863Mark the installed package as selected by adding it to
1864`package-selected-packages'.
1865
1866When called from Lisp and optional argument DONT-SELECT is
1867non-nil, install the package but do not add it to
1868`package-selected-packages'.
1869
1870If PKG is a `package-desc' and it is already installed, don't try
1871to install it but still mark it as selected.
1872
1873If the command is invoked with a prefix argument, it will allow
1874upgrading of built-in packages, as if `package-install-upgrade-built-in'
1875had been enabled."
1876 (interactive
1877 (progn
1878 ;; Initialize the package system to get the list of package
1879 ;; symbols for completion.
1880 (package--archives-initialize)
1881 (list (intern (completing-read
1882 "Install package: "
1883 package-archive-contents
1884 nil t))
1885 nil)))
1886 (cl-check-type pkg (or symbol package-desc))
1887 (package--archives-initialize)
1888 (add-hook 'post-command-hook #'package-menu--post-refresh)
1889 (let ((name (if (package-desc-p pkg)
1890 (package-desc-name pkg)
1891 pkg)))
1892 (when (or (and package-install-upgrade-built-in
1893 (package--active-built-in-p pkg))
1894 (package-installed-p pkg))
1895 (user-error "`%s' is already installed" name))
1896 (unless (or dont-select (package--user-selected-p name))
1897 (package--save-selected-packages
1898 (cons name package-selected-packages)))
1899 (when (and (or current-prefix-arg package-install-upgrade-built-in)
1900 (package--active-built-in-p pkg))
1901 (setq pkg (or (cadr (assq name package-archive-contents)) pkg)))
1902 (if-let* ((transaction
1903 (if (package-desc-p pkg)
1904 (unless (package-installed-p pkg)
1905 (package-compute-transaction (list pkg)
1906 (package-desc-reqs pkg)))
1907 (package-compute-transaction () (list (list pkg))))))
1908 (progn
1909 (package-download-transaction transaction)
1910 (package--quickstart-maybe-refresh)
1911 (message "Package `%s' installed." name)))))
1912
1913
1914(declare-function package-vc-upgrade "package-vc" (pkg))
1915
1916;;;###autoload
1917(defun package-upgrade (name)
1918 "Upgrade package NAME if a newer version exists.
1919
1920NAME should be a symbol."
1921 (interactive
1922 (list (intern (completing-read
1923 "Upgrade package: "
1924 (package--upgradeable-packages t) nil t))))
1925 (cl-check-type name symbol)
1926 (let* ((pkg-desc (cadr (assq name package-alist)))
1927 (package-install-upgrade-built-in (not pkg-desc)))
1928 ;; `pkg-desc' will be nil when the package is an "active built-in".
1929 (if (and pkg-desc (package-vc-p pkg-desc))
1930 (package-vc-upgrade pkg-desc)
1931 (when pkg-desc
1932 (package-delete pkg-desc 'force 'dont-unselect))
1933 (package-install name
1934 ;; An active built-in has never been "selected"
1935 ;; before. Mark it as installed explicitly.
1936 (and pkg-desc 'dont-select)))))
1937
1938(defun package--upgradeable-packages (&optional include-builtins)
1939 ;; Initialize the package system to get the list of package
1940 ;; symbols for completion.
1941 (package--archives-initialize)
1942 (mapcar
1943 #'car
1944 (seq-filter
1945 (lambda (elt)
1946 (or (let ((available
1947 (assq (car elt) package-archive-contents)))
1948 (and available
1949 (or (and
1950 include-builtins
1951 (not (package-desc-version (cadr elt))))
1952 (version-list-<
1953 (package-desc-version (cadr elt))
1954 (package-desc-version (cadr available))))))
1955 (package-vc-p (cadr elt))))
1956 (if include-builtins
1957 (append package-alist
1958 (mapcan
1959 (lambda (elt)
1960 (when (not (assq (car elt) package-alist))
1961 (list (list (car elt) (package--from-builtin elt)))))
1962 package--builtins))
1963 package-alist))))
1964
1965;;;###autoload
1966(defun package-upgrade-all (&optional query)
1967 "Refresh package list and upgrade all packages.
1968If QUERY, ask the user before upgrading packages. When called
1969interactively, QUERY is always true.
1970
1971Currently, packages which are part of the Emacs distribution are
1972not upgraded by this command. To enable upgrading such a package
1973using this command, first upgrade the package to a newer version
1974from ELPA by either using `\\[package-upgrade]' or
1975`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
1976 (interactive (list (not noninteractive)))
1977 (package-refresh-contents)
1978 (let ((upgradeable (package--upgradeable-packages package-install-upgrade-built-in)))
1979 (if (not upgradeable)
1980 (message "No packages to upgrade")
1981 (when (and query
1982 (not (yes-or-no-p
1983 (if (length= upgradeable 1)
1984 "One package to upgrade. Do it? "
1985 (format "%s packages to upgrade. Do it?"
1986 (length upgradeable))))))
1987 (user-error "Upgrade aborted"))
1988 (mapc #'package-upgrade upgradeable))))
1989
1990(defun package--dependencies (pkg)
1991 "Return a list of all transitive dependencies of PKG.
1992If PKG is a package descriptor, the return value is a list of
1993package descriptors. If PKG is a symbol designating a package,
1994the return value is a list of symbols designating packages."
1995 (when-let* ((desc (if (package-desc-p pkg) pkg
1996 (cadr (assq pkg package-archive-contents)))))
1997 ;; Can we have circular dependencies? Assume "nope".
1998 (let ((all (named-let more ((pkg-desc desc))
1999 (let (deps)
2000 (dolist (req (package-desc-reqs pkg-desc))
2001 (setq deps (nconc
2002 (catch 'found
2003 (dolist (p (apply #'append (mapcar #'cdr (package--alist))))
2004 (when (and (string= (car req) (package-desc-name p))
2005 (version-list-<= (cadr req) (package-desc-version p)))
2006 (throw 'found (more p)))))
2007 deps)))
2008 (delete-dups (cons pkg-desc deps))))))
2009 (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all)))))
2010
2011(defun package-strip-rcs-id (str)
2012 "Strip RCS version ID from the version string STR.
2013If the result looks like a dotted numeric version, return it.
2014Otherwise return nil."
2015 (when str
2016 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
2017 (setq str (substring str (match-end 0))))
2018 (let ((l (version-to-list str)))
2019 ;; Don't return `str' but (package-version-join (version-to-list str))
2020 ;; to make sure we use a "canonical name"!
2021 (if l (package-version-join l)))))
2022
2023(declare-function lm-website "lisp-mnt" (&optional file))
2024
2025;;;###autoload
2026(defun package-install-from-buffer ()
2027 "Install a package from the current buffer.
2028The current buffer is assumed to be a single .el or .tar file or
2029a directory. These must follow the packaging guidelines (see
2030info node `(elisp)Packaging').
2031
2032Specially, if current buffer is a directory, the -pkg.el
2033description file is not mandatory, in which case the information
2034is derived from the main .el file in the directory. Using Dired,
2035you can restrict what files to install by marking specific files.
2036
2037Downloads and installs required packages as needed."
2038 (interactive)
2039 (let* ((pkg-desc
2040 (cond
2041 ((derived-mode-p 'dired-mode)
2042 ;; This is the only way a package-desc object with a `dir'
2043 ;; desc-kind can be created. Such packages can't be
2044 ;; uploaded or installed from archives, they can only be
2045 ;; installed from local buffers or directories.
2046 (package-dir-info))
2047 ((derived-mode-p 'tar-mode)
2048 (package-tar-file-info))
2049 (t
2050 ;; Package headers should be parsed from decoded text
2051 ;; (see Bug#48137) where possible.
2052 (if (and (eq buffer-file-coding-system 'no-conversion)
2053 buffer-file-name)
2054 (let* ((package-buffer (current-buffer))
2055 (decoding-system
2056 (car (find-operation-coding-system
2057 'insert-file-contents
2058 (cons buffer-file-name
2059 package-buffer)))))
2060 (with-temp-buffer
2061 (insert-buffer-substring package-buffer)
2062 (decode-coding-region (point-min) (point-max)
2063 decoding-system)
2064 (package-buffer-info)))
2065
2066 (save-excursion
2067 (package-buffer-info))))))
2068 (name (package-desc-name pkg-desc)))
2069 ;; Download and install the dependencies.
2070 (let* ((requires (package-desc-reqs pkg-desc))
2071 (transaction (package-compute-transaction nil requires)))
2072 (package-download-transaction transaction))
2073 ;; Install the package itself.
2074 (package-unpack pkg-desc)
2075 (unless (package--user-selected-p name)
2076 (package--save-selected-packages
2077 (cons name package-selected-packages)))
2078 (package--quickstart-maybe-refresh)
2079 pkg-desc))
2080
2081;;;###autoload
2082(defun package-install-file (file)
2083 "Install a package from FILE.
2084The file can either be a tar file, an Emacs Lisp file, or a
2085directory."
2086 (interactive "fPackage file name: ")
2087 (with-temp-buffer
2088 (if (file-directory-p file)
2089 (progn
2090 (setq default-directory file)
2091 (dired-mode))
2092 (insert-file-contents-literally file)
2093 (set-visited-file-name file)
2094 (set-buffer-modified-p nil)
2095 (when (string-match "\\.tar\\'" file) (tar-mode)))
2096 (unwind-protect
2097 (package-install-from-buffer)
2098 (fundamental-mode)))) ; free auxiliary data
2099
2100;;;###autoload
2101(defun package-install-selected-packages (&optional noconfirm)
2102 "Ensure packages in `package-selected-packages' are installed.
2103If some packages are not installed, propose to install them.
2104
2105If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
2106argument, don't ask for confirmation to install packages."
2107 (interactive "P")
2108 (package--archives-initialize)
2109 ;; We don't need to populate `package-selected-packages' before
2110 ;; using here, because the outcome is the same either way (nothing
2111 ;; gets installed).
2112 (if (not package-selected-packages)
2113 (message "`package-selected-packages' is empty, nothing to install")
2114 (let* ((not-installed (seq-remove #'package-installed-p package-selected-packages))
2115 (available (seq-filter (lambda (p) (assq p package-archive-contents)) not-installed))
2116 (difference (- (length not-installed) (length available))))
2117 (cond
2118 (available
2119 (when (or noconfirm
2120 (y-or-n-p
2121 (format "Packages to install: %d (%s), proceed? "
2122 (length available)
2123 (mapconcat #'symbol-name available " "))))
2124 (mapc (lambda (p) (package-install p 'dont-select)) available)))
2125 ((> difference 0)
2126 (message (substitute-command-keys
2127 "Packages that are not available: %d (the rest is already \
2128installed), maybe you need to \\[package-refresh-contents]")
2129 difference))
2130 (t
2131 (message "All your packages are already installed"))))))
2132
2133
2134;;; Package Deletion
2135
2136(defun package--newest-p (pkg)
2137 "Return non-nil if PKG is the newest package with its name."
2138 (equal (cadr (assq (package-desc-name pkg) package-alist))
2139 pkg))
2140
2141(declare-function comp-el-to-eln-filename "comp.c")
2142(defvar package-vc-repository-store)
2143(defun package--delete-directory (dir)
2144 "Delete PKG-DESC directory DIR recursively.
2145Clean-up the corresponding .eln files if Emacs is native
2146compiled, and remove the DIR from `load-path'."
2147 (setq load-path (cl-remove-if (lambda (s) (file-in-directory-p s dir))
2148 load-path))
2149 (when (featurep 'native-compile)
2150 (cl-loop
2151 for file in (directory-files-recursively dir
2152 ;; Exclude lockfiles
2153 (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos))
2154 do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
2155 (if (file-symlink-p (directory-file-name dir))
2156 (delete-file (directory-file-name dir))
2157 (delete-directory dir t)))
2158
2159
2160(defun package-delete (pkg-desc &optional force nosave)
2161 "Delete package PKG-DESC.
2162
2163Argument PKG-DESC is the full description of the package, for example as
2164obtained by `package-get-descriptor'. Interactively, prompt the user
2165for the package name and version.
2166
2167When package is used elsewhere as dependency of another package,
2168refuse deleting it and return an error.
2169If prefix argument FORCE is non-nil, package will be deleted even
2170if it is used elsewhere.
2171If NOSAVE is non-nil, the package is not removed from
2172`package-selected-packages'."
2173 (interactive
2174 (progn
2175 (let* ((package-table
2176 (mapcar
2177 (lambda (p) (cons (package-desc-full-name p) p))
2178 (delq nil
2179 (mapcar (lambda (p) (unless (package-built-in-p p) p))
2180 (apply #'append (mapcar #'cdr (package--alist)))))))
2181 (package-name (completing-read "Delete package: "
2182 (mapcar #'car package-table)
2183 nil t)))
2184 (list (cdr (assoc package-name package-table))
2185 current-prefix-arg nil))))
2186 (let* ((dir (package-desc-dir pkg-desc))
2187 (name (package-desc-name pkg-desc))
2188 (new-package-alist (let ((pkgs (assq name package-alist)))
2189 (if (null (remove pkg-desc (cdr pkgs)))
2190 (remq pkgs package-alist)
2191 package-alist)))
2192 pkg-used-elsewhere-by)
2193 ;; If the user is trying to delete this package, they definitely
2194 ;; don't want it marked as selected, so we remove it from
2195 ;; `package-selected-packages' even if it can't be deleted.
2196 (when (and (null nosave)
2197 (package--user-selected-p name)
2198 ;; Don't deselect if this is an older version of an
2199 ;; upgraded package.
2200 (package--newest-p pkg-desc))
2201 (package--save-selected-packages (remove name package-selected-packages)))
2202 (cond ((not (string-prefix-p (file-name-as-directory
2203 (expand-file-name package-user-dir))
2204 (expand-file-name dir)))
2205 ;; Don't delete "system" packages.
2206 (error "Package `%s' is a system package, not deleting"
2207 (package-desc-full-name pkg-desc)))
2208 ((and (null force)
2209 (setq pkg-used-elsewhere-by
2210 (let ((package-alist new-package-alist))
2211 (package--used-elsewhere-p pkg-desc)))) ;See bug#65475
2212 ;; Don't delete packages used as dependency elsewhere.
2213 (error "Package `%s' is used by `%s' as dependency, not deleting"
2214 (package-desc-full-name pkg-desc)
2215 (package-desc-name pkg-used-elsewhere-by)))
2216 (t
2217 (add-hook 'post-command-hook #'package-menu--post-refresh)
2218 (package--delete-directory dir)
2219 ;; Remove NAME-VERSION.signed and NAME-readme.txt files.
2220 ;;
2221 ;; NAME-readme.txt files are no longer created, but they
2222 ;; may be left around from an earlier install.
2223 (dolist (suffix '(".signed" "readme.txt"))
2224 (let* ((version (package-version-join (package-desc-version pkg-desc)))
2225 (file (concat (if (string= suffix ".signed")
2226 dir
2227 (substring dir 0 (- (length version))))
2228 suffix)))
2229 (when (file-exists-p file)
2230 (delete-file file))))
2231 ;; Update package-alist.
2232 (setq package-alist new-package-alist)
2233 (package--quickstart-maybe-refresh)
2234 (message "Package `%s' deleted."
2235 (package-desc-full-name pkg-desc))))))
2236
2237;;;###autoload
2238(defun package-reinstall (pkg)
2239 "Reinstall package PKG.
2240PKG should be either a symbol, the package name, or a `package-desc'
2241object."
2242 (interactive
2243 (progn
2244 (package--archives-initialize)
2245 (list (intern (completing-read
2246 "Reinstall package: "
2247 (mapcar #'symbol-name
2248 (mapcar #'car package-alist)))))))
2249 (package--archives-initialize)
2250 (package-delete
2251 (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist)))
2252 'force 'nosave)
2253 (package-install pkg 'dont-select))
2254
2255;;;###autoload
2256(defun package-recompile (pkg)
2257 "Byte-compile package PKG again.
2258PKG should be either a symbol, the package name, or a `package-desc'
2259object."
2260 (interactive (list (intern (completing-read
2261 "Recompile package: "
2262 (mapcar #'symbol-name
2263 (mapcar #'car package-alist))))))
2264 (let ((pkg-desc (if (package-desc-p pkg)
2265 pkg
2266 (cadr (assq pkg package-alist)))))
2267 ;; Delete the old .elc files to ensure that we don't inadvertently
2268 ;; load them (in case they contain byte code/macros that are now
2269 ;; invalid).
2270 (dolist (elc (directory-files-recursively
2271 (package-desc-dir pkg-desc) "\\.elc\\'"))
2272 (delete-file elc))
2273 (package--compile pkg-desc)))
2274
2275;;;###autoload
2276(defun package-recompile-all ()
2277 "Byte-compile all installed packages.
2278This is meant to be used only in the case the byte-compiled files
2279are invalid due to changed byte-code, macros or the like."
2280 (interactive)
2281 (pcase-dolist (`(_ ,pkg-desc) package-alist)
2282 (with-demoted-errors "Error while recompiling: %S"
2283 (package-recompile pkg-desc))))
2284
2285;;;###autoload
2286(defun package-autoremove (&optional noconfirm)
2287 "Remove packages that are no longer needed.
2288
2289Packages that are no more needed by other packages in
2290`package-selected-packages' and their dependencies
2291will be deleted.
2292
2293If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
2294argument, don't ask for confirmation to install packages."
2295 (interactive "P")
2296 ;; If `package-selected-packages' is nil, it would make no sense to
2297 ;; try to populate it here, because then `package-autoremove' will
2298 ;; do absolutely nothing.
2299 (when (or noconfirm
2300 package-selected-packages
2301 (yes-or-no-p
2302 (format-message
2303 "`package-selected-packages' is empty! Really remove ALL packages? ")))
2304 (let ((removable (package--removable-packages)))
2305 (if removable
2306 (when (or noconfirm
2307 (y-or-n-p
2308 (format "Packages to delete: %d (%s), proceed? "
2309 (length removable)
2310 (mapconcat #'symbol-name removable " "))))
2311 (mapc (lambda (p)
2312 (package-delete (cadr (assq p package-alist)) t))
2313 removable))
2314 (message "Nothing to autoremove")))))
2315
2316(defun package-isolate (packages &optional temp-init)
2317 "Start an uncustomized Emacs and only load a set of PACKAGES.
2318Interactively, prompt for PACKAGES to load, which should be specified
2319separated by commas.
2320If called from Lisp, PACKAGES should be a list of packages to load.
2321If TEMP-INIT is non-nil, or when invoked with a prefix argument,
2322the Emacs user directory is set to a temporary directory.
2323This command is intended for testing Emacs and/or the packages
2324in a clean environment."
2325 (interactive
2326 (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p))
2327 unless (package-built-in-p p)
2328 collect (cons (package-desc-full-name p) p) into table
2329 finally return
2330 (list
2331 (cl-loop for c in
2332 (completing-read-multiple
2333 "Packages to isolate: " table
2334 nil t)
2335 collect (alist-get c table nil nil #'string=))
2336 current-prefix-arg)))
2337 (let* ((name (concat "package-isolate-"
2338 (mapconcat #'package-desc-full-name packages ",")))
2339 (all-packages (delete-consecutive-dups
2340 (sort (append packages (mapcan #'package--dependencies packages))
2341 (lambda (p0 p1)
2342 (string< (package-desc-name p0) (package-desc-name p1))))))
2343 initial-scratch-message package-load-list)
2344 (with-temp-buffer
2345 (insert ";; This is an isolated testing environment, with these packages enabled:\n\n")
2346 (dolist (package all-packages)
2347 (push (list (package-desc-name package)
2348 (package-version-join (package-desc-version package)))
2349 package-load-list)
2350 (insert ";; - " (package-desc-full-name package))
2351 (unless (memq package packages)
2352 (insert " (dependency)"))
2353 (insert "\n"))
2354 (insert "\n")
2355 (setq initial-scratch-message (buffer-string)))
2356 (apply #'start-process (concat "*" name "*") nil
2357 (list (expand-file-name invocation-name invocation-directory)
2358 "--quick" "--debug-init"
2359 "--init-directory" (if temp-init
2360 (make-temp-file name t)
2361 user-emacs-directory)
2362 (format "--eval=%S"
2363 `(progn
2364 (setq initial-scratch-message ,initial-scratch-message)
2365
2366 (require 'package)
2367 ,@(mapcar
2368 (lambda (dir)
2369 `(add-to-list 'package-directory-list ,dir))
2370 (cons package-user-dir package-directory-list))
2371 (setq package-load-list ',package-load-list)
2372 (package-activate-all)))))))
2373
2374
2375;;;; Package description buffer.
2376
2377;;;###autoload
2378(defun describe-package (package)
2379 "Display the full documentation of PACKAGE (a symbol)."
2380 (interactive
2381 (let* ((guess (or (function-called-at-point)
2382 (symbol-at-point))))
2383 (require 'finder-inf nil t)
2384 ;; Load the package list if necessary (but don't activate them).
2385 (unless package--initialized
2386 (package-initialize t))
2387 (let ((packages (append (mapcar #'car package-alist)
2388 (mapcar #'car package-archive-contents)
2389 (mapcar #'car package--builtins))))
2390 (unless (memq guess packages)
2391 (setq guess nil))
2392 (setq packages (mapcar #'symbol-name packages))
2393 (let ((val
2394 (completing-read (format-prompt "Describe package" guess)
2395 packages nil t nil nil (when guess
2396 (symbol-name guess)))))
2397 (list (and (> (length val) 0) (intern val)))))))
2398 (if (not (or (package-desc-p package) (and package (symbolp package))))
2399 (message "No package specified")
2400 (help-setup-xref (list #'describe-package package)
2401 (called-interactively-p 'interactive))
2402 (with-help-window (help-buffer)
2403 (with-current-buffer standard-output
2404 (describe-package-1 package)))))
2405
2406(defface package-help-section-name
2407 '((t :inherit (bold font-lock-function-name-face)))
2408 "Face used on section names in package description buffers."
2409 :version "25.1")
2410
2411(defun package--print-help-section (name &rest strings)
2412 "Print \"NAME: \", right aligned to the 13th column.
2413If more STRINGS are provided, insert them followed by a newline.
2414Otherwise no newline is inserted."
2415 (declare (indent 1))
2416 (insert (make-string (max 0 (- 11 (string-width name))) ?\s)
2417 (propertize (concat name ": ") 'font-lock-face 'package-help-section-name))
2418 (when strings
2419 (apply #'insert strings)
2420 (insert "\n")))
2421
2422(declare-function lm-commentary "lisp-mnt" (&optional file))
2423
2424(defun package--get-description (desc)
2425 "Return a string containing the long description of the package DESC.
2426The description is read from the installed package files."
2427 ;; Installed packages have nil for kind, so we look for README
2428 ;; first, then fall back to the Commentary header.
2429
2430 ;; We don’t include README.md here, because that is often the home
2431 ;; page on a site like github, and not suitable as the package long
2432 ;; description.
2433 (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org"))
2434 file
2435 (srcdir (package-desc-dir desc))
2436 result)
2437 (while (and files
2438 (not result))
2439 (setq file (pop files))
2440 (when (file-readable-p (expand-file-name file srcdir))
2441 ;; Found a README.
2442 (with-temp-buffer
2443 (insert-file-contents (expand-file-name file srcdir))
2444 (setq result (buffer-string)))))
2445
2446 (or
2447 result
2448
2449 ;; Look for Commentary header.
2450 (lm-commentary (expand-file-name
2451 (format "%s.el" (package-desc-name desc)) srcdir))
2452 "")))
2453
2454(defun package--describe-add-library-links ()
2455 "Add links to library names in package description."
2456 (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
2457 (if (locate-library (match-string 1))
2458 (make-text-button (match-beginning 1) (match-end 1)
2459 'xref (match-string-no-properties 1)
2460 'help-echo "Read this file's commentary"
2461 :type 'package--finder-xref))))
2462
2463(defun describe-package-1 (pkg)
2464 "Insert the package description for PKG.
2465Helper function for `describe-package'."
2466 (require 'lisp-mnt)
2467 (let* ((desc (or
2468 (if (package-desc-p pkg) pkg)
2469 (cadr (assq pkg package-alist))
2470 (let ((built-in (assq pkg package--builtins)))
2471 (if built-in
2472 (package--from-builtin built-in)
2473 (cadr (assq pkg package-archive-contents))))))
2474 (name (if desc (package-desc-name desc) pkg))
2475 (pkg-dir (if desc (package-desc-dir desc)))
2476 (reqs (if desc (package-desc-reqs desc)))
2477 (required-by (if desc (package--used-elsewhere-p desc nil 'all)))
2478 (version (if desc (package-desc-version desc)))
2479 (archive (if desc (package-desc-archive desc)))
2480 (extras (and desc (package-desc-extras desc)))
2481 (website (cdr (assoc :url extras)))
2482 (commit (cdr (assoc :commit extras)))
2483 (keywords (if desc (package-desc--keywords desc)))
2484 (built-in (eq pkg-dir 'builtin))
2485 (installable (and archive (not built-in)))
2486 (status (if desc (package-desc-status desc) "orphan"))
2487 (incompatible-reason (package--incompatible-p desc))
2488 (signed (if desc (package-desc-signed desc)))
2489 (maintainers (or (cdr (assoc :maintainer extras))
2490 (cdr (assoc :maintainers extras))))
2491 (authors (cdr (assoc :authors extras)))
2492 (news (and-let* (pkg-dir
2493 ((not built-in))
2494 (file (expand-file-name "news" pkg-dir))
2495 ((file-regular-p file))
2496 ((file-readable-p file)))
2497 file)))
2498 (when (string= status "avail-obso")
2499 (setq status "available obsolete"))
2500 (when incompatible-reason
2501 (setq status "incompatible"))
2502 (princ (format "Package %S is %s.\n\n" name status))
2503
2504 ;; TODO: Remove the string decorations and reformat the strings
2505 ;; for future l10n.
2506 (package--print-help-section "Status")
2507 (cond (built-in
2508 (insert (propertize (capitalize status)
2509 'font-lock-face 'package-status-built-in)
2510 "."))
2511 (pkg-dir
2512 (insert (propertize (if (member status '("unsigned" "dependency"))
2513 "Installed"
2514 (capitalize status))
2515 'font-lock-face 'package-status-built-in))
2516 (insert (substitute-command-keys " in `"))
2517 (let ((dir (abbreviate-file-name
2518 (file-name-as-directory
2519 (if (file-in-directory-p pkg-dir package-user-dir)
2520 (file-relative-name pkg-dir package-user-dir)
2521 pkg-dir)))))
2522 (help-insert-xref-button dir 'help-package-def pkg-dir))
2523 (if (and (package-built-in-p name)
2524 (not (package-built-in-p name version)))
2525 (insert (substitute-command-keys
2526 "',\n shadowing a ")
2527 (propertize "built-in package"
2528 'font-lock-face 'package-status-built-in))
2529 (insert (substitute-quotes "'")))
2530 (if signed
2531 (insert ".")
2532 (insert " (unsigned)."))
2533 (when (and (package-desc-p desc)
2534 (not required-by)
2535 (member status '("unsigned" "installed")))
2536 (insert " ")
2537 (package-make-button "Delete"
2538 'action #'package-delete-button-action
2539 'package-desc desc)))
2540 (incompatible-reason
2541 (insert (propertize "Incompatible" 'font-lock-face 'font-lock-warning-face)
2542 " because it depends on ")
2543 (if (stringp incompatible-reason)
2544 (insert "Emacs " incompatible-reason ".")
2545 (insert "uninstallable packages.")))
2546 (installable
2547 (insert (capitalize status))
2548 (insert " from " (format "%s" archive))
2549 (insert " -- ")
2550 (package-make-button
2551 "Install"
2552 'action 'package-install-button-action
2553 'package-desc desc))
2554 (t (insert (capitalize status) ".")))
2555 (insert "\n")
2556 (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive.
2557 (package--print-help-section "Archive"
2558 (or archive "n/a")))
2559 (and version
2560 (package--print-help-section "Version"
2561 (package-version-join version)))
2562 (when commit
2563 (package--print-help-section "Commit" commit))
2564 (when desc
2565 (package--print-help-section "Summary"
2566 (package-desc-summary desc)))
2567
2568 (setq reqs (if desc (package-desc-reqs desc)))
2569 (when reqs
2570 (package--print-help-section "Requires")
2571 (let ((first t))
2572 (dolist (req reqs)
2573 (let* ((name (car req))
2574 (vers (cadr req))
2575 (text (format "%s-%s" (symbol-name name)
2576 (package-version-join vers)))
2577 (reason (if (and (listp incompatible-reason)
2578 (assq name incompatible-reason))
2579 " (not available)" "")))
2580 (cond (first (setq first nil))
2581 ((>= (+ 2 (current-column) (length text) (length reason))
2582 (window-width))
2583 (insert ",\n "))
2584 (t (insert ", ")))
2585 (help-insert-xref-button text 'help-package name)
2586 (insert reason)))
2587 (insert "\n")))
2588 (when required-by
2589 (package--print-help-section "Required by")
2590 (let ((first t))
2591 (dolist (pkg required-by)
2592 (let ((text (package-desc-full-name pkg)))
2593 (cond (first (setq first nil))
2594 ((>= (+ 2 (current-column) (length text))
2595 (window-width))
2596 (insert ",\n "))
2597 (t (insert ", ")))
2598 (help-insert-xref-button text 'help-package
2599 (package-desc-name pkg))))
2600 (insert "\n")))
2601 (when website
2602 ;; Prefer https for the website of packages on common domains.
2603 (when (string-match-p (rx bol "http://" (or "elpa." "www." "git." "")
2604 (or "nongnu.org" "gnu.org" "sr.ht"
2605 "emacswiki.org" "gitlab.com" "github.com")
2606 "/")
2607 website)
2608 ;; But only if the user has "https" in `package-archives'.
2609 (let ((gnu (cdr (assoc "gnu" package-archives))))
2610 (and gnu (string-match-p "^https" gnu)
2611 (setq website
2612 (replace-regexp-in-string "^http" "https" website)))))
2613 (package--print-help-section "Website")
2614 (help-insert-xref-button website 'help-url website)
2615 (insert "\n"))
2616 (when keywords
2617 (package--print-help-section "Keywords")
2618 (dolist (k keywords)
2619 (package-make-button
2620 k
2621 'package-keyword k
2622 'action 'package-keyword-button-action)
2623 (insert " "))
2624 (insert "\n"))
2625 (when maintainers
2626 (unless (and (listp (car maintainers)) (listp (cdr maintainers)))
2627 (setq maintainers (list maintainers)))
2628 (package--print-help-section
2629 (if (cdr maintainers) "Maintainers" "Maintainer"))
2630 (dolist (maintainer maintainers)
2631 (when (bolp)
2632 (insert (make-string 13 ?\s)))
2633 (package--print-email-button maintainer)))
2634 (when authors
2635 (package--print-help-section (if (cdr authors) "Authors" "Author"))
2636 (dolist (author authors)
2637 (when (bolp)
2638 (insert (make-string 13 ?\s)))
2639 (package--print-email-button author)))
2640 (let* ((all-pkgs (append (cdr (assq name package-alist))
2641 (cdr (assq name package-archive-contents))
2642 (let ((bi (assq name package--builtins)))
2643 (if bi (list (package--from-builtin bi))))))
2644 (other-pkgs (delete desc all-pkgs)))
2645 (when other-pkgs
2646 (package--print-help-section "Other versions"
2647 (mapconcat (lambda (opkg)
2648 (let* ((ov (package-desc-version opkg))
2649 (dir (package-desc-dir opkg))
2650 (from (or (package-desc-archive opkg)
2651 (if (stringp dir) "installed" dir))))
2652 (if (not ov) (format "%s" from)
2653 (format "%s (%s)"
2654 (make-text-button (package-version-join ov) nil
2655 'font-lock-face 'link
2656 'follow-link t
2657 'action
2658 (lambda (_button)
2659 (describe-package opkg)))
2660 from))))
2661 other-pkgs ", ")
2662 ".")))
2663
2664 (insert "\n")
2665
2666 (let ((start-of-description (point)))
2667 (if built-in
2668 ;; For built-in packages, get the description from the
2669 ;; Commentary header.
2670 (insert (or (lm-commentary (locate-file (format "%s.el" name)
2671 load-path
2672 load-file-rep-suffixes))
2673 ""))
2674
2675 (if (package-installed-p desc)
2676 ;; For installed packages, get the description from the
2677 ;; installed files.
2678 (insert (package--get-description desc))
2679
2680 ;; For non-built-in, non-installed packages, get description from
2681 ;; the archive.
2682 (let* ((basename (format "%s-readme.txt" name))
2683 readme-string)
2684
2685 (package--with-response-buffer (package-archive-base desc)
2686 :file basename :noerror t
2687 (save-excursion
2688 (goto-char (point-max))
2689 (unless (bolp)
2690 (insert ?\n)))
2691 (cl-assert (not enable-multibyte-characters))
2692 (setq readme-string
2693 ;; The readme.txt files are defined to contain utf-8 text.
2694 (decode-coding-region (point-min) (point-max) 'utf-8 t))
2695 t)
2696 (insert (or readme-string
2697 "This package does not provide a description.")))))
2698
2699 ;; Insert news if available.
2700 (when news
2701 (insert "\n" (make-separator-line) "\n"
2702 (propertize "* News" 'face 'package-help-section-name)
2703 "\n\n")
2704 (insert-file-contents news))
2705
2706 ;; Make library descriptions into links.
2707 (goto-char start-of-description)
2708 (package--describe-add-library-links)
2709 ;; Make URLs in the description into links.
2710 (goto-char start-of-description)
2711 (browse-url-add-buttons))))
2712
2713(defun package-install-button-action (button)
2714 "Run `package-install' on the package BUTTON points to.
2715Used for the `action' property of buttons in the buffer created by
2716`describe-package'."
2717 (let ((pkg-desc (button-get button 'package-desc)))
2718 (when (y-or-n-p (format-message "Install package `%s'? "
2719 (package-desc-full-name pkg-desc)))
2720 (package-install pkg-desc nil)
2721 (describe-package (package-desc-name pkg-desc)))))
2722
2723(defun package-delete-button-action (button)
2724 "Run `package-delete' on the package BUTTON points to.
2725Used for the `action' property of buttons in the buffer created by
2726`describe-package'."
2727 (let ((pkg-desc (button-get button 'package-desc)))
2728 (when (y-or-n-p (format-message "Delete package `%s'? "
2729 (package-desc-full-name pkg-desc)))
2730 (package-delete pkg-desc)
2731 (describe-package (package-desc-name pkg-desc)))))
2732
2733(defun package-keyword-button-action (button)
2734 "Show filtered \"*Packages*\" buffer for BUTTON.
2735The buffer is filtered by the `package-keyword' property of BUTTON.
2736Used for the `action' property of buttons in the buffer created by
2737`describe-package'."
2738 (let ((pkg-keyword (button-get button 'package-keyword)))
2739 (package-show-package-list t (list pkg-keyword))))
2740
2741(defun package-make-button (text &rest properties)
2742 "Insert button labeled TEXT with button PROPERTIES at point.
2743PROPERTIES are passed to `insert-text-button', for which this
2744function is a convenience wrapper used by `describe-package-1'."
2745 (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
2746 (button-face (if (display-graphic-p)
2747 (progn
2748 (require 'cus-edit) ; for the custom-button face
2749 'custom-button)
2750 'link)))
2751 (apply #'insert-text-button button-text 'face button-face 'follow-link t
2752 properties)))
2753
2754(defun package--finder-goto-xref (button)
2755 "Jump to a Lisp file for the BUTTON at point."
2756 (let* ((file (button-get button 'xref))
2757 (lib (locate-library file)))
2758 (if lib (finder-commentary lib)
2759 (message "Unable to locate `%s'" file))))
2760
2761(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref)
2762
2763(defun package--print-email-button (recipient)
2764 "Insert a button whose action will send an email to RECIPIENT.
2765NAME should have the form (FULLNAME . EMAIL) where FULLNAME is
2766either a full name or nil, and EMAIL is a valid email address."
2767 (when (car recipient)
2768 (insert (car recipient)))
2769 (when (and (car recipient) (cdr recipient))
2770 (insert " "))
2771 (when (cdr recipient)
2772 (insert "<")
2773 (insert-text-button (cdr recipient)
2774 'follow-link t
2775 'action (lambda (_)
2776 (compose-mail
2777 (format "%s <%s>" (car recipient) (cdr recipient)))))
2778 (insert ">"))
2779 (insert "\n"))
2780
2781
2782;;;; Package menu mode.
2783
2784(defvar-keymap package-menu-mode-map
2785 :doc "Local keymap for `package-menu-mode' buffers."
2786 :parent tabulated-list-mode-map
2787 "C-m" #'package-menu-describe-package
2788 "u" #'package-menu-mark-unmark
2789 "DEL" #'package-menu-backup-unmark
2790 "d" #'package-menu-mark-delete
2791 "i" #'package-menu-mark-install
2792 "U" #'package-menu-mark-upgrades
2793 "r" #'revert-buffer
2794 "~" #'package-menu-mark-obsolete-for-deletion
2795 "w" #'package-browse-url
2796 "b" #'package-report-bug
2797 "x" #'package-menu-execute
2798 "h" #'package-menu-quick-help
2799 "H" #'package-menu-hide-package
2800 "?" #'package-menu-describe-package
2801 "(" #'package-menu-toggle-hiding
2802 "/ /" #'package-menu-clear-filter
2803 "/ a" #'package-menu-filter-by-archive
2804 "/ d" #'package-menu-filter-by-description
2805 "/ k" #'package-menu-filter-by-keyword
2806 "/ N" #'package-menu-filter-by-name-or-description
2807 "/ n" #'package-menu-filter-by-name
2808 "/ s" #'package-menu-filter-by-status
2809 "/ v" #'package-menu-filter-by-version
2810 "/ m" #'package-menu-filter-marked
2811 "/ u" #'package-menu-filter-upgradable)
2812
2813(easy-menu-define package-menu-mode-menu package-menu-mode-map
2814 "Menu for `package-menu-mode'."
2815 '("Package"
2816 ["Describe Package" package-menu-describe-package :help "Display information about this package"]
2817 ["Open Package Website" package-browse-url
2818 :help "Open the website of this package"]
2819 ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
2820 "--"
2821 ["Refresh Package List" revert-buffer
2822 :help "Redownload the package archive(s)"
2823 :active (not package--downloads-in-progress)]
2824 ["Execute Marked Actions" package-menu-execute :help "Perform all the marked actions"]
2825
2826 "--"
2827 ["Mark All Available Upgrades" package-menu-mark-upgrades
2828 :help "Mark packages that have a newer version for upgrading"
2829 :active (not package--downloads-in-progress)]
2830 ["Mark All Obsolete for Deletion" package-menu-mark-obsolete-for-deletion :help "Mark all obsolete packages for deletion"]
2831 ["Mark for Install" package-menu-mark-install :help "Mark a package for installation and move to the next line"]
2832 ["Mark for Deletion" package-menu-mark-delete :help "Mark a package for deletion and move to the next line"]
2833 ["Unmark" package-menu-mark-unmark :help "Clear any marks on a package and move to the next line"]
2834
2835 "--"
2836 ("Filter Packages"
2837 ["Filter by Archive" package-menu-filter-by-archive
2838 :help
2839 "Prompt for archive(s), display only packages from those archives"]
2840 ["Filter by Description" package-menu-filter-by-description
2841 :help
2842 "Prompt for regexp, display only packages with matching description"]
2843 ["Filter by Keyword" package-menu-filter-by-keyword
2844 :help
2845 "Prompt for keyword(s), display only packages with matching keywords"]
2846 ["Filter by Name" package-menu-filter-by-name
2847 :help
2848 "Prompt for regexp, display only packages whose names match the regexp"]
2849 ["Filter by Name or Description" package-menu-filter-by-name-or-description
2850 :help
2851 "Prompt for regexp, display only packages whose name or description matches"]
2852 ["Filter by Status" package-menu-filter-by-status
2853 :help
2854 "Prompt for status(es), display only packages with those statuses"]
2855 ["Filter by Upgrades available" package-menu-filter-upgradable
2856 :help "Display only installed packages for which upgrades are available"]
2857 ["Filter by Version" package-menu-filter-by-version
2858 :help
2859 "Prompt for version and comparison operator, display only packages of matching versions"]
2860 ["Filter Marked" package-menu-filter-marked
2861 :help "Display only packages marked for installation or deletion"]
2862 ["Clear Filter" package-menu-clear-filter
2863 :help "Clear package list filtering, display the entire list again"])
2864
2865 ["Hide by Regexp" package-menu-hide-package
2866 :help "Toggle visibility of obsolete and unwanted packages"]
2867 ["Display Older Versions" package-menu-toggle-hiding
2868 :style toggle :selected (not package-menu--hide-packages)
2869 :help "Display package even if a newer version is already installed"]
2870
2871 "--"
2872 ["Quit" quit-window :help "Quit package selection"]
2873 ["Customize" (customize-group 'package)]))
2874
2875(defvar package-menu--new-package-list nil
2876 "List of newly-available packages since `list-packages' was last called.")
2877
2878(defvar package-menu--transaction-status nil
2879 "Mode-line status of ongoing package transaction.")
2880
2881(defconst package-menu-mode-line-format
2882 '((package-menu-mode-line-info
2883 (:eval (symbol-value 'package-menu-mode-line-info)))))
2884
2885(defvar-local package-menu-mode-line-info nil
2886 "Variable which stores package-menu mode-line format.")
2887
2888(defun package-menu--set-mode-line-format ()
2889 "Display package-menu mode-line."
2890 (when-let* ((buf (get-buffer "*Packages*"))
2891 ((buffer-live-p buf)))
2892 (with-current-buffer buf
2893 (setq package-menu-mode-line-info
2894 (let ((installed 0)
2895 (new 0)
2896 (total (length package-archive-contents))
2897 (to-upgrade (length (package-menu--find-upgrades)))
2898 (total-help "Total number of packages of all package archives")
2899 (installed-help "Total number of packages installed")
2900 (upgrade-help "Total number of packages to upgrade")
2901 (new-help "Total number of packages added recently"))
2902
2903 (save-excursion
2904 (goto-char (point-min))
2905 (while (not (eobp))
2906 (let ((status (package-menu-get-status)))
2907 (cond
2908 ((member status
2909 '("installed" "dependency" "unsigned"))
2910 (setq installed (1+ installed)))
2911 ((equal status "new")
2912 (setq new (1+ new)))))
2913 (forward-line)))
2914
2915 (setq installed (number-to-string installed))
2916 (setq total (number-to-string total))
2917 (setq to-upgrade (number-to-string to-upgrade))
2918
2919 (list
2920 " ["
2921 (propertize "Total: " 'help-echo total-help)
2922 (propertize total
2923 'help-echo total-help
2924 'face 'package-mode-line-total)
2925 " / "
2926 (propertize "Installed: " 'help-echo installed-help)
2927 (propertize installed
2928 'help-echo installed-help
2929 'face 'package-mode-line-installed)
2930 " / "
2931 (propertize "To Upgrade: " 'help-echo upgrade-help)
2932 (propertize to-upgrade
2933 'help-echo upgrade-help
2934 'face 'package-mode-line-to-upgrade)
2935 (when (> new 0)
2936 (concat
2937 " / "
2938 (propertize "New: " 'help-echo new-help)
2939 (propertize (number-to-string new)
2940 'help-echo new-help
2941 'face 'package-mode-line-new)))
2942 "] "))))))
2943(defvar package-menu--tool-bar-map
2944 (let ((map (make-sparse-keymap)))
2945 (tool-bar-local-item-from-menu
2946 #'package-menu-execute "package-menu/execute"
2947 map package-menu-mode-map)
2948 (define-key-after map [separator-1] menu-bar-separator)
2949 (tool-bar-local-item-from-menu
2950 #'package-menu-mark-unmark "package-menu/unmark"
2951 map package-menu-mode-map)
2952 (tool-bar-local-item-from-menu
2953 #'package-menu-mark-install "package-menu/install"
2954 map package-menu-mode-map)
2955 (tool-bar-local-item-from-menu
2956 #'package-menu-mark-delete "package-menu/delete"
2957 map package-menu-mode-map)
2958 (tool-bar-local-item-from-menu
2959 #'package-menu-describe-package "package-menu/info"
2960 map package-menu-mode-map)
2961 (tool-bar-local-item-from-menu
2962 #'package-browse-url "package-menu/url"
2963 map package-menu-mode-map)
2964 (tool-bar-local-item
2965 "package-menu/upgrade" 'package-upgrade-all
2966 'package-upgrade-all
2967 map :help "Upgrade all the packages")
2968 (define-key-after map [separator-2] menu-bar-separator)
2969 (tool-bar-local-item
2970 "search" 'isearch-forward 'search map
2971 :help "Search" :vert-only t)
2972 (tool-bar-local-item-from-menu
2973 #'revert-buffer "refresh"
2974 map package-menu-mode-map)
2975 (tool-bar-local-item-from-menu
2976 #'quit-window "close"
2977 map package-menu-mode-map)
2978 map))
2979
2980(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
2981 "Major mode for browsing a list of packages.
2982The most useful commands here are:
2983
2984 `x': Install the package under point if it isn't already installed,
2985 and delete it if it's already installed,
2986 `i': mark a package for installation, and
2987 `d': mark a package for deletion. Use the `x' command to perform the
2988 actions on the marked files.
2989\\<package-menu-mode-map>
2990\\{package-menu-mode-map}"
2991 :interactive nil
2992 (setq mode-line-process '((package--downloads-in-progress ":Loading")
2993 (package-menu--transaction-status
2994 package-menu--transaction-status)))
2995 (setq-local mode-line-misc-info
2996 (append
2997 mode-line-misc-info
2998 package-menu-mode-line-format))
2999 (setq-local tool-bar-map package-menu--tool-bar-map)
3000 (setq tabulated-list-format
3001 `[("Package" ,package-name-column-width package-menu--name-predicate)
3002 ("Version" ,package-version-column-width package-menu--version-predicate)
3003 ("Status" ,package-status-column-width package-menu--status-predicate)
3004 ("Archive" ,package-archive-column-width package-menu--archive-predicate)
3005 ("Description" 0 package-menu--description-predicate)])
3006 (setq tabulated-list-padding 2)
3007 (setq tabulated-list-sort-key (cons "Status" nil))
3008 (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t)
3009 (tabulated-list-init-header)
3010 (setq revert-buffer-function 'package-menu--refresh-contents)
3011 (setf imenu-prev-index-position-function
3012 #'package--imenu-prev-index-position-function)
3013 (setf imenu-extract-index-name-function
3014 #'package--imenu-extract-index-name-function))
3015
3016(defmacro package--push (pkg-desc status listname)
3017 "Convenience macro for `package-menu--generate'.
3018If the alist stored in the symbol LISTNAME lacks an entry for a
3019package PKG-DESC, add one. The alist is keyed with PKG-DESC."
3020 (declare (obsolete nil "27.1"))
3021 `(unless (assoc ,pkg-desc ,listname)
3022 ;; FIXME: Should we move status into pkg-desc?
3023 (push (cons ,pkg-desc ,status) ,listname)))
3024
3025(defvar package-list-unversioned nil
3026 "If non-nil, include packages that don't have a version in `list-packages'.")
3027
3028(defvar package-list-unsigned nil
3029 "If non-nil, mention in the list which packages were installed without signature.")
3030
3031(defvar package--emacs-version-list (version-to-list emacs-version)
3032 "The value of variable `emacs-version' as a list.")
3033
3034(defun package--ensure-package-menu-mode ()
3035 "Signal a user-error if major mode is not `package-menu-mode'."
3036 (unless (derived-mode-p 'package-menu-mode)
3037 (user-error "The current buffer is not a Package Menu")))
3038
3039(defun package--incompatible-p (pkg &optional shallow)
3040 "Return non-nil if PKG has no chance of being installable.
3041PKG is a `package-desc' object.
3042
3043If SHALLOW is non-nil, this only checks if PKG depends on a
3044higher `emacs-version' than the one being used. Otherwise, also
3045checks the viability of dependencies, according to
3046`package--compatibility-table'.
3047
3048If PKG requires an incompatible Emacs version, the return value
3049is this version (as a string).
3050If PKG requires incompatible packages, the return value is a list
3051of these dependencies, similar to the list returned by
3052`package-desc-reqs'."
3053 (let* ((reqs (package-desc-reqs pkg))
3054 (version (cadr (assq 'emacs reqs))))
3055 (if (and version (version-list-< package--emacs-version-list version))
3056 (package-version-join version)
3057 (unless shallow
3058 (let (out)
3059 (dolist (dep (package-desc-reqs pkg) out)
3060 (let ((dep-name (car dep)))
3061 (unless (eq 'emacs dep-name)
3062 (let ((cv (gethash dep-name package--compatibility-table)))
3063 (when (version-list-< (or cv '(0)) (or (cadr dep) '(0)))
3064 (push dep out)))))))))))
3065
3066(defun package-desc-status (pkg-desc)
3067 "Return the status of `package-desc' object PKG-DESC."
3068 (let* ((name (package-desc-name pkg-desc))
3069 (dir (package-desc-dir pkg-desc))
3070 (lle (assq name package-load-list))
3071 (held (cadr lle))
3072 (version (package-desc-version pkg-desc))
3073 (signed (or (not package-list-unsigned)
3074 (package-desc-signed pkg-desc))))
3075 (cond
3076 ((package-vc-p pkg-desc) "source")
3077 ((eq dir 'builtin) "built-in")
3078 ((and lle (null held)) "disabled")
3079 ((stringp held)
3080 (let ((hv (if (stringp held) (version-to-list held))))
3081 (cond
3082 ((version-list-= version hv) "held")
3083 ((version-list-< version hv) "obsolete")
3084 (t "disabled"))))
3085 (dir ;One of the installed packages.
3086 (cond
3087 ((not (file-exists-p dir)) "deleted")
3088 ;; Not inside `package-user-dir'.
3089 ((not (file-in-directory-p dir package-user-dir)) "external")
3090 ((eq pkg-desc (cadr (assq name package-alist)))
3091 (if (not signed) "unsigned"
3092 (if (package--user-selected-p name)
3093 "installed" "dependency")))
3094 (t "obsolete")))
3095 ((package--incompatible-p pkg-desc) "incompat")
3096 (t
3097 (let* ((ins (cadr (assq name package-alist)))
3098 (ins-v (if ins (package-desc-version ins))))
3099 (cond
3100 ;; Installed obsolete packages are handled in the `dir'
3101 ;; clause above. Here we handle available obsolete, which
3102 ;; are displayed depending on `package-menu--hide-packages'.
3103 ((and ins (version-list-<= version ins-v)) "avail-obso")
3104 (t
3105 (if (memq name package-menu--new-package-list)
3106 "new" "available"))))))))
3107
3108(defvar package-menu--hide-packages t
3109 "Whether available obsolete packages should be hidden.
3110Can be toggled with \\<package-menu-mode-map> \\[package-menu-toggle-hiding].
3111Installed obsolete packages are always displayed.")
3112
3113(defun package-menu-toggle-hiding ()
3114 "In Package Menu, toggle visibility of obsolete available packages.
3115
3116Also hide packages whose name matches a regexp in user option
3117`package-hidden-regexps' (a list). To add regexps to this list,
3118use `package-menu-hide-package'."
3119 (interactive nil package-menu-mode)
3120 (package--ensure-package-menu-mode)
3121 (setq package-menu--hide-packages
3122 (not package-menu--hide-packages))
3123 (if package-menu--hide-packages
3124 (message "Hiding obsolete or unwanted packages")
3125 (message "Displaying all packages"))
3126 (revert-buffer nil 'no-confirm))
3127
3128(defun package--remove-hidden (pkg-list)
3129 "Filter PKG-LIST according to `package-archive-priorities'.
3130PKG-LIST must be a list of `package-desc' objects, all with the
3131same name, sorted by decreasing `package-desc-priority-version'.
3132Return a list of packages tied for the highest priority according
3133to their archives."
3134 (when pkg-list
3135 ;; Variable toggled with `package-menu-toggle-hiding'.
3136 (if (not package-menu--hide-packages)
3137 pkg-list
3138 (let ((installed (cadr (assq (package-desc-name (car pkg-list))
3139 package-alist))))
3140 (when installed
3141 (setq pkg-list
3142 (let ((ins-version (package-desc-version installed)))
3143 (cl-remove-if (lambda (p) (version-list-< (package-desc-version p)
3144 ins-version))
3145 pkg-list))))
3146 (let ((filtered-by-priority
3147 (cond
3148 ((not package-menu-hide-low-priority)
3149 pkg-list)
3150 ((eq package-menu-hide-low-priority 'archive)
3151 (let (max-priority out)
3152 (while pkg-list
3153 (let ((p (pop pkg-list)))
3154 (let ((priority (package-desc-priority p)))
3155 (if (and max-priority (< priority max-priority))
3156 (setq pkg-list nil)
3157 (push p out)
3158 (setq max-priority priority)))))
3159 (nreverse out)))
3160 (pkg-list
3161 (list (car pkg-list))))))
3162 (if (not installed)
3163 filtered-by-priority
3164 (let ((ins-version (package-desc-version installed)))
3165 (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p)
3166 ins-version)
3167 (package-vc-p installed)))
3168 filtered-by-priority))))))))
3169
3170(defcustom package-hidden-regexps nil
3171 "List of regexps matching the name of packages to hide.
3172If the name of a package matches any of these regexps it is
3173omitted from the package menu. To toggle this, type \\[package-menu-toggle-hiding].
3174
3175Values can be interactively added to this list by typing
3176\\[package-menu-hide-package] on a package."
3177 :version "25.1"
3178 :type '(repeat (regexp :tag "Hide packages with name matching")))
3179
3180(defcustom package-menu-use-current-if-no-marks t
3181 "Whether \\<package-menu-mode-map>\\[package-menu-execute] in package menu operates on current package if none are marked.
3182
3183If non-nil, and no packages are marked for installation or
3184deletion, \\<package-menu-mode-map>\\[package-menu-execute] will operate on the current package at point,
3185see `package-menu-execute' for details.
3186The default is t. Set to nil to get back the original behavior
3187of having `package-menu-execute' signal an error when no packages
3188are marked for installation or deletion."
3189 :version "29.1"
3190 :type 'boolean)
3191
3192(defun package-menu--refresh (&optional packages keywords)
3193 "Re-populate the `tabulated-list-entries'.
3194PACKAGES should be nil or t, which means to display all known packages.
3195KEYWORDS should be nil or a list of keywords."
3196 ;; Construct list of (PKG-DESC . STATUS).
3197 (unless packages (setq packages t))
3198 (let ((hidden-names (mapconcat #'identity package-hidden-regexps "\\|"))
3199 info-list)
3200 ;; Installed packages:
3201 (dolist (elt package-alist)
3202 (let ((name (car elt)))
3203 (when (or (eq packages t) (memq name packages))
3204 (dolist (pkg (cdr elt))
3205 (when (package--has-keyword-p pkg keywords)
3206 (push pkg info-list))))))
3207
3208 ;; Built-in packages:
3209 (dolist (elt package--builtins)
3210 (let ((pkg (package--from-builtin elt))
3211 (name (car elt)))
3212 (when (not (eq name 'emacs)) ; Hide the `emacs' package.
3213 (when (and (package--has-keyword-p pkg keywords)
3214 (or package-list-unversioned
3215 (package--bi-desc-version (cdr elt)))
3216 (or (eq packages t) (memq name packages)))
3217 (push pkg info-list)))))
3218
3219 ;; Available and disabled packages:
3220 (unless (equal package--old-archive-priorities package-archive-priorities)
3221 (package-read-all-archive-contents))
3222 (dolist (elt package-archive-contents)
3223 (let ((name (car elt)))
3224 ;; To be displayed it must be in PACKAGES;
3225 (when (and (or (eq packages t) (memq name packages))
3226 ;; and we must either not be hiding anything,
3227 (or (not package-menu--hide-packages)
3228 (not package-hidden-regexps)
3229 ;; or just not hiding this specific package.
3230 (not (string-match hidden-names (symbol-name name)))))
3231 ;; Hide available-obsolete or low-priority packages.
3232 (dolist (pkg (package--remove-hidden (cdr elt)))
3233 (when (package--has-keyword-p pkg keywords)
3234 (push pkg info-list))))))
3235
3236 ;; Print the result.
3237 (tabulated-list-init-header)
3238 (setq tabulated-list-entries
3239 (mapcar #'package-menu--print-info-simple info-list))))
3240
3241(defun package-all-keywords ()
3242 "Collect all package keywords."
3243 (let ((key-list))
3244 (package--mapc (lambda (desc)
3245 (setq key-list (append (package-desc--keywords desc)
3246 key-list))))
3247 key-list))
3248
3249(defun package--mapc (function &optional packages)
3250 "Call FUNCTION for all known PACKAGES.
3251PACKAGES can be nil or t, which means to display all known
3252packages, or a list of packages.
3253
3254Built-in packages are converted with `package--from-builtin'."
3255 (unless packages (setq packages t))
3256 (let (name)
3257 ;; Installed packages:
3258 (dolist (elt package-alist)
3259 (setq name (car elt))
3260 (when (or (eq packages t) (memq name packages))
3261 (mapc function (cdr elt))))
3262
3263 ;; Built-in packages:
3264 (dolist (elt package--builtins)
3265 (setq name (car elt))
3266 (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
3267 (or package-list-unversioned
3268 (package--bi-desc-version (cdr elt)))
3269 (or (eq packages t) (memq name packages)))
3270 (funcall function (package--from-builtin elt))))
3271
3272 ;; Available and disabled packages:
3273 (dolist (elt package-archive-contents)
3274 (setq name (car elt))
3275 (when (or (eq packages t) (memq name packages))
3276 (dolist (pkg (cdr elt))
3277 ;; Hide obsolete packages.
3278 (unless (package-installed-p (package-desc-name pkg)
3279 (package-desc-version pkg))
3280 (funcall function pkg)))))))
3281
3282(defun package--has-keyword-p (desc &optional keywords)
3283 "Test if package DESC has any of the given KEYWORDS.
3284When none are given, the package matches."
3285 (if keywords
3286 (let ((desc-keywords (and desc (package-desc--keywords desc)))
3287 found)
3288 (while (and (not found) keywords)
3289 (let ((k (pop keywords)))
3290 (setq found
3291 (or (string= k (concat "arc:" (package-desc-archive desc)))
3292 (string= k (concat "status:" (package-desc-status desc)))
3293 (member k desc-keywords)))))
3294 found)
3295 t))
3296
3297(defun package-menu--display (remember-pos suffix)
3298 "Display the Package Menu.
3299If REMEMBER-POS is non-nil, keep point on the same entry.
3300
3301If SUFFIX is non-nil, append that to \"Package\" for the first
3302column in the header line."
3303 (setf (car (aref tabulated-list-format 0))
3304 (if suffix
3305 (concat "Package[" suffix "]")
3306 "Package"))
3307 (tabulated-list-init-header)
3308 (tabulated-list-print remember-pos))
3309
3310(defun package-menu--generate (remember-pos &optional packages keywords)
3311 "Populate and display the Package Menu.
3312If REMEMBER-POS is non-nil, keep point on the same entry.
3313PACKAGES should be t, which means to display all known packages,
3314or a list of package names (symbols) to display.
3315
3316With KEYWORDS given, only packages with those keywords are
3317shown."
3318 (package-menu--refresh packages keywords)
3319 (package-menu--display remember-pos
3320 (when keywords
3321 (let ((filters (mapconcat #'identity keywords ",")))
3322 (concat "Package[" filters "]")))))
3323
3324(defun package-menu--print-info (pkg)
3325 "Return a package entry suitable for `tabulated-list-entries'.
3326PKG has the form (PKG-DESC . STATUS).
3327Return (PKG-DESC [NAME VERSION STATUS DOC])."
3328 (package-menu--print-info-simple (car pkg)))
3329(make-obsolete 'package-menu--print-info
3330 'package-menu--print-info-simple "25.1")
3331
3332
3333;;; Package menu faces
3334
3335(defface package-name
3336 '((t :inherit link))
3337 "Face used on package names in the package menu."
3338 :version "25.1")
3339
3340(defface package-description
3341 '((t :inherit default))
3342 "Face used on package description summaries in the package menu."
3343 :version "25.1")
3344
3345;; Shame this hyphenates "built-in", when "font-lock-builtin-face" doesn't.
3346(defface package-status-built-in
3347 '((t :inherit font-lock-builtin-face))
3348 "Face used on the status and version of built-in packages."
3349 :version "25.1")
3350
3351(defface package-status-external
3352 '((t :inherit package-status-built-in))
3353 "Face used on the status and version of external packages."
3354 :version "25.1")
3355
3356(defface package-status-available
3357 '((t :inherit default))
3358 "Face used on the status and version of available packages."
3359 :version "25.1")
3360
3361(defface package-status-new
3362 '((t :inherit (bold package-status-available)))
3363 "Face used on the status and version of new packages."
3364 :version "25.1")
3365
3366(defface package-status-held
3367 '((t :inherit font-lock-constant-face))
3368 "Face used on the status and version of held packages."
3369 :version "25.1")
3370
3371(defface package-status-disabled
3372 '((t :inherit font-lock-warning-face))
3373 "Face used on the status and version of disabled packages."
3374 :version "25.1")
3375
3376(defface package-status-installed
3377 '((t :inherit font-lock-comment-face))
3378 "Face used on the status and version of installed packages."
3379 :version "25.1")
3380
3381(defface package-status-from-source
3382 '((t :inherit font-lock-negation-char-face))
3383 "Face used on the status and version of installed packages."
3384 :version "29.1")
3385
3386(defface package-status-dependency
3387 '((t :inherit package-status-installed))
3388 "Face used on the status and version of dependency packages."
3389 :version "25.1")
3390
3391(defface package-status-unsigned
3392 '((t :inherit font-lock-warning-face))
3393 "Face used on the status and version of unsigned packages."
3394 :version "25.1")
3395
3396(defface package-status-incompat
3397 '((t :inherit error))
3398 "Face used on the status and version of incompat packages."
3399 :version "25.1")
3400
3401(defface package-status-avail-obso
3402 '((t :inherit package-status-incompat))
3403 "Face used on the status and version of avail-obso packages."
3404 :version "25.1")
3405
3406(defface package-mark-install-line
3407 '((((class color) (background light))
3408 :background "darkolivegreen1" :extend t)
3409 (((class color) (background dark))
3410 :background "seagreen" :extend t)
3411 (t :inherit (highlight) :extend t))
3412 "Face used for highlighting in package-menu packages marked to be installed."
3413 :version "31.1")
3414
3415(defface package-mark-delete-line
3416 '((((class color) (background light))
3417 :background "rosybrown1" :extend t)
3418 (((class color) (background dark))
3419 :background "indianred4" :extend t)
3420 (t :inherit (highlight) :extend t))
3421 "Face used for highlighting in package-menu packages marked to be deleted."
3422 :version "31.1")
3423
3424(defface package-mode-line-total nil
3425 "Face for the total number of packages displayed on the mode line."
3426 :version "31.1")
3427
3428(defface package-mode-line-installed '((t :inherit package-status-installed))
3429 "Face for the number of installed packages displayed on the mode line."
3430 :version "31.1")
3431
3432(defface package-mode-line-to-upgrade '((t :inherit bold))
3433 "Face for the number of packages to upgrade displayed on the mode line."
3434 :version "31.1")
3435
3436(defface package-mode-line-new '((t :inherit package-status-new))
3437 "Face for the number of new packages displayed on the mode line."
3438 :version "31.1")
3439
3440
3441;;; Package menu printing
3442
3443(defun package-menu--print-info-simple (pkg)
3444 "Return a package entry suitable for `tabulated-list-entries'.
3445PKG is a `package-desc' object.
3446Return (PKG-DESC [NAME VERSION STATUS DOC])."
3447 (let* ((status (package-desc-status pkg))
3448 (face (pcase status
3449 ("built-in" 'package-status-built-in)
3450 ("external" 'package-status-external)
3451 ("available" 'package-status-available)
3452 ("avail-obso" 'package-status-avail-obso)
3453 ("new" 'package-status-new)
3454 ("held" 'package-status-held)
3455 ("disabled" 'package-status-disabled)
3456 ("installed" 'package-status-installed)
3457 ("source" 'package-status-from-source)
3458 ("dependency" 'package-status-dependency)
3459 ("unsigned" 'package-status-unsigned)
3460 ("incompat" 'package-status-incompat)
3461 (_ 'font-lock-warning-face)))) ; obsolete.
3462 (list pkg
3463 `[(,(symbol-name (package-desc-name pkg))
3464 face package-name
3465 font-lock-face package-name
3466 follow-link t
3467 package-desc ,pkg
3468 action package-menu-describe-package)
3469 ,(propertize
3470 (if (package-vc-p pkg)
3471 (progn
3472 (require 'package-vc)
3473 (package-vc-commit pkg))
3474 (package-version-join
3475 (package-desc-version pkg)))
3476 'font-lock-face face)
3477 ,(propertize status 'font-lock-face face)
3478 ,(propertize (or (package-desc-archive pkg) "")
3479 'font-lock-face face)
3480 ,(propertize (package-desc-summary pkg)
3481 'font-lock-face 'package-description)])))
3482
3483(defvar package-menu--old-archive-contents nil
3484 "`package-archive-contents' before the latest refresh.")
3485
3486(defun package-menu--refresh-contents (&optional _arg _noconfirm)
3487 "In Package Menu, download the Emacs Lisp package archive.
3488Fetch the contents of each archive specified in
3489`package-archives', and then refresh the package menu.
3490
3491`package-menu-mode' sets `revert-buffer-function' to this
3492function. The args ARG and NOCONFIRM, passed from
3493`revert-buffer', are ignored."
3494 (package--ensure-package-menu-mode)
3495 (setq package-menu--old-archive-contents package-archive-contents)
3496 (setq package-menu--new-package-list nil)
3497 (package-refresh-contents package-menu-async))
3498(define-obsolete-function-alias 'package-menu-refresh 'revert-buffer "27.1")
3499
3500(defun package-menu--overlay-line (face)
3501 "Highlight whole line with face FACE."
3502 (let ((ov (make-overlay (line-beginning-position)
3503 (1+ (line-end-position)))))
3504 (overlay-put ov 'pkg-menu-ov t)
3505 (overlay-put ov 'evaporate t)
3506 (overlay-put ov 'face face)))
3507
3508(defun package-menu--remove-overlay ()
3509 "Remove all overlays done by `package-menu--overlay-line' in current line."
3510 (remove-overlays (line-beginning-position)
3511 (1+ (line-end-position))
3512 'pkg-menu-ov t))
3513
3514(defun package-menu-hide-package ()
3515 "Hide in Package Menu packages that match a regexp.
3516Prompt for the regexp to match against package names.
3517The default regexp will hide only the package whose name is at point.
3518
3519The regexp is added to the list in the user option
3520`package-hidden-regexps' and saved for future sessions.
3521
3522To unhide a package, type
3523`\\[customize-variable] RET package-hidden-regexps', and then modify
3524the regexp such that it no longer matches the package's name.
3525
3526Type \\[package-menu-toggle-hiding] to toggle package hiding."
3527 (declare (interactive-only "change `package-hidden-regexps' instead."))
3528 (interactive nil package-menu-mode)
3529 (package--ensure-package-menu-mode)
3530 (let* ((name (when (derived-mode-p 'package-menu-mode)
3531 (concat "\\`" (regexp-quote (symbol-name (package-desc-name
3532 (tabulated-list-get-id))))
3533 "\\'")))
3534 (re (read-string "Hide packages matching regexp: " name)))
3535 ;; Test if it is valid.
3536 (string-match re "")
3537 (push re package-hidden-regexps)
3538 (customize-save-variable 'package-hidden-regexps package-hidden-regexps)
3539 (package-menu--post-refresh)
3540 (let ((hidden
3541 (cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e))))
3542 package-archive-contents)))
3543 (message "Packages to hide: %d. Type `%s' to toggle or `%s' to customize"
3544 (length hidden)
3545 (substitute-command-keys "\\[package-menu-toggle-hiding]")
3546 (substitute-command-keys "\\[customize-variable] RET package-hidden-regexps")))))
3547
3548
3549(defun package-menu-describe-package (&optional button)
3550 "Describe the current package.
3551The current package is the package at point.
3552If optional arg BUTTON is non-nil, describe its associated
3553package(s); this is always nil in interactive invocations."
3554 (interactive nil package-menu-mode)
3555 (let ((pkg-desc (if button (button-get button 'package-desc)
3556 (tabulated-list-get-id))))
3557 (if pkg-desc
3558 (describe-package pkg-desc)
3559 (user-error "No package here"))))
3560
3561;; fixme numeric argument
3562(defun package-menu-mark-delete (&optional _num)
3563 "Mark the current package for deletion and move to the next line.
3564The current package is the package at point."
3565 (interactive "p" package-menu-mode)
3566 (package--ensure-package-menu-mode)
3567 (if (member (package-menu-get-status)
3568 '("installed" "source" "dependency" "obsolete" "unsigned"))
3569 (progn (package-menu--overlay-line 'package-mark-delete-line)
3570 (tabulated-list-put-tag "D" t))
3571 (forward-line)))
3572
3573(defun package-menu-mark-install (&optional _num)
3574 "Mark the current package for installation and move to the next line.
3575The current package is the package at point."
3576 (interactive "p" package-menu-mode)
3577 (package--ensure-package-menu-mode)
3578 (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency"))
3579 (progn (package-menu--overlay-line 'package-mark-install-line)
3580 (tabulated-list-put-tag "I" t))
3581 (forward-line)))
3582
3583(defun package-menu-mark-unmark (&optional _num)
3584 "Clear any marks on the current package and move to the next line.
3585The current package is the package at point."
3586 (interactive "p" package-menu-mode)
3587 (package--ensure-package-menu-mode)
3588 (package-menu--remove-overlay)
3589 (tabulated-list-put-tag " " t))
3590
3591(defun package-menu-backup-unmark ()
3592 "Back up one line and clear any marks on that line's package."
3593 (interactive nil package-menu-mode)
3594 (package--ensure-package-menu-mode)
3595 (forward-line -1)
3596 (package-menu--remove-overlay)
3597 (tabulated-list-put-tag " "))
3598
3599(defun package-menu-mark-obsolete-for-deletion ()
3600 "Mark all obsolete packages for deletion."
3601 (interactive nil package-menu-mode)
3602 (package--ensure-package-menu-mode)
3603 (save-excursion
3604 (goto-char (point-min))
3605 (while (not (eobp))
3606 (if (equal (package-menu-get-status) "obsolete")
3607 (progn (package-menu--overlay-line 'package-mark-delete-line)
3608 (tabulated-list-put-tag "D" t))
3609 (forward-line 1)))))
3610
3611(defvar package--quick-help-keys
3612 '((("mark for installation," . 9)
3613 ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1))
3614 ("next," "previous")
3615 ("Hide-package," "(-toggle-hidden")
3616 ("g-refresh-contents," "/-filter," "help")))
3617
3618(defun package--prettify-quick-help-key (desc)
3619 "Prettify DESC to be displayed as a help menu."
3620 (if (listp desc)
3621 (if (listp (cdr desc))
3622 (mapconcat #'package--prettify-quick-help-key desc " ")
3623 (let ((place (cdr desc))
3624 (out (copy-sequence (car desc))))
3625 (add-text-properties place (1+ place)
3626 '(face help-key-binding)
3627 out)
3628 out))
3629 (package--prettify-quick-help-key (cons desc 0))))
3630
3631(defun package-menu-quick-help ()
3632 "Show short help for key bindings in `package-menu-mode'.
3633You can view the full list of keys with \\[describe-mode]."
3634 (interactive nil package-menu-mode)
3635 (package--ensure-package-menu-mode)
3636 (message (mapconcat #'package--prettify-quick-help-key
3637 package--quick-help-keys "\n")))
3638
3639(defun package-menu-get-status ()
3640 "Return status description of package at point in Package Menu."
3641 (package--ensure-package-menu-mode)
3642 (let* ((id (tabulated-list-get-id))
3643 (entry (and id (assoc id tabulated-list-entries))))
3644 (if entry
3645 (aref (cadr entry) 2)
3646 "")))
3647
3648(defun package-archive-priority (archive)
3649 "Return the priority of ARCHIVE.
3650
3651The archive priorities are specified in
3652`package-archive-priorities'. If not given there, the priority
3653defaults to 0."
3654 (or (cdr (assoc archive package-archive-priorities))
3655 0))
3656
3657(defun package-desc-priority-version (pkg-desc)
3658 "Return the version PKG-DESC with the archive priority prepended.
3659
3660This allows for easy comparison of package versions from
3661different archives if archive priorities are meant to be taken in
3662consideration."
3663 (cons (package-desc-priority pkg-desc)
3664 (package-desc-version pkg-desc)))
3665
3666(defun package-menu--find-upgrades ()
3667 "In Package Menu, return an alist of packages that can be upgraded.
3668The alist has the same form as `package-alist', namely a list
3669of elements of the form (PKG . DESCS), but where DESCS is the `package-desc'
3670object corresponding to the newer version."
3671 (let (installed available upgrades)
3672 ;; Build list of installed/available packages in this buffer.
3673 (dolist (entry tabulated-list-entries)
3674 ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
3675 (let ((pkg-desc (car entry))
3676 (status (aref (cadr entry) 2)))
3677 (cond ((member status '("installed" "dependency" "unsigned" "external" "built-in"))
3678 (push pkg-desc installed))
3679 ((member status '("available" "new"))
3680 (setq available (package--append-to-alist pkg-desc available))))))
3681 ;; Loop through list of installed packages, finding upgrades.
3682 (dolist (pkg-desc installed)
3683 (let* ((name (package-desc-name pkg-desc))
3684 (avail-pkg (cadr (assq name available))))
3685 (and avail-pkg
3686 (version-list-< (package-desc-priority-version pkg-desc)
3687 (package-desc-priority-version avail-pkg))
3688 (or (not (package--active-built-in-p pkg-desc))
3689 package-install-upgrade-built-in)
3690 (push (cons name avail-pkg) upgrades))))
3691 upgrades))
3692
3693(defvar package-menu--mark-upgrades-pending nil
3694 "Whether mark-upgrades is waiting for a refresh to finish.")
3695
3696(defun package-menu--mark-upgrades-1 ()
3697 "Mark all upgradable packages in the Package Menu.
3698Implementation of `package-menu-mark-upgrades'."
3699 (setq package-menu--mark-upgrades-pending nil)
3700 (let ((upgrades (package-menu--find-upgrades)))
3701 (if (null upgrades)
3702 (message "No packages to upgrade")
3703 (widen)
3704 (save-excursion
3705 (goto-char (point-min))
3706 (while (not (eobp))
3707 (let* ((pkg-desc (tabulated-list-get-id))
3708 (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades))))
3709 (cond ((null upgrade)
3710 (forward-line 1))
3711 ((equal pkg-desc upgrade)
3712 (package-menu-mark-install))
3713 (t
3714 (package-menu-mark-delete))))))
3715 (message "Packages marked for upgrading: %d"
3716 (length upgrades)))))
3717
3718
3719(defun package-menu-mark-upgrades ()
3720 "Mark all upgradable packages in the Package Menu.
3721For each installed package for which a newer version is available,
3722place an (I)nstall flag on the available version and a (D)elete flag
3723on the installed version. A subsequent \\[package-menu-execute] command will upgrade
3724the marked packages.
3725
3726If there's an async refresh operation in progress, the flags will
3727be placed as part of `package-menu--post-refresh' instead of
3728immediately."
3729 (interactive nil package-menu-mode)
3730 (package--ensure-package-menu-mode)
3731 (if (not package--downloads-in-progress)
3732 (package-menu--mark-upgrades-1)
3733 (setq package-menu--mark-upgrades-pending t)
3734 (message "Waiting for refresh to finish...")))
3735
3736(defun package-menu--list-to-prompt (packages &optional include-dependencies)
3737 "Return a string listing PACKAGES that's usable in a prompt.
3738PACKAGES is a list of `package-desc' objects.
3739Formats the returned string to be usable in a minibuffer
3740prompt (see `package-menu--prompt-transaction-p').
3741
3742If INCLUDE-DEPENDENCIES, also include the number of uninstalled
3743dependencies."
3744 ;; The case where `package' is empty is handled in
3745 ;; `package-menu--prompt-transaction-p' below.
3746 (format "%d (%s)%s"
3747 (length packages)
3748 (mapconcat #'package-desc-full-name packages " ")
3749 (let ((deps
3750 (seq-remove
3751 #'package-installed-p
3752 (delete-dups
3753 (apply
3754 #'nconc
3755 (mapcar (lambda (package)
3756 (package--dependencies
3757 (package-desc-name package)))
3758 packages))))))
3759 (if (and include-dependencies deps)
3760 (if (length= deps 1)
3761 (format " plus 1 dependency")
3762 (format " plus %d dependencies" (length deps)))
3763 ""))))
3764
3765(defun package-menu--prompt-transaction-p (delete install upgrade)
3766 "Prompt the user about DELETE, INSTALL, and UPGRADE.
3767DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects.
3768Either may be nil, but not all."
3769 (y-or-n-p
3770 (concat
3771 (when delete
3772 (format "Packages to delete: %s. "
3773 (package-menu--list-to-prompt delete)))
3774 (when install
3775 (format "Packages to install: %s. "
3776 (package-menu--list-to-prompt install t)))
3777 (when upgrade
3778 (format "Packages to upgrade: %s. "
3779 (package-menu--list-to-prompt upgrade)))
3780 "Proceed? ")))
3781
3782
3783(defun package-menu--partition-transaction (install delete)
3784 "Return an alist describing an INSTALL DELETE transaction.
3785Alist contains three entries, upgrade, delete, and install, each
3786with a list of package names.
3787
3788The upgrade entry contains any `package-desc' objects in INSTALL
3789whose name coincides with an object in DELETE. The delete and
3790the install entries are the same as DELETE and INSTALL with such
3791objects removed."
3792 (let* ((upg (cl-intersection install delete :key #'package-desc-name))
3793 (ins (cl-set-difference install upg :key #'package-desc-name))
3794 (del (cl-set-difference delete upg :key #'package-desc-name)))
3795 `((delete . ,del) (install . ,ins) (upgrade . ,upg))))
3796
3797(defun package-menu--perform-transaction (install-list delete-list)
3798 "Install packages in INSTALL-LIST and delete DELETE-LIST.
3799Return nil if there were no errors; non-nil otherwise."
3800 (let ((errors nil))
3801 (if install-list
3802 (let ((status-format (format ":Installing %%d/%d"
3803 (length install-list)))
3804 (i 0)
3805 (package-menu--transaction-status))
3806 (dolist (pkg install-list)
3807 (setq package-menu--transaction-status
3808 (format status-format (incf i)))
3809 (force-mode-line-update)
3810 (redisplay 'force)
3811 ;; Don't mark as selected, `package-menu-execute' already
3812 ;; does that.
3813 (package-install pkg 'dont-select))))
3814 (let ((package-menu--transaction-status ":Deleting"))
3815 (force-mode-line-update)
3816 (redisplay 'force)
3817 (dolist (elt (package--sort-by-dependence delete-list))
3818 (condition-case-unless-debug err
3819 (let ((inhibit-message (or inhibit-message package-menu-async)))
3820 (package-delete elt nil 'nosave))
3821 (error
3822 (push (package-desc-full-name elt) errors)
3823 (message "Error trying to delete `%s': %s"
3824 (package-desc-full-name elt)
3825 (error-message-string err))))))
3826 errors))
3827
3828(defun package--update-selected-packages (add remove)
3829 "Update the `package-selected-packages' list according to ADD and REMOVE.
3830ADD and REMOVE must be disjoint lists of package names (or
3831`package-desc' objects) to be added and removed to the selected
3832packages list, respectively."
3833 (dolist (p add)
3834 (cl-pushnew (if (package-desc-p p) (package-desc-name p) p)
3835 package-selected-packages))
3836 (dolist (p remove)
3837 (setq package-selected-packages
3838 (remove (if (package-desc-p p) (package-desc-name p) p)
3839 package-selected-packages)))
3840 (when (or add remove)
3841 (package--save-selected-packages package-selected-packages)))
3842
3843(defun package-menu-execute (&optional noquery)
3844 "Perform Package Menu actions on marked packages.
3845Packages marked for installation are downloaded and installed,
3846packages marked for deletion are removed, and packages marked for
3847upgrading are downloaded and upgraded.
3848
3849If no packages are marked, the action taken depends on the state
3850of the current package, the one at point. If it's not already
3851installed, this command will install the package; if it's installed,
3852the command will delete the package.
3853
3854Optional argument NOQUERY non-nil means do not ask the user to
3855confirm the installations/deletions; this is always nil in interactive
3856invocations."
3857 (interactive nil package-menu-mode)
3858 (package--ensure-package-menu-mode)
3859 (let (install-list delete-list cmd pkg-desc)
3860 (save-excursion
3861 (goto-char (point-min))
3862 (while (not (eobp))
3863 (setq cmd (char-after))
3864 (unless (eq cmd ?\s)
3865 ;; This is the key PKG-DESC.
3866 (setq pkg-desc (tabulated-list-get-id))
3867 (cond ((eq cmd ?D)
3868 (push pkg-desc delete-list))
3869 ((eq cmd ?I)
3870 (push pkg-desc install-list))))
3871 (forward-line)))
3872 ;; Nothing marked.
3873 (unless (or delete-list install-list)
3874 ;; Not on a package line.
3875 (unless (and (tabulated-list-get-id)
3876 package-menu-use-current-if-no-marks)
3877 (user-error "No operations specified"))
3878 (let* ((id (tabulated-list-get-id))
3879 (status (package-menu-get-status)))
3880 (cond
3881 ((member status '("installed"))
3882 (push id delete-list))
3883 ((member status '("available" "avail-obso" "new" "dependency"))
3884 (push id install-list))
3885 (t (user-error "No default action available for status: %s"
3886 status)))))
3887 (let-alist (package-menu--partition-transaction install-list delete-list)
3888 (when (or noquery
3889 (package-menu--prompt-transaction-p .delete .install .upgrade))
3890 (let ((message-template
3891 (concat "[ "
3892 (when .delete
3893 (format "Delete %d " (length .delete)))
3894 (when .install
3895 (format "Install %d " (length .install)))
3896 (when .upgrade
3897 (format "Upgrade %d " (length .upgrade)))
3898 "]")))
3899 (message "Operation %s started" message-template)
3900 ;; Packages being upgraded are not marked as selected.
3901 (package--update-selected-packages .install .delete)
3902 (unless (package-menu--perform-transaction install-list delete-list)
3903 ;; If there weren't errors, output data.
3904 (if-let* ((removable (package--removable-packages)))
3905 (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them"
3906 (length removable)
3907 (substitute-command-keys "\\[package-autoremove]"))
3908 (message "Operation %s finished" message-template))))))))
3909
3910(defun package-menu--version-predicate (A B)
3911 "Predicate to sort \"*Packages*\" buffer by the version column.
3912This is used for `tabulated-list-format' in `package-menu-mode'."
3913 (let ((vA (or (ignore-error error (version-to-list (aref (cadr A) 1))) '(0)))
3914 (vB (or (ignore-error error (version-to-list (aref (cadr B) 1))) '(0))))
3915 (if (version-list-= vA vB)
3916 (package-menu--name-predicate A B)
3917 (version-list-< vA vB))))
3918
3919(defun package-menu--status-predicate (A B)
3920 "Predicate to sort \"*Packages*\" buffer by the status column.
3921This is used for `tabulated-list-format' in `package-menu-mode'."
3922 (let ((sA (aref (cadr A) 2))
3923 (sB (aref (cadr B) 2)))
3924 (cond ((string= sA sB)
3925 (package-menu--name-predicate A B))
3926 ((string= sA "new") t)
3927 ((string= sB "new") nil)
3928 ((string-prefix-p "avail" sA)
3929 (if (string-prefix-p "avail" sB)
3930 (package-menu--name-predicate A B)
3931 t))
3932 ((string-prefix-p "avail" sB) nil)
3933 ((string= sA "installed") t)
3934 ((string= sB "installed") nil)
3935 ((string= sA "dependency") t)
3936 ((string= sB "dependency") nil)
3937 ((string= sA "source") t)
3938 ((string= sB "source") nil)
3939 ((string= sA "unsigned") t)
3940 ((string= sB "unsigned") nil)
3941 ((string= sA "held") t)
3942 ((string= sB "held") nil)
3943 ((string= sA "external") t)
3944 ((string= sB "external") nil)
3945 ((string= sA "built-in") t)
3946 ((string= sB "built-in") nil)
3947 ((string= sA "obsolete") t)
3948 ((string= sB "obsolete") nil)
3949 ((string= sA "incompat") t)
3950 ((string= sB "incompat") nil)
3951 (t (string< sA sB)))))
3952
3953(defun package-menu--description-predicate (A B)
3954 "Predicate to sort \"*Packages*\" buffer by the description column.
3955This is used for `tabulated-list-format' in `package-menu-mode'."
3956 (let ((dA (aref (cadr A) (if (cdr package-archives) 4 3)))
3957 (dB (aref (cadr B) (if (cdr package-archives) 4 3))))
3958 (if (string= dA dB)
3959 (package-menu--name-predicate A B)
3960 (string< dA dB))))
3961
3962(defun package-menu--name-predicate (A B)
3963 "Predicate to sort \"*Packages*\" buffer by the name column.
3964This is used for `tabulated-list-format' in `package-menu-mode'."
3965 (string< (symbol-name (package-desc-name (car A)))
3966 (symbol-name (package-desc-name (car B)))))
3967
3968(defun package-menu--archive-predicate (A B)
3969 "Predicate to sort \"*Packages*\" buffer by the archive column.
3970This is used for `tabulated-list-format' in `package-menu-mode'."
3971 (let ((a (or (package-desc-archive (car A)) ""))
3972 (b (or (package-desc-archive (car B)) "")))
3973 (if (string= a b)
3974 (package-menu--name-predicate A B)
3975 (string< a b))))
3976
3977(defun package-menu--populate-new-package-list ()
3978 "Decide which packages are new in `package-archive-contents'.
3979Store this list in `package-menu--new-package-list'."
3980 ;; Find which packages are new.
3981 (when package-menu--old-archive-contents
3982 (dolist (elt package-archive-contents)
3983 (unless (assq (car elt) package-menu--old-archive-contents)
3984 (push (car elt) package-menu--new-package-list)))
3985 (setq package-menu--old-archive-contents nil)))
3986
3987(defun package-menu--find-and-notify-upgrades ()
3988 "Notify the user of upgradable packages."
3989 (when-let* ((upgrades (package-menu--find-upgrades)))
3990 (message "Packages that can be upgraded: %d; type `%s' to mark for upgrading."
3991 (length upgrades)
3992 (substitute-command-keys "\\[package-menu-mark-upgrades]"))))
3993
3994
3995(defun package-menu--post-refresh ()
3996 "Revert \"*Packages*\" buffer and check for new packages and upgrades.
3997Do nothing if there's no *Packages* buffer.
3998
3999This function is called after `package-refresh-contents' and it
4000is added to `post-command-hook' by any function which alters the
4001package database (`package-install' and `package-delete'). When
4002run, it removes itself from `post-command-hook'."
4003 (remove-hook 'post-command-hook #'package-menu--post-refresh)
4004 (let ((buf (get-buffer "*Packages*")))
4005 (when (buffer-live-p buf)
4006 (with-current-buffer buf
4007 (package-menu--populate-new-package-list)
4008 (run-hooks 'tabulated-list-revert-hook)
4009 (tabulated-list-print 'remember 'update)))))
4010
4011(defun package-menu--mark-or-notify-upgrades ()
4012 "If there's a *Packages* buffer, check for upgrades and possibly mark them.
4013Do nothing if there's no *Packages* buffer. If there are
4014upgrades, mark them if `package-menu--mark-upgrades-pending' is
4015non-nil, otherwise just notify the user that there are upgrades.
4016This function is called after `package-refresh-contents'."
4017 (let ((buf (get-buffer "*Packages*")))
4018 (when (buffer-live-p buf)
4019 (with-current-buffer buf
4020 (if package-menu--mark-upgrades-pending
4021 (package-menu--mark-upgrades-1)
4022 (package-menu--find-and-notify-upgrades))))))
4023
4024;;;###autoload
4025(defun list-packages (&optional no-fetch)
4026 "Display a list of packages.
4027This first fetches the updated list of packages before
4028displaying, unless a prefix argument NO-FETCH is specified.
4029The list is displayed in a buffer named `*Packages*', and
4030includes the package's version, availability status, and a
4031short description."
4032 (interactive "P")
4033 (require 'finder-inf nil t)
4034 ;; Initialize the package system if necessary.
4035 (unless package--initialized
4036 (package-initialize t))
4037 ;; Integrate the package-menu with updating the archives.
4038 (add-hook 'package--post-download-archives-hook
4039 #'package-menu--post-refresh)
4040 (add-hook 'package--post-download-archives-hook
4041 #'package-menu--mark-or-notify-upgrades 'append)
4042 (add-hook 'package--post-download-archives-hook
4043 #'package-menu--set-mode-line-format 'append)
4044
4045 ;; Generate the Package Menu.
4046 (let ((buf (get-buffer-create "*Packages*")))
4047 (with-current-buffer buf
4048 ;; Since some packages have their descriptions include non-ASCII
4049 ;; characters...
4050 (setq buffer-file-coding-system 'utf-8)
4051 (package-menu-mode)
4052
4053 ;; Fetch the remote list of packages.
4054 (unless no-fetch (package-menu--refresh-contents))
4055
4056 ;; If we're not async, this would be redundant.
4057 (when package-menu-async
4058 (package-menu--generate nil t)))
4059 ;; The package menu buffer has keybindings. If the user types
4060 ;; `M-x list-packages', that suggests it should become current.
4061 (pop-to-buffer-same-window buf)))
4062
4063;;;###autoload
4064(defalias 'package-list-packages 'list-packages)
4065
4066;; Used in finder.el
4067(defun package-show-package-list (&optional packages keywords)
4068 "Display PACKAGES in a *Packages* buffer.
4069This is similar to `list-packages', but it does not fetch the
4070updated list of packages, and it only displays packages with
4071names in PACKAGES (which should be a list of symbols).
4072
4073When KEYWORDS are given, only packages with those KEYWORDS are
4074shown."
4075 (interactive)
4076 (require 'finder-inf nil t)
4077 (let* ((buf (get-buffer-create "*Packages*"))
4078 (win (get-buffer-window buf)))
4079 (with-current-buffer buf
4080 (package-menu-mode)
4081 (package-menu--generate nil packages keywords))
4082 (if win
4083 (select-window win)
4084 (switch-to-buffer buf))))
4085
4086(defun package-menu--filter-by (predicate suffix)
4087 "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header.
4088PREDICATE is a function which will be called with one argument, a
4089`package-desc' object, and returns t if that object should be
4090listed in the Package Menu.
4091
4092SUFFIX is passed on to `package-menu--display' and is added to
4093the header line of the first column."
4094 ;; Update `tabulated-list-entries' so that it contains all
4095 ;; packages before searching.
4096 (package-menu--refresh t nil)
4097 (let (found-entries)
4098 (dolist (entry tabulated-list-entries)
4099 (when (funcall predicate (car entry))
4100 (push entry found-entries)))
4101 (if found-entries
4102 (progn
4103 (setq tabulated-list-entries found-entries)
4104 (package-menu--display t suffix))
4105 (user-error "No packages found"))))
4106
4107(defun package-menu-filter-by-archive (archive)
4108 "Filter the \"*Packages*\" buffer by ARCHIVE.
4109Display only packages from package archive ARCHIVE.
4110ARCHIVE can be the name of a single archive (a string), or
4111a list of archive names. If ARCHIVE is nil or an empty
4112string, show all packages.
4113
4114When called interactively, prompt for ARCHIVE. To specify
4115several archives, type their names separated by commas."
4116 (interactive (list (completing-read-multiple
4117 "Filter by archive: "
4118 (mapcar #'car package-archives)))
4119 package-menu-mode)
4120 (package--ensure-package-menu-mode)
4121 (let ((archives (ensure-list archive)))
4122 (package-menu--filter-by
4123 (lambda (pkg-desc)
4124 (let ((pkg-archive (package-desc-archive pkg-desc)))
4125 (or (null archives)
4126 (and pkg-archive
4127 (member pkg-archive archives)))))
4128 (concat "archive:" (string-join archives ",")))))
4129
4130(defun package-menu-filter-by-description (description)
4131 "Filter the \"*Packages*\" buffer by the regexp DESCRIPTION.
4132Display only packages whose description matches the regexp
4133given as DESCRIPTION.
4134
4135When called interactively, prompt for DESCRIPTION.
4136
4137If DESCRIPTION is nil or the empty string, show all packages."
4138 (interactive (list (read-regexp "Filter by description (regexp)"))
4139 package-menu-mode)
4140 (package--ensure-package-menu-mode)
4141 (if (or (not description) (string-empty-p description))
4142 (package-menu--generate t t)
4143 (package-menu--filter-by (lambda (pkg-desc)
4144 (string-match description
4145 (package-desc-summary pkg-desc)))
4146 (format "desc:%s" description))))
4147
4148(defun package-menu-filter-by-keyword (keyword)
4149 "Filter the \"*Packages*\" buffer by KEYWORD.
4150Display only packages whose keywords match the specified KEYWORD.
4151KEYWORD can be a string or a list of strings. If KEYWORD is nil
4152or the empty string, show all packages.
4153
4154In addition to package keywords, KEYWORD can include the name(s)
4155of archive(s) and the package status, such as \"available\"
4156or \"built-in\" or \"obsolete\".
4157
4158When called interactively, prompt for KEYWORD. To specify several
4159keywords, type them separated by commas."
4160 (interactive (list (completing-read-multiple
4161 "Keywords: "
4162 (package-all-keywords)))
4163 package-menu-mode)
4164 (package--ensure-package-menu-mode)
4165 (when (stringp keyword)
4166 (setq keyword (list keyword)))
4167 (if (not keyword)
4168 (package-menu--generate t t)
4169 (package-menu--filter-by (lambda (pkg-desc)
4170 (package--has-keyword-p pkg-desc keyword))
4171 (concat "keyword:" (string-join keyword ",")))))
4172
4173(define-obsolete-function-alias
4174 'package-menu-filter #'package-menu-filter-by-keyword "27.1")
4175
4176(defun package-menu-filter-by-name-or-description (name-or-description)
4177 "Filter the \"*Packages*\" buffer by the regexp NAME-OR-DESCRIPTION.
4178Display only packages whose name or description matches the regexp
4179NAME-OR-DESCRIPTION.
4180
4181When called interactively, prompt for NAME-OR-DESCRIPTION.
4182
4183If NAME-OR-DESCRIPTION is nil or the empty string, show all
4184packages."
4185 (interactive (list (read-regexp "Filter by name or description (regexp)"))
4186 package-menu-mode)
4187 (package--ensure-package-menu-mode)
4188 (if (or (not name-or-description) (string-empty-p name-or-description))
4189 (package-menu--generate t t)
4190 (package-menu--filter-by (lambda (pkg-desc)
4191 (or (string-match name-or-description
4192 (package-desc-summary pkg-desc))
4193 (string-match name-or-description
4194 (symbol-name
4195 (package-desc-name pkg-desc)))))
4196 (format "name-or-desc:%s" name-or-description))))
4197
4198(defun package-menu-filter-by-name (name)
4199 "Filter the \"*Packages*\" buffer by the regexp NAME.
4200Display only packages whose name matches the regexp NAME.
4201
4202When called interactively, prompt for NAME.
4203
4204If NAME is nil or the empty string, show all packages."
4205 (interactive (list (read-regexp "Filter by name (regexp)"))
4206 package-menu-mode)
4207 (package--ensure-package-menu-mode)
4208 (if (or (not name) (string-empty-p name))
4209 (package-menu--generate t t)
4210 (package-menu--filter-by (lambda (pkg-desc)
4211 (string-match-p name (symbol-name
4212 (package-desc-name pkg-desc))))
4213 (format "name:%s" name))))
4214
4215(defun package-menu-filter-by-status (status)
4216 "Filter the \"*Packages*\" buffer by STATUS.
4217Display only packages with specified STATUS.
4218STATUS can be a single status, a string, or a list of strings.
4219If STATUS is nil or the empty string, show all packages.
4220
4221When called interactively, prompt for STATUS. To specify
4222several possible status values, type them separated by commas."
4223 (interactive (list (completing-read "Filter by status: "
4224 '("avail-obso"
4225 "available"
4226 "built-in"
4227 "dependency"
4228 "disabled"
4229 "external"
4230 "held"
4231 "incompat"
4232 "installed"
4233 "source"
4234 "new"
4235 "unsigned")))
4236 package-menu-mode)
4237 (package--ensure-package-menu-mode)
4238 (if (or (not status) (string-empty-p status))
4239 (package-menu--generate t t)
4240 (let ((status-list
4241 (if (listp status)
4242 status
4243 (split-string status ","))))
4244 (package-menu--filter-by
4245 (lambda (pkg-desc)
4246 (member (package-desc-status pkg-desc) status-list))
4247 (format "status:%s" (string-join status-list ","))))))
4248
4249(defun package-menu-filter-by-version (version predicate)
4250 "Filter the \"*Packages*\" buffer by VERSION and PREDICATE.
4251Display only packages whose version satisfies the condition
4252defined by VERSION and PREDICATE.
4253
4254When called interactively, prompt for one of the comparison operators
4255`<', `>' or `=', and for a version. Show only packages whose version
4256is lower (`<'), equal (`=') or higher (`>') than the specified VERSION.
4257
4258When called from Lisp, VERSION should be a version string and
4259PREDICATE should be the symbol `=', `<' or `>'.
4260
4261If VERSION is nil or the empty string, show all packages."
4262 (interactive (let ((choice (intern
4263 (char-to-string
4264 (read-char-choice
4265 "Filter by version? [Type =, <, > or q] "
4266 '(?< ?> ?= ?q))))))
4267 (if (eq choice 'q)
4268 '(quit nil)
4269 (list (read-from-minibuffer
4270 (concat "Filter by version ("
4271 (pcase choice
4272 ('= "= equal to")
4273 ('< "< less than")
4274 ('> "> greater than"))
4275 "): "))
4276 choice)))
4277 package-menu-mode)
4278 (package--ensure-package-menu-mode)
4279 (unless (equal predicate 'quit)
4280 (if (or (not version) (string-empty-p version))
4281 (package-menu--generate t t)
4282 (package-menu--filter-by
4283 (let ((fun (pcase predicate
4284 ('= #'version-list-=)
4285 ('< #'version-list-<)
4286 ('> (lambda (a b) (not (version-list-<= a b))))
4287 (_ (error "Unknown predicate: %s" predicate))))
4288 (ver (version-to-list version)))
4289 (lambda (pkg-desc)
4290 (funcall fun (package-desc-version pkg-desc) ver)))
4291 (format "versions:%s%s" predicate version)))))
4292
4293(defun package-menu-filter-marked ()
4294 "Filter \"*Packages*\" buffer by non-empty mark.
4295Show only the packages that have been marked for installation or deletion.
4296Unlike other filters, this leaves the marks intact."
4297 (interactive nil package-menu-mode)
4298 (package--ensure-package-menu-mode)
4299 (widen)
4300 (let (found-entries mark pkg-id entry marks)
4301 (save-excursion
4302 (goto-char (point-min))
4303 (while (not (eobp))
4304 (setq mark (char-after))
4305 (unless (eq mark ?\s)
4306 (setq pkg-id (tabulated-list-get-id))
4307 (setq entry (package-menu--print-info-simple pkg-id))
4308 (push entry found-entries)
4309 ;; remember the mark
4310 (push (cons pkg-id mark) marks))
4311 (forward-line))
4312 (if found-entries
4313 (progn
4314 (setq tabulated-list-entries found-entries)
4315 (package-menu--display t nil)
4316 ;; redo the marks, but we must remember the marks!!
4317 (goto-char (point-min))
4318 (while (not (eobp))
4319 (setq mark (cdr (assq (tabulated-list-get-id) marks)))
4320 (tabulated-list-put-tag (char-to-string mark) t)))
4321 (user-error "No packages found")))))
4322
4323(defun package-menu-filter-upgradable ()
4324 "Filter \"*Packages*\" buffer to show only upgradable packages."
4325 (interactive nil package-menu-mode)
4326 (let ((pkgs (mapcar #'car (package-menu--find-upgrades))))
4327 (package-menu--filter-by
4328 (lambda (pkg)
4329 (memql (package-desc-name pkg) pkgs))
4330 "upgradable")))
4331
4332(defun package-menu-clear-filter ()
4333 "Clear any filter currently applied to the \"*Packages*\" buffer."
4334 (interactive nil package-menu-mode)
4335 (package--ensure-package-menu-mode)
4336 (package-menu--generate t t))
4337
4338(defun package-list-packages-no-fetch ()
4339 "Display a list of packages.
4340Does not fetch the updated list of packages before displaying.
4341The list is displayed in a buffer named `*Packages*'."
4342 (interactive)
4343 (list-packages t))
4344
4345
4346;;;; Quickstart: precompute activation actions for faster start up.
4347
4348;; Activating packages via `package-initialize' is costly: for N installed
4349;; packages, it needs to read all N <pkg>-pkg.el files first to decide
4350;; which packages to activate, and then again N <pkg>-autoloads.el files.
4351;; To speed this up, we precompute a mega-autoloads file which is the
4352;; concatenation of all those <pkg>-autoloads.el, so we can activate
4353;; all packages by loading this one file (and hence without initializing
4354;; package.el).
4355
4356;; Other than speeding things up, this also offers a bootstrap feature:
4357;; it lets us activate packages according to `package-load-list' and
4358;; `package-user-dir' even before those vars are set.
4359
4360(defcustom package-quickstart nil
4361 "Precompute activation actions to speed up startup.
4362This requires the use of `package-quickstart-refresh' every time the
4363activations need to be changed, such as when `package-load-list' is modified."
4364 :type 'boolean
4365 :version "27.1")
4366
4367;;;###autoload
4368(defcustom package-quickstart-file
4369 (locate-user-emacs-file "package-quickstart.el")
4370 "Location of the file used to speed up activation of packages at startup."
4371 :type 'file
4372 :group 'applications
4373 :initialize #'custom-initialize-delay
4374 :version "27.1")
4375
4376(defun package--quickstart-maybe-refresh ()
4377 (if package-quickstart
4378 ;; FIXME: Delay refresh in case we're installing/deleting
4379 ;; several packages!
4380 (package-quickstart-refresh)
4381 (delete-file (concat package-quickstart-file "c"))
4382 (delete-file package-quickstart-file)))
4383
4384(defvar package--quickstart-dir nil
4385 "Set by `package-quickstart-file' to the directory containing it.")
4386
4387(defun package--quickstart-rel (file)
4388 "Return an expr depending on `package--quickstart-dir' which evaluates to FILE.
4389
4390If FILE is in `package--quickstart-dir', returns an expression that is
4391relative to that directory, so if that directory is moved we can still
4392find FILE."
4393 (if (file-in-directory-p file package--quickstart-dir)
4394 `(file-name-concat package--quickstart-dir ,(file-relative-name file package--quickstart-dir))
4395 file))
4396
4397(defun package-quickstart-refresh ()
4398 "(Re)Generate the `package-quickstart-file'."
4399 (interactive)
4400 (package-initialize 'no-activate)
4401 (require 'info)
4402 (let ((package--quickstart-pkgs ())
4403 ;; Pretend we haven't activated anything yet!
4404 (package-activated-list ())
4405 ;; Make sure we can load this file without load-source-file-function.
4406 (coding-system-for-write 'emacs-internal)
4407 ;; Ensure that `pp' and `prin1-to-string' calls further down
4408 ;; aren't truncated.
4409 (print-length nil)
4410 (print-level nil)
4411 (Info-directory-list '(""))
4412 (package--quickstart-dir nil))
4413 (dolist (elt package-alist)
4414 (condition-case err
4415 (package-activate (car elt))
4416 ;; Don't let failure of activation of a package arbitrarily stop
4417 ;; activation of further packages.
4418 (error (message "%s" (error-message-string err)))))
4419 (setq package--quickstart-pkgs (nreverse package--quickstart-pkgs))
4420 (with-temp-file package-quickstart-file
4421 (emacs-lisp-mode) ;For `syntax-ppss'.
4422 (insert ";;; Quickstart file to activate all packages at startup -*- lexical-binding:t -*-\n")
4423 (insert ";; ¡¡ This file is autogenerated by `package-quickstart-refresh', DO NOT EDIT !!\n\n")
4424 (setq package--quickstart-dir
4425 (file-name-directory (expand-file-name package-quickstart-file)))
4426 (pp '(setq package--quickstart-dir
4427 (file-name-directory (expand-file-name load-file-name)))
4428 (current-buffer))
4429 (dolist (pkg package--quickstart-pkgs)
4430 (let* ((file
4431 ;; Prefer uncompiled files (and don't accept .so files).
4432 (let ((load-suffixes '(".el" ".elc")))
4433 (locate-library (package--autoloads-file-name pkg))))
4434 (pfile (prin1-to-string (package--quickstart-rel file))))
4435 (insert "(let* ((load-file-name " pfile ")\
4436\(load-true-file-name load-file-name))\n")
4437 (insert-file-contents file)
4438 ;; Fixup the special #$ reader form and throw away comments.
4439 (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
4440 (unless (ppss-string-terminator (save-match-data (syntax-ppss)))
4441 (replace-match (if (match-end 1) "" pfile) t t)))
4442 (unless (bolp) (insert "\n"))
4443 (insert ")\n")))
4444 (pp `(defvar package-activated-list) (current-buffer))
4445 (pp `(setq package-activated-list
4446 (delete-dups
4447 (append ',(mapcar #'package-desc-name package--quickstart-pkgs)
4448 package-activated-list)))
4449 (current-buffer))
4450 (let ((info-dirs
4451 (mapcar #'package--quickstart-rel (butlast Info-directory-list))))
4452 (when info-dirs
4453 (pp `(progn (require 'info)
4454 (info-initialize)
4455 (setq Info-directory-list
4456 (append (list . ,info-dirs) Info-directory-list)))
4457 (current-buffer))))
4458 ;; Use `\s' instead of a space character, so this code chunk is not
4459 ;; mistaken for an actual file-local section of package.el.
4460 (insert "
4461;; Local\sVariables:
4462;; version-control: never
4463;; no-update-autoloads: t
4464;; byte-compile-warnings: (not make-local)
4465;; End:
4466"))
4467 ;; FIXME: Do it asynchronously in an Emacs subprocess, and
4468 ;; don't show the byte-compiler warnings.
4469 (byte-compile-file package-quickstart-file)))
4470
4471(defun package--imenu-prev-index-position-function ()
4472 "Move point to previous line in package-menu buffer.
4473This function is used as a value for
4474`imenu-prev-index-position-function'."
4475 (unless (bobp)
4476 (forward-line -1)))
4477
4478(defun package--imenu-extract-index-name-function ()
4479 "Return imenu name for line at point.
4480This function is used as a value for
4481`imenu-extract-index-name-function'. Point should be at the
4482beginning of the line."
4483 (let ((package-desc (tabulated-list-get-id)))
4484 (format "%s (%s): %s"
4485 (package-desc-name package-desc)
4486 (package-version-join (package-desc-version package-desc))
4487 (package-desc-summary package-desc))))
4488
4489(defun package--query-desc (&optional alist)
4490 "Query the user for a package or return the package at point.
4491The optional argument ALIST must consist of elements with the
4492form (PKG-NAME PKG-DESC). If not specified, it will default to
4493`package-alist'."
4494 (or (tabulated-list-get-id)
4495 (let ((alist (or alist package-alist)))
4496 (cadr (assoc (completing-read "Package: " alist nil t)
4497 alist #'string=)))))
4498
4499(defun package-browse-url (desc &optional secondary)
4500 "Open the website of the package under point in a browser.
4501`browse-url' is used to determine the browser to be used. If
4502SECONDARY (interactively, the prefix), use the secondary browser.
4503DESC must be a `package-desc' object."
4504 (interactive (list (package--query-desc)
4505 current-prefix-arg)
4506 package-menu-mode)
4507 (unless desc
4508 (user-error "No package here"))
4509 (let ((url (cdr (assoc :url (package-desc-extras desc)))))
4510 (unless url
4511 (user-error "No website for %s" (package-desc-name desc)))
4512 (if secondary
4513 (funcall browse-url-secondary-browser-function url)
4514 (browse-url url))))
4515
4516(declare-function ietf-drums-parse-address "ietf-drums"
4517 (string &optional decode))
4518
4519(defun package-maintainers (pkg-desc &optional no-error)
4520 "Return an email address for the maintainers of PKG-DESC.
4521The email address may contain commas, if there are multiple
4522maintainers. If no maintainers are found, an error will be
4523signaled. If the optional argument NO-ERROR is non-nil no error
4524will be signaled in that case."
4525 (unless (package-desc-p pkg-desc)
4526 (error "Invalid package description: %S" pkg-desc))
4527 (let* ((name (package-desc-name pkg-desc))
4528 (extras (package-desc-extras pkg-desc))
4529 (maint (alist-get :maintainer extras)))
4530 (unless (listp (cdr maint))
4531 (setq maint (list maint)))
4532 (cond
4533 ((and (null maint) (null no-error))
4534 (user-error "Package `%s' has no explicit maintainer" name))
4535 ((and (not (progn
4536 (require 'ietf-drums)
4537 (ietf-drums-parse-address (cdar maint))))
4538 (null no-error))
4539 (user-error "Package `%s' has no maintainer address" name))
4540 (t
4541 (with-temp-buffer
4542 (mapc #'package--print-email-button maint)
4543 (replace-regexp-in-string
4544 "\n" ", " (string-trim
4545 (buffer-substring-no-properties
4546 (point-min) (point-max)))))))))
4547
4548;;;###autoload
4549(defun package-report-bug (desc)
4550 "Prepare a message to send to the maintainers of a package.
4551DESC must be a `package-desc' object."
4552 (interactive (list (package--query-desc package-alist))
4553 package-menu-mode)
4554 (let ((maint (package-maintainers desc))
4555 (name (symbol-name (package-desc-name desc)))
4556 (pkgdir (package-desc-dir desc))
4557 vars)
4558 (when pkgdir
4559 (dolist-with-progress-reporter (group custom-current-group-alist)
4560 "Scanning for modified user options..."
4561 (when (and (car group)
4562 (file-in-directory-p (car group) pkgdir))
4563 (dolist (ent (get (cdr group) 'custom-group))
4564 (when (and (custom-variable-p (car ent))
4565 (boundp (car ent))
4566 (not (eq (custom--standard-value (car ent))
4567 (default-toplevel-value (car ent)))))
4568 (push (car ent) vars))))))
4569 (dlet ((reporter-prompt-for-summary-p t))
4570 (reporter-submit-bug-report maint name vars))))
4571
4572;;;; Introspection
4573
4574(defun package-get-descriptor (pkg-name)
4575 "Return the `package-desc' of PKG-NAME."
4576 (unless package--initialized (package-initialize 'no-activate))
4577 (or (package--get-activatable-pkg pkg-name)
4578 (cadr (assq pkg-name package-alist))
4579 (cadr (assq pkg-name package-archive-contents))))
4580
4581(provide 'package)
4582
4583;;; package.el ends here