aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPhilip Kaludercic2025-08-06 15:12:55 +0200
committerPhilip Kaludercic2025-08-07 15:55:01 +0200
commitbdd0220f6571906b0618924274ec12fbb876a09e (patch)
tree8c7a38e924ddb329f226a98eeec43dc331e8a67d
parent5c153cfb9620baf44dd388bb509c5aca82e377e9 (diff)
downloademacs-scratch/package.el-experiments.tar.gz
emacs-scratch/package.el-experiments.zip
Split package.el into multiple filesscratch/package.el-experiments
* lisp/emacs-lisp/package.el: Replace this file with... * lisp/emacs-lisp/package/package.el: a stub file and... * lisp/emacs-lisp/package/package-compile.el: file. * lisp/emacs-lisp/package/package-describe.el: * lisp/emacs-lisp/package/package-elpa.el: * lisp/emacs-lisp/package/package-install.el: * lisp/emacs-lisp/package/package-menu.el: * lisp/emacs-lisp/package/package-misc.el: * lisp/emacs-lisp/package/package-quickstart.el: Multiple files. * lisp/emacs-lisp/package-vc.el: Move this file... * lisp/emacs-lisp/package/package-vc.el: to here.
Diffstat
-rw-r--r--lisp/emacs-lisp/package.el4972
-rw-r--r--lisp/package/package-compile.el111
-rw-r--r--lisp/package/package-core.el927
-rw-r--r--lisp/package/package-describe.el419
-rw-r--r--lisp/package/package-elpa.el629
-rw-r--r--lisp/package/package-install.el1053
-rw-r--r--lisp/package/package-menu.el1580
-rw-r--r--lisp/package/package-misc.el129
-rw-r--r--lisp/package/package-quickstart.el151
-rw-r--r--lisp/package/package-vc.el (renamed from lisp/emacs-lisp/package-vc.el)27
-rw-r--r--lisp/package/package.el151
11 files changed, 5168 insertions, 4981 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
deleted file mode 100644
index fe6bebc67ff..00000000000
--- a/lisp/emacs-lisp/package.el
+++ /dev/null
@@ -1,4972 +0,0 @@
1;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
2
3;; Copyright (C) 2007-2025 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 'cl-lib)
147(eval-when-compile (require 'subr-x))
148(eval-when-compile (require 'epg)) ;For setf accessors.
149(eval-when-compile (require 'inline)) ;For `define-inline'
150(require 'seq)
151
152(require 'tabulated-list)
153(require 'macroexp)
154(require 'url-handlers)
155(require 'browse-url)
156
157(defgroup package nil
158 "Manager for Emacs Lisp packages."
159 :group 'applications
160 :version "24.1")
161
162
163;;; Customization options
164
165;;;###autoload
166(defcustom package-enable-at-startup t
167 "Whether to make installed packages available when Emacs starts.
168If non-nil, packages are made available before reading the init
169file (but after reading the early init file). This means that if
170you wish to set this variable, you must do so in the early init
171file. Regardless of the value of this variable, packages are not
172made available if `user-init-file' is nil (e.g. Emacs was started
173with \"-q\").
174
175Even if the value is nil, you can type \\[package-initialize] to
176make installed packages available at any time, or you can
177call (package-activate-all) in your init-file.
178
179Note that this variable must be set to a non-default value in
180your early-init file, as the variable's value is used before
181loading the regular init file. Therefore, if you customize it
182via Customize, you should save your customized setting into
183your `early-init-file'."
184 :type 'boolean
185 :version "24.1")
186
187(defcustom package-load-list '(all)
188 "List of packages for `package-activate-all' to make available.
189Each element in this list should be a list (NAME VERSION), or the
190symbol `all'. The symbol `all' says to make available the latest
191installed versions of all packages not specified by other
192elements.
193
194For an element (NAME VERSION), NAME is a package name (a symbol).
195VERSION should be t, a string, or nil.
196If VERSION is t, the most recent version is made available.
197If VERSION is a string, only that version is ever made available.
198 Any other version, even if newer, is silently ignored.
199 Hence, the package is \"held\" at that version.
200If VERSION is nil, the package is not made available (it is \"disabled\")."
201 :type '(repeat (choice (const all)
202 (list :tag "Specific package"
203 (symbol :tag "Package name")
204 (choice :tag "Version"
205 (const :tag "disable" nil)
206 (const :tag "most recent" t)
207 (string :tag "specific version")))))
208 :risky t
209 :version "24.1")
210
211(defcustom package-archives `(("gnu" .
212 ,(format "http%s://elpa.gnu.org/packages/"
213 (if (gnutls-available-p) "s" "")))
214 ("nongnu" .
215 ,(format "http%s://elpa.nongnu.org/nongnu/"
216 (if (gnutls-available-p) "s" ""))))
217 "An alist of archives from which to fetch.
218The default value points to the GNU Emacs package repository.
219
220Each element has the form (ID . LOCATION).
221 ID is an archive name, as a string.
222 LOCATION specifies the base location for the archive.
223 If it starts with \"http(s):\", it is treated as an HTTP(S) URL;
224 otherwise it should be an absolute directory name.
225 (Other types of URL are currently not supported.)
226
227Only add locations that you trust, since fetching and installing
228a package can run arbitrary code.
229
230HTTPS URLs should be used where possible, as they offer superior
231security."
232 :type '(alist :key-type (string :tag "Archive name")
233 :value-type (string :tag "URL or directory name"))
234 :risky t
235 :version "28.1")
236
237(defcustom package-menu-hide-low-priority 'archive
238 "If non-nil, hide low priority packages from the packages menu.
239A package is considered low priority if there's another version
240of it available such that:
241 (a) the archive of the other package is higher priority than
242 this one, as per `package-archive-priorities';
243 or
244 (b) they both have the same archive priority but the other
245 package has a higher version number.
246
247This variable has three possible values:
248 nil: no packages are hidden;
249 `archive': only criterion (a) is used;
250 t: both criteria are used.
251
252This variable has no effect if `package-menu--hide-packages' is
253nil, so it can be toggled with \\<package-menu-mode-map>\\[package-menu-toggle-hiding]."
254 :type '(choice (const :tag "Don't hide anything" nil)
255 (const :tag "Hide per package-archive-priorities"
256 archive)
257 (const :tag "Hide per archive and version number" t))
258 :version "25.1")
259
260(defcustom package-archive-priorities nil
261 "An alist of priorities for packages.
262
263Each element has the form (ARCHIVE-ID . PRIORITY).
264
265When installing packages, the package with the highest version
266number from the archive with the highest priority is
267selected. When higher versions are available from archives with
268lower priorities, the user has to select those manually.
269
270Archives not in this list have the priority 0, as have packages
271that are already installed. If you use negative priorities for
272the archives, they will not be upgraded automatically.
273
274See also `package-menu-hide-low-priority'."
275 :type '(alist :key-type (string :tag "Archive name")
276 :value-type (integer :tag "Priority (default is 0)"))
277 :risky t
278 :version "25.1")
279
280(defcustom package-pinned-packages nil
281 "An alist of packages that are pinned to specific archives.
282This can be useful if you have multiple package archives enabled,
283and want to control which archive a given package gets installed from.
284
285Each element of the alist has the form (PACKAGE . ARCHIVE), where:
286 PACKAGE is a symbol representing a package
287 ARCHIVE is a string representing an archive (it should be the car of
288an element in `package-archives', e.g. \"gnu\").
289
290Adding an entry to this variable means that only ARCHIVE will be
291considered as a source for PACKAGE. If other archives provide PACKAGE,
292they are ignored (for this package). If ARCHIVE does not contain PACKAGE,
293the package will be unavailable."
294 :type '(alist :key-type (symbol :tag "Package")
295 :value-type (string :tag "Archive name"))
296 ;; This could prevent you from receiving updates for a package,
297 ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue
298 ;; if PACKAGE has a known vulnerability that is fixed in newer versions.
299 :risky t
300 :version "24.4")
301
302;;;###autoload
303(defcustom package-user-dir (locate-user-emacs-file "elpa")
304 "Directory containing the user's Emacs Lisp packages.
305The directory name should be absolute.
306Apart from this directory, Emacs also looks for system-wide
307packages in `package-directory-list'."
308 :type 'directory
309 :initialize #'custom-initialize-delay
310 :risky t
311 :group 'applications
312 :version "24.1")
313
314;;;###autoload
315(defcustom package-directory-list
316 ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
317 (let (result)
318 (dolist (f load-path)
319 (and (stringp f)
320 (equal (file-name-nondirectory f) "site-lisp")
321 (push (expand-file-name "elpa" f) result)))
322 (nreverse result))
323 "List of additional directories containing Emacs Lisp packages.
324Each directory name should be absolute.
325
326These directories contain packages intended for system-wide; in
327contrast, `package-user-dir' contains packages for personal use."
328 :type '(repeat directory)
329 :initialize #'custom-initialize-delay
330 :group 'applications
331 :risky t
332 :version "24.1")
333
334(declare-function epg-find-configuration "epg-config"
335 (protocol &optional no-cache program-alist))
336
337(defcustom package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)
338 "Directory containing GnuPG keyring or nil.
339This variable specifies the GnuPG home directory used by package.
340That directory is passed via the option \"--homedir\" to GnuPG.
341If nil, do not use the option \"--homedir\", but stick with GnuPG's
342default directory."
343 :type `(choice
344 (const
345 :tag "Default Emacs package management GnuPG home directory"
346 ,(expand-file-name "gnupg" package-user-dir))
347 (const
348 :tag "Default GnuPG directory (GnuPG option --homedir not used)"
349 nil)
350 (directory :tag "A specific GnuPG --homedir"))
351 :risky t
352 :version "26.1")
353
354(defcustom package-check-signature 'allow-unsigned
355 "Non-nil means to check package signatures when installing.
356
357This also applies to the \"archive-contents\" file that lists the
358contents of the archive.
359
360The value can be one of:
361
362 t Accept a package only if it comes with at least
363 one verified signature.
364
365 `all' Same as t, but verify all signatures if there
366 are more than one.
367
368 `allow-unsigned' Install a package even if it is unsigned,
369 but verify the signature if possible (that
370 is, if it is signed, we have the key for it,
371 and GnuPG is installed).
372
373 nil Package signatures are ignored."
374 :type '(choice (const :value nil :tag "Never")
375 (const :value allow-unsigned :tag "Allow unsigned")
376 (const :value t :tag "Check always")
377 (const :value all :tag "Check always (all signatures)"))
378 :risky t
379 :version "27.1")
380
381(defun package-check-signature ()
382 "Check whether we have a usable OpenPGP configuration.
383If so, and variable `package-check-signature' is
384`allow-unsigned', return `allow-unsigned', otherwise return the
385value of variable `package-check-signature'."
386 (if (eq package-check-signature 'allow-unsigned)
387 (and (epg-find-configuration 'OpenPGP)
388 'allow-unsigned)
389 package-check-signature))
390
391(defcustom package-unsigned-archives nil
392 "List of archives where we do not check for package signatures.
393This should be a list of strings matching the names of package
394archives in the variable `package-archives'."
395 :type '(repeat (string :tag "Archive name"))
396 :risky t
397 :version "24.4")
398
399(defcustom package-selected-packages nil
400 "Store here packages installed explicitly by user.
401This variable is fed automatically by Emacs when installing a new package.
402This variable is used by `package-autoremove' to decide
403which packages are no longer needed.
404You can use it to (re)install packages on other machines
405by running `package-install-selected-packages'.
406
407To check if a package is contained in this list here, use
408`package--user-selected-p', as it may populate the variable with
409a sane initial value."
410 :version "25.1"
411 :type '(repeat symbol))
412
413(defcustom package-native-compile nil
414 "Non-nil means to natively compile packages as part of their installation.
415This controls ahead-of-time compilation of packages when they are
416installed. If this option is nil, packages will be natively
417compiled when they are loaded for the first time.
418
419This option does not have any effect if Emacs was not built with
420native compilation support."
421 :type '(boolean)
422 :risky t
423 :version "28.1")
424
425(defcustom package-menu-async t
426 "If non-nil, package-menu will use async operations when possible.
427Currently, only the refreshing of archive contents supports
428asynchronous operations. Package transactions are still done
429synchronously."
430 :type 'boolean
431 :version "25.1")
432
433(defcustom package-name-column-width 30
434 "Column width for the Package name in the package menu."
435 :type 'natnum
436 :version "28.1")
437
438(defcustom package-version-column-width 14
439 "Column width for the Package version in the package menu."
440 :type 'natnum
441 :version "28.1")
442
443(defcustom package-status-column-width 12
444 "Column width for the Package status in the package menu."
445 :type 'natnum
446 :version "28.1")
447
448(defcustom package-archive-column-width 8
449 "Column width for the Package archive in the package menu."
450 :type 'natnum
451 :version "28.1")
452
453
454;;; `package-desc' object definition
455;; This is the struct used internally to represent packages.
456;; Functions that deal with packages should generally take this object
457;; as an argument. In some situations (e.g. commands that query the
458;; user) it makes sense to take the package name as a symbol instead,
459;; but keep in mind there could be multiple `package-desc's with the
460;; same name.
461
462(defvar package--default-summary "No description available.")
463
464(define-inline package-vc-p (pkg-desc)
465 "Return non-nil if PKG-DESC is a VC package."
466 (inline-letevals (pkg-desc)
467 (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc))))
468
469(cl-defstruct (package-desc
470 ;; Rename the default constructor from `make-package-desc'.
471 (:constructor package-desc-create)
472 ;; Has the same interface as the old `define-package',
473 ;; which is still used in the "foo-pkg.el" files. Extra
474 ;; options can be supported by adding additional keys.
475 (:constructor
476 package-desc-from-define
477 (name-string version-string &optional summary requirements
478 &rest rest-plist
479 &aux
480 (name (intern name-string))
481 (version (if (eq (car-safe version-string) 'vc)
482 (version-to-list (cdr version-string))
483 (version-to-list version-string)))
484 (reqs (mapcar (lambda (elt)
485 (list (car elt)
486 (version-to-list (cadr elt))))
487 (if (eq 'quote (car requirements))
488 (nth 1 requirements)
489 requirements)))
490 (kind (plist-get rest-plist :kind))
491 (archive (plist-get rest-plist :archive))
492 (extras (let (alist)
493 (while rest-plist
494 (unless (memq (car rest-plist) '(:kind :archive))
495 (let ((value (cadr rest-plist)))
496 (when value
497 (push (cons (car rest-plist)
498 (if (eq (car-safe value) 'quote)
499 (cadr value)
500 value))
501 alist))))
502 (setq rest-plist (cddr rest-plist)))
503 alist)))))
504 "Structure containing information about an individual package.
505Slots:
506
507`name' Name of the package, as a symbol.
508
509`version' Version of the package, as a version list.
510
511`summary' Short description of the package, typically taken from
512 the first line of the file.
513
514`reqs' Requirements of the package. A list of (PACKAGE
515 VERSION-LIST) naming the dependent package and the minimum
516 required version.
517
518`kind' The distribution format of the package. Currently, it is
519 either `single' or `tar'.
520
521`archive' The name of the archive (as a string) whence this
522 package came.
523
524`dir' The directory where the package is installed (if installed),
525 `builtin' if it is built-in, or nil otherwise.
526
527`extras' Optional alist of additional keyword-value pairs.
528
529`signed' Flag to indicate that the package is signed by provider."
530 name
531 version
532 (summary package--default-summary)
533 reqs
534 kind
535 archive
536 dir
537 extras
538 signed)
539
540(defun package--from-builtin (bi-desc)
541 "Create a `package-desc' object from BI-DESC.
542BI-DESC should be a `package--bi-desc' object."
543 (package-desc-create :name (pop bi-desc)
544 :version (package--bi-desc-version bi-desc)
545 :summary (package--bi-desc-summary bi-desc)
546 :dir 'builtin))
547
548;; Pseudo fields.
549(defun package-version-join (vlist)
550 "Return the version string corresponding to the list VLIST.
551This is, approximately, the inverse of `version-to-list'.
552\(Actually, it returns only one of the possible inverses, since
553`version-to-list' is a many-to-one operation.)"
554 (if (null vlist)
555 ""
556 (let ((str-list (list "." (int-to-string (car vlist)))))
557 (dolist (num (cdr vlist))
558 (cond
559 ((>= num 0)
560 (push (int-to-string num) str-list)
561 (push "." str-list))
562 ((< num -4)
563 (error "Invalid version list `%s'" vlist))
564 (t
565 ;; pre, or beta, or alpha
566 (cond ((equal "." (car str-list))
567 (pop str-list))
568 ((not (string-match "[0-9]+" (car str-list)))
569 (error "Invalid version list `%s'" vlist)))
570 (push (cond ((= num -1) "pre")
571 ((= num -2) "beta")
572 ((= num -3) "alpha")
573 ((= num -4) "snapshot"))
574 str-list))))
575 (if (equal "." (car str-list))
576 (pop str-list))
577 (apply #'concat (nreverse str-list)))))
578
579(defun package-desc-full-name (pkg-desc)
580 "Return full name of package-desc object PKG-DESC.
581This is the name of the package with its version appended."
582 (if (package-vc-p pkg-desc)
583 (symbol-name (package-desc-name pkg-desc))
584 (format "%s-%s"
585 (package-desc-name pkg-desc)
586 (package-version-join (package-desc-version pkg-desc)))))
587
588(defun package-desc-suffix (pkg-desc)
589 "Return file-name extension of package-desc object PKG-DESC.
590Depending on the `package-desc-kind' of PKG-DESC, this is one of:
591
592 \\='single - \".el\"
593 \\='tar - \".tar\"
594 \\='dir - \"\"
595
596Signal an error if the kind is none of the above."
597 (pcase (package-desc-kind pkg-desc)
598 ('single ".el")
599 ('tar ".tar")
600 ('dir "")
601 (kind (error "Unknown package kind: %s" kind))))
602
603(defun package-desc--keywords (pkg-desc)
604 "Return keywords of package-desc object PKG-DESC.
605These keywords come from the foo-pkg.el file, and in general
606corresponds to the keywords in the \"Keywords\" header of the
607package."
608 (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc)))))
609 (if (eq (car-safe keywords) 'quote)
610 (nth 1 keywords)
611 keywords)))
612
613(defun package-desc-priority (pkg-desc)
614 "Return the priority of the archive of package-desc object PKG-DESC."
615 (package-archive-priority (package-desc-archive pkg-desc)))
616
617(defun package--parse-elpaignore (pkg-desc)
618 "Return a list of regular expressions to match files ignored by PKG-DESC."
619 (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
620 (ignore (expand-file-name ".elpaignore" pkg-dir))
621 files)
622 (when (file-exists-p ignore)
623 (with-temp-buffer
624 (insert-file-contents ignore)
625 (goto-char (point-min))
626 (while (not (eobp))
627 (push (wildcard-to-regexp
628 (let ((line (buffer-substring
629 (line-beginning-position)
630 (line-end-position))))
631 (file-name-concat pkg-dir (string-trim-left line "/"))))
632 files)
633 (forward-line)))
634 files)))
635
636(cl-defstruct (package--bi-desc
637 (:constructor package-make-builtin (version summary))
638 (:type vector))
639 "Package descriptor format used in finder-inf.el and package--builtins."
640 version
641 reqs
642 summary)
643
644
645;;; Installed packages
646;; The following variables store information about packages present in
647;; the system. The most important of these is `package-alist'. The
648;; command `package-activate-all' is also closely related to this
649;; section.
650
651(defvar package--builtins nil
652 "Alist of built-in packages.
653The actual value is initialized by loading the library
654`finder-inf'; this is not done until it is needed, e.g. by the
655function `package-built-in-p'.
656
657Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package
658name (a symbol) and DESC is a `package--bi-desc' structure.")
659(put 'package--builtins 'risky-local-variable t)
660
661(defvar package-alist nil
662 "Alist of all packages available for activation.
663Each element has the form (PKG . DESCS), where PKG is a package
664name (a symbol) and DESCS is a non-empty list of `package-desc'
665structures, sorted by decreasing versions.
666
667This variable is set automatically by `package-load-descriptor',
668called via `package-activate-all'. To change which packages are
669loaded and/or activated, customize `package-load-list'.")
670(put 'package-alist 'risky-local-variable t)
671
672;;;; Public interfaces for accessing built-in package info
673
674(defun package-versioned-builtin-packages ()
675 "Return a list of all the versioned built-in packages.
676The return value is a list of names of built-in packages represented as
677symbols."
678 (mapcar #'car package--builtin-versions))
679
680(defun package-builtin-package-version (package)
681 "Return the version of a built-in PACKAGE given by its symbol.
682The return value is a list of integers representing the version of
683PACKAGE, in the format returned by `version-to-list', or nil if the
684package is built-in but has no version or is not a built-in package."
685 (alist-get package package--builtin-versions))
686
687;;;###autoload
688(defvar package-activated-list nil
689 ;; FIXME: This should implicitly include all builtin packages.
690 "List of the names of currently activated packages.")
691(put 'package-activated-list 'risky-local-variable t)
692
693;;;; Populating `package-alist'.
694
695;; The following functions are called on each installed package by
696;; `package-load-all-descriptors', which ultimately populates the
697;; `package-alist' variable.
698
699(declare-function package-vc-version "package-vc" (pkg))
700
701(defun package-process-define-package (exp)
702 "Process define-package expression EXP and push it to `package-alist'.
703EXP should be a form read from a foo-pkg.el file.
704Convert EXP into a `package-desc' object using the
705`package-desc-from-define' constructor before pushing it to
706`package-alist'.
707
708If there already exists a package by the same name in
709`package-alist', insert this object there such that the packages
710are sorted with the highest version first."
711 (when (eq (car-safe exp) 'define-package)
712 (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp)))
713 (name (package-desc-name new-pkg-desc))
714 (version (package-desc-version new-pkg-desc))
715 (old-pkgs (assq name package-alist)))
716 (if (null old-pkgs)
717 ;; If there's no old package, just add this to `package-alist'.
718 (push (list name new-pkg-desc) package-alist)
719 ;; If there is, insert the new package at the right place in the list.
720 (while
721 (if (and (cdr old-pkgs)
722 (version-list-< version
723 (package-desc-version (cadr old-pkgs))))
724 (setq old-pkgs (cdr old-pkgs))
725 (push new-pkg-desc (cdr old-pkgs))
726 nil)))
727 new-pkg-desc)))
728
729(declare-function package-vc-commit "package-vc" (pkg))
730
731(defun package-load-descriptor (pkg-dir)
732 "Load the package description file in directory PKG-DIR.
733Create a new `package-desc' object, add it to `package-alist' and
734return it."
735 (let ((pkg-file (expand-file-name (package--description-file pkg-dir)
736 pkg-dir))
737 (signed-file (concat pkg-dir ".signed")))
738 (when (file-exists-p pkg-file)
739 (with-temp-buffer
740 (insert-file-contents pkg-file)
741 (goto-char (point-min))
742 (let ((pkg-desc (or (package-process-define-package
743 (read (current-buffer)))
744 (error "Can't find define-package in %s" pkg-file))))
745 (setf (package-desc-dir pkg-desc) pkg-dir)
746 (if (file-exists-p signed-file)
747 (setf (package-desc-signed pkg-desc) t))
748 pkg-desc)))))
749
750(defun package-load-all-descriptors ()
751 "Load descriptors for installed Emacs Lisp packages.
752This looks for package subdirectories in `package-user-dir' and
753`package-directory-list'. The variable `package-load-list'
754controls which package subdirectories may be loaded.
755
756In each valid package subdirectory, this function loads the
757description file containing a call to `define-package', which
758updates `package-alist'."
759 (dolist (dir (cons package-user-dir package-directory-list))
760 (when (file-directory-p dir)
761 (dolist (pkg-dir (directory-files dir t "\\`[^.]"))
762 (when (file-directory-p pkg-dir)
763 (package-load-descriptor pkg-dir))))))
764
765(defun package--alist ()
766 "Return `package-alist', after computing it if needed."
767 (or package-alist
768 (progn (package-load-all-descriptors)
769 package-alist)))
770
771(defun define-package ( _name-string _version-string
772 &optional _docstring _requirements
773 &rest _extra-properties)
774 "Define a new package.
775NAME-STRING is the name of the package, as a string.
776VERSION-STRING is the version of the package, as a string.
777DOCSTRING is a short description of the package, a string.
778REQUIREMENTS is a list of dependencies on other packages.
779 Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
780 where OTHER-VERSION is a string.
781
782EXTRA-PROPERTIES is currently unused."
783 (declare (obsolete nil "29.1") (indent defun))
784 (error "Don't call me!"))
785
786
787;;; Package activation
788;; Section for functions used by `package-activate', which see.
789
790(defun package-disabled-p (pkg-name version)
791 "Return whether PKG-NAME at VERSION can be activated.
792The decision is made according to `package-load-list'.
793Return nil if the package can be activated.
794Return t if the package is completely disabled.
795Return the max version (as a string) if the package is held at a lower version."
796 (let ((force (assq pkg-name package-load-list)))
797 (cond ((null force) (not (memq 'all package-load-list)))
798 ((null (setq force (cadr force))) t) ; disabled
799 ((eq force t) nil)
800 ((stringp force) ; held
801 (unless (version-list-= version (version-to-list force))
802 force))
803 (t (error "Invalid element in `package-load-list'")))))
804
805(defun package-built-in-p (package &optional min-version)
806 "Return non-nil if PACKAGE is built-in to Emacs.
807Optional arg MIN-VERSION, if non-nil, should be a version list
808specifying the minimum acceptable version."
809 (if (package-desc-p package) ;; was built-in and then was converted
810 (eq 'builtin (package-desc-dir package))
811 (let ((bi (assq package package--builtin-versions)))
812 (cond
813 (bi (version-list-<= min-version (cdr bi)))
814 ((remove 0 min-version) nil)
815 (t
816 (require 'finder-inf nil t) ; For `package--builtins'.
817 (assq package package--builtins))))))
818
819(defun package--active-built-in-p (package)
820 "Return non-nil if the built-in version of PACKAGE is used.
821If the built-in version of PACKAGE is used and PACKAGE is
822also available for installation from an archive, it is an
823indication that PACKAGE was never upgraded to any newer
824version from the archive."
825 (and (not (assq (cond
826 ((package-desc-p package)
827 (package-desc-name package))
828 ((stringp package) (intern package))
829 ((symbolp package) package)
830 ((error "Unknown package format: %S" package)))
831 (package--alist)))
832 (package-built-in-p package)))
833
834(defun package--autoloads-file-name (pkg-desc)
835 "Return the absolute name of the autoloads file, sans extension.
836PKG-DESC is a `package-desc' object."
837 (expand-file-name
838 (format "%s-autoloads" (package-desc-name pkg-desc))
839 (package-desc-dir pkg-desc)))
840
841(defvar Info-directory-list)
842(declare-function info-initialize "info" ())
843
844(defvar package--quickstart-pkgs t
845 "If set to a list, we're computing the set of pkgs to activate.")
846
847(defsubst package--library-stem (file)
848 (catch 'done
849 (let (result)
850 (dolist (suffix (get-load-suffixes) file)
851 (setq result (string-trim file nil suffix))
852 (unless (equal file result)
853 (throw 'done result))))))
854
855(defun package--reload-previously-loaded (pkg-desc &optional warn)
856 "Force reimportation of files in PKG-DESC already present in `load-history'.
857New editions of files contain macro definitions and
858redefinitions, the overlooking of which would cause
859byte-compilation of the new package to fail.
860If WARN is a string, display a warning (using WARN as a format string)
861before reloading the files. WARN must have two %-sequences
862corresponding to package name (a symbol) and a list of files loaded (as
863sexps)."
864 (with-demoted-errors "Error in package--load-files-for-activation: %s"
865 (let* (result
866 (dir (package-desc-dir pkg-desc))
867 ;; A previous implementation would skip `dir' itself.
868 ;; However, in normal use reloading from the same directory
869 ;; never happens anyway, while in certain cases external to
870 ;; Emacs a package in the same directory not necessary
871 ;; stays byte-identical, e.g. during development. Just
872 ;; don't special-case `dir'.
873 (effective-path (or (bound-and-true-p find-library-source-path)
874 load-path))
875 (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))
876 (history (mapcar #'file-truename
877 (cl-remove-if-not #'stringp
878 (mapcar #'car load-history)))))
879 (dolist (file files)
880 (when-let* ((library (package--library-stem
881 (file-relative-name file dir)))
882 (canonical (locate-library library nil effective-path))
883 (truename (file-truename canonical))
884 ;; Normally, all files in a package are compiled by
885 ;; now, but don't assume that. E.g. different
886 ;; versions can add or remove `no-byte-compile'.
887 (altname (if (string-suffix-p ".el" truename)
888 (replace-regexp-in-string
889 "\\.el\\'" ".elc" truename t)
890 (replace-regexp-in-string
891 "\\.elc\\'" ".el" truename t)))
892 (found (or (member truename history)
893 (and (not (string= altname truename))
894 (member altname history))))
895 (recent-index (length found)))
896 (unless (equal (file-name-base library)
897 (format "%s-autoloads" (package-desc-name pkg-desc)))
898 (push (cons (expand-file-name library dir) recent-index) result))))
899 (when (and result warn)
900 (display-warning 'package
901 (format warn (package-desc-name pkg-desc)
902 (mapcar #'car result))))
903 (mapc (lambda (c) (load (car c) nil t))
904 (sort result (lambda (x y) (< (cdr x) (cdr y))))))))
905
906(defun package-activate-1 (pkg-desc &optional reload deps)
907 "Activate package given by PKG-DESC, even if it was already active.
908If DEPS is non-nil, also activate its dependencies (unless they
909are already activated).
910If RELOAD is non-nil, also `load' any files inside the package which
911correspond to previously loaded files."
912 (let* ((name (package-desc-name pkg-desc))
913 (pkg-dir (package-desc-dir pkg-desc)))
914 (unless pkg-dir
915 (error "Internal error: unable to find directory for `%s'"
916 (package-desc-full-name pkg-desc)))
917 (catch 'exit
918 ;; Activate its dependencies recursively.
919 ;; FIXME: This doesn't check whether the activated version is the
920 ;; required version.
921 (when deps
922 (dolist (req (package-desc-reqs pkg-desc))
923 (unless (package-activate (car req))
924 (message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable"
925 name (car req) (package-version-join (cadr req)))
926 (throw 'exit nil))))
927 (if (listp package--quickstart-pkgs)
928 ;; We're only collecting the set of packages to activate!
929 (push pkg-desc package--quickstart-pkgs)
930 (when (or reload (assq name package--builtin-versions))
931 (package--reload-previously-loaded
932 pkg-desc (unless reload
933 "Package %S is activated too late.
934The following files have already been loaded: %S")))
935 (with-demoted-errors "Error loading autoloads: %s"
936 (load (package--autoloads-file-name pkg-desc) nil t)))
937 ;; Add info node.
938 (when (file-exists-p (expand-file-name "dir" pkg-dir))
939 ;; FIXME: not the friendliest, but simple.
940 (require 'info)
941 (info-initialize)
942 (add-to-list 'Info-directory-list pkg-dir))
943 (push name package-activated-list)
944 ;; Don't return nil.
945 t)))
946
947;;;; `package-activate'
948
949(defun package--get-activatable-pkg (pkg-name)
950 ;; Is "activatable" a word?
951 (let ((pkg-descs (cdr (assq pkg-name package-alist))))
952 ;; Check if PACKAGE is available in `package-alist'.
953 (while
954 (when pkg-descs
955 (let ((available-version (package-desc-version (car pkg-descs))))
956 (or (package-disabled-p pkg-name available-version)
957 ;; Prefer a builtin package.
958 (package-built-in-p pkg-name available-version))))
959 (setq pkg-descs (cdr pkg-descs)))
960 (car pkg-descs)))
961
962;; This function activates a newer version of a package if an older
963;; one was already activated. It also loads a features of this
964;; package which were already loaded.
965(defun package-activate (package &optional force)
966 "Activate the package named PACKAGE.
967If FORCE is true, (re-)activate it if it's already activated.
968Newer versions are always activated, regardless of FORCE."
969 (let ((pkg-desc (package--get-activatable-pkg package)))
970 (cond
971 ;; If no such package is found, maybe it's built-in.
972 ((null pkg-desc)
973 (package-built-in-p package))
974 ;; If the package is already activated, just return t.
975 ((and (memq package package-activated-list) (not force))
976 t)
977 ;; Otherwise, proceed with activation.
978 (t (package-activate-1 pkg-desc nil 'deps)))))
979
980
981;;; Installation -- Local operations
982;; This section contains a variety of features regarding installing a
983;; package to/from disk. This includes autoload generation,
984;; unpacking, compiling, as well as defining a package from the
985;; current buffer.
986
987;;;; Unpacking
988(defvar tar-parse-info)
989(declare-function tar-untar-buffer "tar-mode" ())
990(declare-function tar-header-name "tar-mode" (tar-header) t)
991(declare-function tar-header-link-type "tar-mode" (tar-header) t)
992
993(defun package-untar-buffer (dir)
994 "Untar the current buffer.
995This uses `tar-untar-buffer' from Tar mode. All files should
996untar into a directory named DIR; otherwise, signal an error."
997 (tar-mode)
998 ;; Make sure everything extracts into DIR.
999 (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
1000 (case-fold-search (file-name-case-insensitive-p dir)))
1001 (dolist (tar-data tar-parse-info)
1002 (let ((name (expand-file-name (tar-header-name tar-data))))
1003 (or (string-match regexp name)
1004 ;; Tarballs created by some utilities don't list
1005 ;; directories with a trailing slash (Bug#13136).
1006 (and (string-equal (expand-file-name dir) name)
1007 (eq (tar-header-link-type tar-data) 5))
1008 (error "Package does not untar cleanly into directory %s/" dir)))))
1009 (tar-untar-buffer))
1010
1011(defun package--alist-to-plist-args (alist)
1012 (mapcar #'macroexp-quote
1013 (apply #'nconc
1014 (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
1015
1016(declare-function dired-get-marked-files "dired")
1017
1018(defun package-unpack (pkg-desc)
1019 "Install the contents of the current buffer as a package."
1020 (let* ((name (package-desc-name pkg-desc))
1021 (dirname (package-desc-full-name pkg-desc))
1022 (pkg-dir (expand-file-name dirname package-user-dir)))
1023 (pcase (package-desc-kind pkg-desc)
1024 ('dir
1025 (make-directory pkg-dir t)
1026 (let ((file-list
1027 (or (and (derived-mode-p 'dired-mode)
1028 (dired-get-marked-files))
1029 (directory-files-recursively default-directory "" nil))))
1030 (dolist (source-file file-list)
1031 (let ((target (expand-file-name
1032 (file-relative-name source-file default-directory)
1033 pkg-dir)))
1034 (make-directory (file-name-directory target) t)
1035 (copy-file source-file target t)))
1036 ;; Now that the files have been installed, this package is
1037 ;; indistinguishable from a `tar' or a `single'. Let's make
1038 ;; things simple by ensuring we're one of them.
1039 (setf (package-desc-kind pkg-desc)
1040 (if (length> file-list 1) 'tar 'single))))
1041 ('tar
1042 (make-directory package-user-dir t)
1043 (let* ((default-directory (file-name-as-directory package-user-dir)))
1044 (package-untar-buffer dirname)))
1045 ('single
1046 (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir)))
1047 (make-directory pkg-dir t)
1048 (package--write-file-no-coding el-file)))
1049 (kind (error "Unknown package kind: %S" kind)))
1050 (package--make-autoloads-and-stuff pkg-desc pkg-dir)
1051 ;; Update package-alist.
1052 (let ((new-desc (package-load-descriptor pkg-dir)))
1053 (unless (equal (package-desc-full-name new-desc)
1054 (package-desc-full-name pkg-desc))
1055 (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')"
1056 (package-desc-full-name new-desc) (package-desc-full-name pkg-desc)))
1057 ;; Activation has to be done before compilation, so that if we're
1058 ;; upgrading and macros have changed we load the new definitions
1059 ;; before compiling.
1060 (when (package-activate-1 new-desc :reload :deps)
1061 ;; FIXME: Compilation should be done as a separate, optional, step.
1062 ;; E.g. for multi-package installs, we should first install all packages
1063 ;; and then compile them.
1064 (package--compile new-desc)
1065 (when package-native-compile
1066 (package--native-compile-async new-desc))
1067 ;; After compilation, load again any files loaded by
1068 ;; `activate-1', so that we use the byte-compiled definitions.
1069 (package--reload-previously-loaded new-desc)))
1070 pkg-dir))
1071
1072(defun package-generate-description-file (pkg-desc pkg-file)
1073 "Create the foo-pkg.el file PKG-FILE for single-file package PKG-DESC."
1074 (let* ((name (package-desc-name pkg-desc)))
1075 (let ((print-level nil)
1076 (print-quoted t)
1077 (print-length nil))
1078 (write-region
1079 (concat
1080 ";;; Generated package description from "
1081 (replace-regexp-in-string "-pkg\\.el\\'" ".el"
1082 (file-name-nondirectory pkg-file))
1083 " -*- no-byte-compile: t -*-\n"
1084 (prin1-to-string
1085 (nconc
1086 (list 'define-package
1087 (symbol-name name)
1088 (package-version-join (package-desc-version pkg-desc))
1089 (package-desc-summary pkg-desc)
1090 (let ((requires (package-desc-reqs pkg-desc)))
1091 (list 'quote
1092 ;; Turn version lists into string form.
1093 (mapcar
1094 (lambda (elt)
1095 (list (car elt)
1096 (package-version-join (cadr elt))))
1097 requires))))
1098 (package--alist-to-plist-args
1099 (package-desc-extras pkg-desc))))
1100 "\n")
1101 nil pkg-file nil 'silent))))
1102
1103
1104;;;; Autoload
1105(declare-function autoload-rubric "autoload" (file &optional type feature))
1106
1107(defun package-autoload-ensure-default-file (file)
1108 "Make sure that the autoload file FILE exists and if not create it."
1109 (declare (obsolete nil "29.1"))
1110 (unless (file-exists-p file)
1111 (require 'autoload)
1112 (let ((coding-system-for-write 'utf-8-emacs-unix))
1113 (with-suppressed-warnings ((obsolete autoload-rubric))
1114 (write-region (autoload-rubric file "package" nil)
1115 nil file nil 'silent))))
1116 file)
1117
1118(defvar autoload-timestamps)
1119(defvar version-control)
1120
1121(defun package-generate-autoloads (name pkg-dir)
1122 "Generate autoloads in PKG-DIR for package named NAME."
1123 (let* ((auto-name (format "%s-autoloads.el" name))
1124 ;;(ignore-name (concat name "-pkg.el"))
1125 (output-file (expand-file-name auto-name pkg-dir))
1126 ;; We don't need 'em, and this makes the output reproducible.
1127 (autoload-timestamps nil)
1128 (backup-inhibited t)
1129 (version-control 'never))
1130 (loaddefs-generate
1131 pkg-dir output-file nil
1132 (prin1-to-string
1133 '(add-to-list
1134 'load-path
1135 ;; Add the directory that will contain the autoload file to
1136 ;; the load path. We don't hard-code `pkg-dir', to avoid
1137 ;; issues if the package directory is moved around.
1138 ;; `loaddefs-generate' has code to do this for us, but it's
1139 ;; not currently exposed. (Bug#63625)
1140 (or (and load-file-name
1141 (directory-file-name
1142 (file-name-directory load-file-name)))
1143 (car load-path)))))
1144 (let ((buf (find-buffer-visiting output-file)))
1145 (when buf (kill-buffer buf)))
1146 auto-name))
1147
1148(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir)
1149 "Generate autoloads, description file, etc., for PKG-DESC installed at PKG-DIR."
1150 (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir)
1151 (let ((desc-file (expand-file-name (package--description-file pkg-dir)
1152 pkg-dir)))
1153 (unless (file-exists-p desc-file)
1154 (package-generate-description-file pkg-desc desc-file)))
1155 ;; FIXME: Create foo.info and dir file from foo.texi?
1156 )
1157
1158;;;; Compilation
1159(defvar warning-minimum-level)
1160(defvar byte-compile-ignore-files)
1161(defun package--compile (pkg-desc)
1162 "Byte-compile installed package PKG-DESC.
1163This assumes that `pkg-desc' has already been activated with
1164`package-activate-1'."
1165 (let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc))
1166 (warning-minimum-level :error)
1167 (load-path load-path))
1168 (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
1169
1170(defun package--native-compile-async (pkg-desc)
1171 "Native compile installed package PKG-DESC asynchronously.
1172This assumes that `pkg-desc' has already been activated with
1173`package-activate-1'."
1174 (when (native-comp-available-p)
1175 (let ((warning-minimum-level :error))
1176 (native-compile-async (package-desc-dir pkg-desc) t))))
1177
1178;;;; Inferring package from current buffer
1179(defun package-read-from-string (str)
1180 "Read a Lisp expression from STR.
1181Signal an error if the entire string was not used."
1182 (pcase-let ((`(,expr . ,offset) (read-from-string str)))
1183 (condition-case ()
1184 ;; The call to `ignore' suppresses a compiler warning.
1185 (progn (ignore (read-from-string str offset))
1186 (error "Can't read whole string"))
1187 (end-of-file expr))))
1188
1189(declare-function lm-header "lisp-mnt" (header))
1190(declare-function lm-package-requires "lisp-mnt" (&optional file))
1191(declare-function lm-package-version "lisp-mnt" (&optional file))
1192(declare-function lm-website "lisp-mnt" (&optional file))
1193(declare-function lm-keywords-list "lisp-mnt" (&optional file))
1194(declare-function lm-maintainers "lisp-mnt" (&optional file))
1195(declare-function lm-authors "lisp-mnt" (&optional file))
1196
1197(defun package-buffer-info ()
1198 "Return a `package-desc' describing the package in the current buffer.
1199
1200If the buffer does not contain a conforming package, signal an
1201error. If there is a package, narrow the buffer to the file's
1202boundaries."
1203 (goto-char (point-min))
1204 (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
1205 (error "Package lacks a file header"))
1206 (let ((file-name (match-string-no-properties 1))
1207 (desc (match-string-no-properties 2)))
1208 (require 'lisp-mnt)
1209 (let* ((version-info (lm-package-version))
1210 (pkg-version (package-strip-rcs-id version-info))
1211 (keywords (lm-keywords-list))
1212 (website (lm-website)))
1213 (unless pkg-version
1214 (if version-info
1215 (error "Unrecognized package version: %s" version-info)
1216 (error "Package lacks a \"Version\" or \"Package-Version\" header")))
1217 (package-desc-from-define
1218 file-name pkg-version desc
1219 (lm-package-requires)
1220 :kind 'single
1221 :url website
1222 :keywords keywords
1223 :maintainer
1224 ;; For backward compatibility, use a single cons-cell if
1225 ;; there's only one maintainer (the most common case).
1226 (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints)))
1227 :authors (lm-authors)))))
1228
1229(defun package--read-pkg-desc (kind)
1230 "Read a `define-package' form in current buffer.
1231Return the pkg-desc, with desc-kind set to KIND."
1232 (goto-char (point-min))
1233 (let* ((pkg-def-parsed (read (current-buffer)))
1234 (pkg-desc
1235 (when (eq (car pkg-def-parsed) 'define-package)
1236 (apply #'package-desc-from-define
1237 (append (cdr pkg-def-parsed))))))
1238 (when pkg-desc
1239 (setf (package-desc-kind pkg-desc) kind)
1240 pkg-desc)))
1241
1242(declare-function tar-get-file-descriptor "tar-mode" (file))
1243(declare-function tar--extract "tar-mode" (descriptor))
1244
1245(defun package-tar-file-info ()
1246 "Find package information for a tar file.
1247The return result is a `package-desc'."
1248 (cl-assert (derived-mode-p 'tar-mode))
1249 (let* ((dir-name (named-let loop
1250 ((filename (tar-header-name (car tar-parse-info))))
1251 (let ((dirname (file-name-directory filename)))
1252 ;; The first file can be in a subdir: look for the top.
1253 (if dirname (loop (directory-file-name dirname))
1254 (file-name-as-directory filename)))))
1255 (desc-file (package--description-file dir-name))
1256 (tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
1257 (unless tar-desc
1258 (error "No package descriptor file found"))
1259 (with-current-buffer (tar--extract tar-desc)
1260 (unwind-protect
1261 (or (package--read-pkg-desc 'tar)
1262 (error "Can't find define-package in %s"
1263 (tar-header-name tar-desc)))
1264 (kill-buffer (current-buffer))))))
1265
1266(defun package-dir-info ()
1267 "Find package information for a directory.
1268The return result is a `package-desc'."
1269 (cl-assert (derived-mode-p 'dired-mode))
1270 (let* ((desc-file (package--description-file default-directory)))
1271 (if (file-readable-p desc-file)
1272 (with-temp-buffer
1273 (insert-file-contents desc-file)
1274 (package--read-pkg-desc 'dir))
1275 (catch 'found
1276 (let ((files (or (and (derived-mode-p 'dired-mode)
1277 (dired-get-marked-files))
1278 (directory-files-recursively default-directory "\\.el\\'"))))
1279 ;; We sort the file names in lexicographical order, to ensure
1280 ;; that we check shorter file names first (ie. those further
1281 ;; up in the directory structure).
1282 (dolist (file (sort files))
1283 ;; The file may be a link to a nonexistent file; e.g., a
1284 ;; lock file.
1285 (when (file-exists-p file)
1286 (with-temp-buffer
1287 (insert-file-contents file)
1288 ;; When we find the file with the data,
1289 (when-let* ((info (ignore-errors (package-buffer-info))))
1290 (setf (package-desc-kind info) 'dir)
1291 (throw 'found info))))))
1292 (error "No .el files with package headers in `%s'" default-directory)))))
1293
1294
1295;;; Communicating with Archives
1296;; Set of low-level functions for communicating with archives and
1297;; signature checking.
1298
1299(defun package--write-file-no-coding (file-name)
1300 "Write file FILE-NAME without encoding using coding system."
1301 (let ((buffer-file-coding-system 'no-conversion))
1302 (write-region (point-min) (point-max) file-name nil 'silent)))
1303
1304(declare-function url-http-file-exists-p "url-http" (url))
1305
1306(defun package--archive-file-exists-p (location file)
1307 "Return t if FILE exists in remote LOCATION."
1308 (let ((http (string-match "\\`https?:" location)))
1309 (if http
1310 (progn
1311 (require 'url-http)
1312 (url-http-file-exists-p (concat location file)))
1313 (file-exists-p (expand-file-name file location)))))
1314
1315(declare-function epg-make-context "epg"
1316 (&optional protocol armor textmode include-certs
1317 cipher-algorithm
1318 digest-algorithm
1319 compress-algorithm))
1320(declare-function epg-verify-string "epg" ( context signature
1321 &optional signed-text))
1322(declare-function epg-context-result-for "epg" (context name))
1323(declare-function epg-signature-status "epg" (signature) t)
1324(declare-function epg-signature-to-string "epg" (signature))
1325
1326(defun package--display-verify-error (context sig-file)
1327 "Show error details with CONTEXT for failed verification of SIG-FILE.
1328The details are shown in a new buffer called \"*Error\"."
1329 (unless (equal (epg-context-error-output context) "")
1330 (with-output-to-temp-buffer "*Error*"
1331 (with-current-buffer standard-output
1332 (if (epg-context-result-for context 'verify)
1333 (insert (format "Failed to verify signature %s:\n" sig-file)
1334 (mapconcat #'epg-signature-to-string
1335 (epg-context-result-for context 'verify)
1336 "\n"))
1337 (insert (format "Error while verifying signature %s:\n" sig-file)))
1338 (insert "\nCommand output:\n" (epg-context-error-output context))))))
1339
1340(defmacro package--with-work-buffer (location file &rest body)
1341 "Run BODY in a buffer containing the contents of FILE at LOCATION.
1342LOCATION is the base location of a package archive, and should be
1343one of the URLs (or file names) specified in `package-archives'.
1344FILE is the name of a file relative to that base location.
1345
1346This macro retrieves FILE from LOCATION into a temporary buffer,
1347and evaluates BODY while that buffer is current. This work
1348buffer is killed afterwards. Return the last value in BODY."
1349 (declare (indent 2) (debug t)
1350 (obsolete package--with-response-buffer "25.1"))
1351 `(with-temp-buffer
1352 (if (string-match-p "\\`https?:" ,location)
1353 (url-insert-file-contents (concat ,location ,file))
1354 (unless (file-name-absolute-p ,location)
1355 (error "Archive location %s is not an absolute file name"
1356 ,location))
1357 (insert-file-contents (expand-file-name ,file ,location)))
1358 ,@body))
1359
1360(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
1361 "Access URL and run BODY in a buffer containing the response.
1362Point is after the headers when BODY runs.
1363FILE, if provided, is added to URL.
1364URL can be a local file name, which must be absolute.
1365ASYNC, if non-nil, runs the request asynchronously.
1366ERROR-FORM is run only if a connection error occurs. If NOERROR
1367is non-nil, don't propagate connection errors (does not apply to
1368errors signaled by ERROR-FORM or by BODY).
1369
1370\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
1371 (declare (indent defun) (debug (sexp body)))
1372 (while (keywordp (car body))
1373 (setq body (cdr (cdr body))))
1374 `(package--with-response-buffer-1 ,url (lambda () ,@body)
1375 :file ,file
1376 :async ,async
1377 :error-function (lambda () ,error-form)
1378 :noerror ,noerror))
1379
1380(defmacro package--unless-error (body &rest before-body)
1381 (declare (debug t) (indent 1))
1382 (let ((err (make-symbol "err")))
1383 `(with-temp-buffer
1384 (set-buffer-multibyte nil)
1385 (when (condition-case ,err
1386 (progn ,@before-body t)
1387 (error (funcall error-function)
1388 (unless noerror
1389 (signal (car ,err) (cdr ,err)))))
1390 (funcall ,body)))))
1391
1392(cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys)
1393 (if (string-match-p "\\`https?:" url)
1394 (let ((url (url-expand-file-name file url)))
1395 (if async
1396 (package--unless-error #'ignore
1397 (url-retrieve
1398 url
1399 (lambda (status)
1400 (let ((b (current-buffer)))
1401 (require 'url-handlers)
1402 (package--unless-error body
1403 (when-let* ((er (plist-get status :error)))
1404 (error "Error retrieving: %s %S" url er))
1405 (with-current-buffer b
1406 (goto-char (point-min))
1407 (unless (search-forward-regexp "^\r?\n\r?" nil t)
1408 (error "Error retrieving: %s %S"
1409 url "incomprehensible buffer")))
1410 (url-insert b)
1411 (kill-buffer b)
1412 (goto-char (point-min)))))
1413 nil
1414 'silent))
1415 (package--unless-error body
1416 ;; Copy&pasted from url-insert-file-contents,
1417 ;; except it calls `url-insert' because we want the contents
1418 ;; literally (but there's no url-insert-file-contents-literally).
1419 (let ((buffer (url-retrieve-synchronously url)))
1420 (unless buffer (signal 'file-error (list url "No Data")))
1421 (when (fboundp 'url-http--insert-file-helper)
1422 ;; XXX: This is HTTP/S specific and should be moved
1423 ;; to url-http instead. See bug#17549.
1424 (url-http--insert-file-helper buffer url))
1425 (url-insert buffer)
1426 (kill-buffer buffer)
1427 (goto-char (point-min))))))
1428 (package--unless-error body
1429 (unless (file-name-absolute-p url)
1430 (error "Location %s is not a url nor an absolute file name" url))
1431 (insert-file-contents-literally (expand-file-name file url)))))
1432
1433(define-error 'bad-signature "Failed to verify signature")
1434
1435(defun package--check-signature-content (content string &optional sig-file)
1436 "Check signature CONTENT against STRING.
1437SIG-FILE is the name of the signature file, used when signaling
1438errors."
1439 (let ((context (epg-make-context 'OpenPGP)))
1440 (when package-gnupghome-dir
1441 (setf (epg-context-home-directory context) package-gnupghome-dir))
1442 (condition-case error
1443 (epg-verify-string context content string)
1444 (error (package--display-verify-error context sig-file)
1445 (signal 'bad-signature error)))
1446 (let (good-signatures had-fatal-error)
1447 ;; The .sig file may contain multiple signatures. Success if one
1448 ;; of the signatures is good.
1449 (dolist (sig (epg-context-result-for context 'verify))
1450 (if (eq (epg-signature-status sig) 'good)
1451 (push sig good-signatures)
1452 ;; If `package-check-signature' is allow-unsigned, don't
1453 ;; signal error when we can't verify signature because of
1454 ;; missing public key. Other errors are still treated as
1455 ;; fatal (bug#17625).
1456 (unless (and (eq (package-check-signature) 'allow-unsigned)
1457 (eq (epg-signature-status sig) 'no-pubkey))
1458 (setq had-fatal-error t))))
1459 (when (or (null good-signatures)
1460 (and (eq (package-check-signature) 'all)
1461 had-fatal-error))
1462 (package--display-verify-error context sig-file)
1463 (signal 'bad-signature (list sig-file)))
1464 good-signatures)))
1465
1466(defun package--check-signature (location file &optional string async callback unwind)
1467 "Check signature of the current buffer.
1468Download the signature file from LOCATION by appending \".sig\"
1469to FILE.
1470GnuPG keyring location depends on `package-gnupghome-dir'.
1471STRING is the string to verify, it defaults to `buffer-string'.
1472If ASYNC is non-nil, the download of the signature file is
1473done asynchronously.
1474
1475If the signature does not verify, signal an error.
1476If the signature is verified and CALLBACK was provided, `funcall'
1477CALLBACK with the list of good signatures as argument (the list
1478can be empty).
1479If no signatures file is found, and `package-check-signature' is
1480`allow-unsigned', call CALLBACK with a nil argument.
1481Otherwise, an error is signaled.
1482
1483UNWIND, if provided, is a function to be called after everything
1484else, even if an error is signaled."
1485 (let ((sig-file (concat file ".sig"))
1486 (string (or string (buffer-string))))
1487 (package--with-response-buffer location :file sig-file
1488 :async async :noerror t
1489 ;; Connection error is assumed to mean "no sig-file".
1490 :error-form (let ((allow-unsigned
1491 (eq (package-check-signature) 'allow-unsigned)))
1492 (when (and callback allow-unsigned)
1493 (funcall callback nil))
1494 (when unwind (funcall unwind))
1495 (unless allow-unsigned
1496 (error "Unsigned file `%s' at %s" file location)))
1497 ;; OTOH, an error here means "bad signature", which we never
1498 ;; suppress. (Bug#22089)
1499 (unwind-protect
1500 (let ((sig (package--check-signature-content
1501 (buffer-substring (point) (point-max))
1502 string sig-file)))
1503 (when callback (funcall callback sig))
1504 sig)
1505 (when unwind (funcall unwind))))))
1506
1507;;; Packages on Archives
1508;; The following variables store information about packages available
1509;; from archives. The most important of these is
1510;; `package-archive-contents' which is initially populated by the
1511;; function `package-read-all-archive-contents' from a cache on disk.
1512;; The `package-initialize' command is also closely related to this
1513;; section, but it has its own section.
1514
1515(defconst package-archive-version 1
1516 "Version number of the package archive understood by package.el.
1517Lower version numbers than this will probably be understood as well.")
1518
1519;; We don't prime the cache since it tends to get out of date.
1520(defvar package-archive-contents nil
1521 "Cache of the contents of all archives in `package-archives'.
1522This is an alist mapping package names (symbols) to
1523non-empty lists of `package-desc' structures.")
1524(put 'package-archive-contents 'risky-local-variable t)
1525
1526(defvar package--compatibility-table nil
1527 "Hash table connecting package names to their compatibility.
1528Each key is a symbol, the name of a package.
1529
1530The value is either nil, representing an incompatible package, or
1531a version list, representing the highest compatible version of
1532that package which is available.
1533
1534A package is considered incompatible if it requires an Emacs
1535version higher than the one being used. To check for package
1536\(in)compatibility, don't read this table directly, use
1537`package--incompatible-p' which also checks dependencies.")
1538
1539(defun package--build-compatibility-table ()
1540 "Build `package--compatibility-table' with `package--mapc'."
1541 ;; Initialize the list of built-ins.
1542 (require 'finder-inf nil t)
1543 ;; Build compat table.
1544 (setq package--compatibility-table (make-hash-table :test 'eq))
1545 (package--mapc #'package--add-to-compatibility-table))
1546
1547(defun package--add-to-compatibility-table (pkg)
1548 "If PKG is compatible (without dependencies), add to the compatibility table.
1549PKG is a package-desc object.
1550Only adds if its version is higher than what's already stored in
1551the table."
1552 (unless (package--incompatible-p pkg 'shallow)
1553 (let* ((name (package-desc-name pkg))
1554 (version (or (package-desc-version pkg) '(0)))
1555 (table-version (gethash name package--compatibility-table)))
1556 (when (or (not table-version)
1557 (version-list-< table-version version))
1558 (puthash name version package--compatibility-table)))))
1559
1560;; Package descriptor objects used inside the "archive-contents" file.
1561;; Changing this defstruct implies changing the format of the
1562;; "archive-contents" files.
1563(cl-defstruct (package--ac-desc
1564 (:constructor package-make-ac-desc (version reqs summary kind extras))
1565 (:copier nil)
1566 (:type vector))
1567 version reqs summary kind extras)
1568
1569(defun package--append-to-alist (pkg-desc alist)
1570 "Append an entry for PKG-DESC to the start of ALIST and return it.
1571This entry takes the form (`package-desc-name' PKG-DESC).
1572
1573If ALIST already has an entry with this name, destructively add
1574PKG-DESC to the cdr of this entry instead, sorted by version
1575number."
1576 (let* ((name (package-desc-name pkg-desc))
1577 (priority-version (package-desc-priority-version pkg-desc))
1578 (existing-packages (assq name alist)))
1579 (if (not existing-packages)
1580 (cons (list name pkg-desc)
1581 alist)
1582 (while (if (and (cdr existing-packages)
1583 (version-list-< priority-version
1584 (package-desc-priority-version
1585 (cadr existing-packages))))
1586 (setq existing-packages (cdr existing-packages))
1587 (push pkg-desc (cdr existing-packages))
1588 nil))
1589 alist)))
1590
1591(defun package--add-to-archive-contents (package archive)
1592 "Add the PACKAGE from the given ARCHIVE if necessary.
1593PACKAGE should have the form (NAME . PACKAGE--AC-DESC).
1594Also, add the originating archive to the `package-desc' structure."
1595 (let* ((name (car package))
1596 (version (package--ac-desc-version (cdr package)))
1597 (pkg-desc
1598 (package-desc-create
1599 :name name
1600 :version version
1601 :reqs (package--ac-desc-reqs (cdr package))
1602 :summary (package--ac-desc-summary (cdr package))
1603 :kind (package--ac-desc-kind (cdr package))
1604 :archive archive
1605 :extras (and (> (length (cdr package)) 4)
1606 ;; Older archive-contents files have only 4
1607 ;; elements here.
1608 (package--ac-desc-extras (cdr package)))))
1609 (pinned-to-archive (assoc name package-pinned-packages)))
1610 ;; Skip entirely if pinned to another archive.
1611 (when (not (and pinned-to-archive
1612 (not (equal (cdr pinned-to-archive) archive))))
1613 (setq package-archive-contents
1614 (package--append-to-alist pkg-desc package-archive-contents)))))
1615
1616(defun package--read-archive-file (file)
1617 "Read cached archive FILE data, if it exists.
1618Return the data from the file, or nil if the file does not exist.
1619If the archive version is too new, signal an error."
1620 (let ((filename (expand-file-name file package-user-dir)))
1621 (when (file-exists-p filename)
1622 (with-temp-buffer
1623 (let ((coding-system-for-read 'utf-8))
1624 (insert-file-contents filename))
1625 (let ((contents (read (current-buffer))))
1626 (if (> (car contents) package-archive-version)
1627 (error "Package archive version %d is higher than %d"
1628 (car contents) package-archive-version))
1629 (cdr contents))))))
1630
1631(defun package-read-archive-contents (archive)
1632 "Read cached archive file for ARCHIVE.
1633If successful, set or update the variable `package-archive-contents'.
1634ARCHIVE should be a string matching the name of a package archive
1635in the variable `package-archives'.
1636If the archive version is too new, signal an error."
1637 ;; Version 1 of 'archive-contents' is identical to our internal
1638 ;; representation.
1639 (let* ((contents-file (format "archives/%s/archive-contents" archive))
1640 (contents (package--read-archive-file contents-file)))
1641 (when contents
1642 (dolist (package contents)
1643 (if package
1644 (package--add-to-archive-contents package archive)
1645 (lwarn '(package refresh) :warning
1646 "Ignoring nil package on `%s' package archive" archive))))))
1647
1648(defvar package--old-archive-priorities nil
1649 "Store currently used `package-archive-priorities'.
1650This is the value of `package-archive-priorities' last time
1651`package-read-all-archive-contents' was called. It can be used
1652by arbitrary functions to decide whether it is necessary to call
1653it again.")
1654
1655(defvar package-read-archive-hook (list #'package-read-archive-contents)
1656 "List of functions to call to read the archive contents.
1657Each function must take an optional argument, a symbol indicating
1658what archive to read in. The symbol ought to be a key in
1659`package-archives'.")
1660
1661(defun package-read-all-archive-contents ()
1662 "Read cached archive file for all archives in `package-archives'.
1663If successful, set or update `package-archive-contents'."
1664 (setq package-archive-contents nil)
1665 (setq package--old-archive-priorities package-archive-priorities)
1666 (dolist (archive package-archives)
1667 (run-hook-with-args 'package-read-archive-hook (car archive))))
1668
1669
1670;;;; Package Initialize
1671;; A bit of a milestone. This brings together some of the above
1672;; sections and populates all relevant lists of packages from contents
1673;; available on disk.
1674
1675(defvar package--initialized nil
1676 "Non-nil if `package-initialize' has been run.")
1677
1678;;;###autoload
1679(defvar package--activated nil
1680 "Non-nil if `package-activate-all' has been run.")
1681
1682;;;###autoload
1683(defun package-initialize (&optional no-activate)
1684 "Load Emacs Lisp packages, and activate them.
1685The variable `package-load-list' controls which packages to load.
1686If optional arg NO-ACTIVATE is non-nil, don't activate packages.
1687
1688It is not necessary to adjust `load-path' or `require' the
1689individual packages after calling `package-initialize' -- this is
1690taken care of by `package-initialize'.
1691
1692If `package-initialize' is called twice during Emacs startup,
1693signal a warning, since this is a bad idea except in highly
1694advanced use cases. To suppress the warning, remove the
1695superfluous call to `package-initialize' from your init-file. If
1696you have code which must run before `package-initialize', put
1697that code in the early init-file."
1698 (interactive)
1699 (when (and package--initialized (not after-init-time))
1700 (lwarn '(package reinitialization) :warning
1701 "Unnecessary call to `package-initialize' in init file"))
1702 (setq package-alist nil)
1703 (package-load-all-descriptors)
1704 (package-read-all-archive-contents)
1705 (setq package--initialized t)
1706 (unless no-activate
1707 (package-activate-all))
1708 ;; This uses `package--mapc' so it must be called after
1709 ;; `package--initialized' is t.
1710 (package--build-compatibility-table))
1711
1712;;;###autoload
1713(progn ;; Make the function usable without loading `package.el'.
1714(defun package-activate-all ()
1715 "Activate all installed packages.
1716The variable `package-load-list' controls which packages to load."
1717 (setq package--activated t)
1718 (let* ((elc (concat package-quickstart-file "c"))
1719 (qs (if (file-readable-p elc) elc
1720 (if (file-readable-p package-quickstart-file)
1721 package-quickstart-file))))
1722 ;; The quickstart file presumes that it has a blank slate,
1723 ;; so don't use it if we already activated some packages.
1724 (or (and qs (not (bound-and-true-p package-activated-list))
1725 ;; Skip `load-source-file-function' which would slow us down by
1726 ;; a factor 2 when loading the .el file (this assumes we were
1727 ;; careful to save this file so it doesn't need any decoding).
1728 (with-demoted-errors "Error during quickstart: %S"
1729 (let ((load-source-file-function nil))
1730 (unless (boundp 'package-activated-list)
1731 (setq package-activated-list nil))
1732 (load qs nil 'nomessage)
1733 t)))
1734 (progn
1735 (require 'package)
1736 ;; Silence the "unknown function" warning when this is compiled
1737 ;; inside `loaddefs.el'.
1738 ;; FIXME: We use `with-no-warnings' because the effect of
1739 ;; `declare-function' is currently not scoped, so if we use
1740 ;; it here, we end up with a redefinition warning instead :-)
1741 (with-no-warnings
1742 (package--activate-all)))))))
1743
1744(defun package--activate-all ()
1745 (dolist (elt (package--alist))
1746 (condition-case err
1747 (package-activate (car elt))
1748 ;; Don't let failure of activation of a package arbitrarily stop
1749 ;; activation of further packages.
1750 (error (message "%s" (error-message-string err))))))
1751
1752;;;; Populating `package-archive-contents' from archives
1753;; This subsection populates the variables listed above from the
1754;; actual archives, instead of from a local cache.
1755
1756(defvar package--downloads-in-progress nil
1757 "List of in-progress asynchronous downloads.")
1758
1759(declare-function epg-import-keys-from-file "epg" (context keys))
1760
1761;;;###autoload
1762(defun package-import-keyring (&optional file)
1763 "Import keys from FILE."
1764 (interactive "fFile: ")
1765 (setq file (expand-file-name file))
1766 (let ((context (epg-make-context 'OpenPGP)))
1767 (when package-gnupghome-dir
1768 (with-file-modes #o700
1769 (make-directory package-gnupghome-dir t))
1770 (setf (epg-context-home-directory context) package-gnupghome-dir))
1771 (message "Importing %s..." (file-name-nondirectory file))
1772 (epg-import-keys-from-file context file)
1773 (message "Importing %s...done" (file-name-nondirectory file))))
1774
1775(defvar package--post-download-archives-hook nil
1776 "Hook run after the archive contents are downloaded.
1777Don't run this hook directly. It is meant to be run as part of
1778`package--update-downloads-in-progress'.")
1779(put 'package--post-download-archives-hook 'risky-local-variable t)
1780
1781(defun package--update-downloads-in-progress (entry)
1782 "Remove ENTRY from `package--downloads-in-progress'.
1783Once it's empty, run `package--post-download-archives-hook'."
1784 ;; Keep track of the downloading progress.
1785 (setq package--downloads-in-progress
1786 (remove entry package--downloads-in-progress))
1787 ;; If this was the last download, run the hook.
1788 (unless package--downloads-in-progress
1789 (package-read-all-archive-contents)
1790 (package--build-compatibility-table)
1791 ;; We message before running the hook, so the hook can give
1792 ;; messages as well.
1793 (message "Package refresh done")
1794 (run-hooks 'package--post-download-archives-hook)))
1795
1796(defun package--download-one-archive (archive file &optional async)
1797 "Retrieve an archive file FILE from ARCHIVE, and cache it.
1798ARCHIVE should be a cons cell of the form (NAME . LOCATION),
1799similar to an entry in `package-alist'. Save the cached copy to
1800\"archives/NAME/FILE\" in `package-user-dir'."
1801 ;; The downloaded archive contents will be read as part of
1802 ;; `package--update-downloads-in-progress'.
1803 (when async
1804 (cl-pushnew (cons archive file) package--downloads-in-progress
1805 :test #'equal))
1806 (package--with-response-buffer (cdr archive) :file file
1807 :async async
1808 :error-form (package--update-downloads-in-progress (cons archive file))
1809 (let* ((location (cdr archive))
1810 (name (car archive))
1811 (content (buffer-string))
1812 (dir (expand-file-name (concat "archives/" name) package-user-dir))
1813 (local-file (expand-file-name file dir)))
1814 (when (listp (read content))
1815 (make-directory dir t)
1816 (if (or (not (package-check-signature))
1817 (member name package-unsigned-archives))
1818 ;; If we don't care about the signature, save the file and
1819 ;; we're done.
1820 (progn
1821 (cl-assert (not enable-multibyte-characters))
1822 (let ((coding-system-for-write 'binary))
1823 (write-region content nil local-file nil 'silent))
1824 (package--update-downloads-in-progress (cons archive file)))
1825 ;; If we care, check it (perhaps async) and *then* write the file.
1826 (package--check-signature
1827 location file content async
1828 ;; This function will be called after signature checking.
1829 (lambda (&optional good-sigs)
1830 (cl-assert (not enable-multibyte-characters))
1831 (let ((coding-system-for-write 'binary))
1832 (write-region content nil local-file nil 'silent))
1833 ;; Write out good signatures into archive-contents.signed file.
1834 (when good-sigs
1835 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
1836 nil (concat local-file ".signed") nil 'silent)))
1837 (lambda () (package--update-downloads-in-progress (cons archive file)))))))))
1838
1839(defun package--download-and-read-archives (&optional async)
1840 "Download descriptions of all `package-archives' and read them.
1841Populate `package-archive-contents' with the result.
1842
1843If optional argument ASYNC is non-nil, perform the downloads
1844asynchronously."
1845 (dolist (archive package-archives)
1846 (condition-case-unless-debug err
1847 (package--download-one-archive archive "archive-contents" async)
1848 (error (message "Failed to download `%s' archive: %s"
1849 (car archive)
1850 (error-message-string err))))))
1851
1852(defvar package-refresh-contents-hook (list #'package--download-and-read-archives)
1853 "List of functions to call to refresh the package archive.
1854Each function may take an optional argument indicating that the
1855operation ought to be executed asynchronously.")
1856
1857;;;###autoload
1858(defun package-refresh-contents (&optional async)
1859 "Download descriptions of all configured ELPA packages.
1860For each archive configured in the variable `package-archives',
1861inform Emacs about the latest versions of all packages it offers,
1862and make them available for download.
1863Optional argument ASYNC specifies whether to perform the
1864downloads in the background. This is always the case when the command
1865is invoked interactively."
1866 (interactive (list t))
1867 (when async
1868 (message "Refreshing package contents..."))
1869 (unless (file-exists-p package-user-dir)
1870 (make-directory package-user-dir t))
1871 (let ((default-keyring (expand-file-name "package-keyring.gpg"
1872 data-directory))
1873 (inhibit-message (or inhibit-message async)))
1874 (when (and (package-check-signature) (file-exists-p default-keyring))
1875 (condition-case-unless-debug error
1876 (package-import-keyring default-keyring)
1877 (error (message "Cannot import default keyring: %s"
1878 (error-message-string error))))))
1879 (run-hook-with-args 'package-refresh-contents-hook async))
1880
1881
1882;;; Dependency Management
1883;; Calculating the full transaction necessary for an installation,
1884;; keeping track of which packages were installed strictly as
1885;; dependencies, and determining which packages cannot be removed
1886;; because they are dependencies.
1887
1888(defun package-compute-transaction (packages requirements &optional seen)
1889 "Return a list of packages to be installed, including PACKAGES.
1890PACKAGES should be a list of `package-desc'.
1891
1892REQUIREMENTS should be a list of additional requirements; each
1893element in this list should have the form (PACKAGE VERSION-LIST),
1894where PACKAGE is a package name and VERSION-LIST is the required
1895version of that package.
1896
1897This function recursively computes the requirements of the
1898packages in REQUIREMENTS, and returns a list of all the packages
1899that must be installed. Packages that are already installed are
1900not included in this list.
1901
1902SEEN is used internally to detect infinite recursion."
1903 ;; FIXME: We really should use backtracking to explore the whole
1904 ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1
1905 ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0:
1906 ;; the current code might fail to see that it could install foo by using the
1907 ;; older bar-1.3).
1908 (dolist (elt requirements)
1909 (let* ((next-pkg (car elt))
1910 (next-version (cadr elt))
1911 (already ()))
1912 (dolist (pkg packages)
1913 (if (eq next-pkg (package-desc-name pkg))
1914 (setq already pkg)))
1915 (when already
1916 (if (version-list-<= next-version (package-desc-version already))
1917 ;; `next-pkg' is already in `packages', but its position there
1918 ;; means it might be installed too late: remove it from there, so
1919 ;; we re-add it (along with its dependencies) at an earlier place
1920 ;; below (bug#16994).
1921 (if (memq already seen) ;Avoid inf-loop on dependency cycles.
1922 (message "Dependency cycle going through %S"
1923 (package-desc-full-name already))
1924 (setq packages (delq already packages))
1925 (setq already nil))
1926 (error "Need package `%s-%s', but only %s is being installed"
1927 next-pkg (package-version-join next-version)
1928 (package-version-join (package-desc-version already)))))
1929 (cond
1930 (already nil)
1931 ((package-installed-p next-pkg next-version) nil)
1932
1933 (t
1934 ;; A package is required, but not installed. It might also be
1935 ;; blocked via `package-load-list'.
1936 (let ((pkg-descs (cdr (assq next-pkg package-archive-contents)))
1937 (found nil)
1938 (found-something nil)
1939 (problem nil))
1940 (while (and pkg-descs (not found))
1941 (let* ((pkg-desc (pop pkg-descs))
1942 (version (package-desc-version pkg-desc))
1943 (disabled (package-disabled-p next-pkg version)))
1944 (cond
1945 ((version-list-< version next-version)
1946 ;; pkg-descs is sorted by priority, not version, so
1947 ;; don't error just yet.
1948 (unless found-something
1949 (setq found-something (package-version-join version))))
1950 (disabled
1951 (unless problem
1952 (setq problem
1953 (if (stringp disabled)
1954 (format-message
1955 "Package `%s' held at version %s, but version %s required"
1956 next-pkg disabled
1957 (package-version-join next-version))
1958 (format-message "Required package `%s' is disabled"
1959 next-pkg)))))
1960 (t (setq found pkg-desc)))))
1961 (unless found
1962 (cond
1963 (problem (error "%s" problem))
1964 (found-something
1965 (error "Need package `%s-%s', but only %s is available"
1966 next-pkg (package-version-join next-version)
1967 found-something))
1968 (t
1969 (if (eq next-pkg 'emacs)
1970 (error "This package requires Emacs version %s"
1971 (package-version-join next-version))
1972 (error (if (not next-version)
1973 (format "Package `%s' is unavailable" next-pkg)
1974 (format "Package `%s' (version %s) is unavailable"
1975 next-pkg (package-version-join next-version))))))))
1976 (setq packages
1977 (package-compute-transaction (cons found packages)
1978 (package-desc-reqs found)
1979 (cons found seen))))))))
1980 packages)
1981
1982(defun package--find-non-dependencies ()
1983 "Return a list of installed packages which are not dependencies.
1984Finds all packages in `package-alist' which are not dependencies
1985of any other packages.
1986Used to populate `package-selected-packages'."
1987 (let ((dep-list
1988 (delete-dups
1989 (apply #'append
1990 (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p))))
1991 package-alist)))))
1992 (cl-loop for p in package-alist
1993 for name = (car p)
1994 unless (memq name dep-list)
1995 collect name)))
1996
1997(defun package--save-selected-packages (&optional value)
1998 "Set and save `package-selected-packages' to VALUE."
1999 (when (or value after-init-time)
2000 ;; It is valid to set it to nil, for example when the last package
2001 ;; is uninstalled. But it shouldn't be done at init time, to
2002 ;; avoid overwriting configurations that haven't yet been loaded.
2003 (setq package-selected-packages (sort value #'string<)))
2004 (if after-init-time
2005 (customize-save-variable 'package-selected-packages package-selected-packages)
2006 (add-hook 'after-init-hook #'package--save-selected-packages)))
2007
2008(defun package--user-selected-p (pkg)
2009 "Return non-nil if PKG is a package was installed by the user.
2010PKG is a package name.
2011This looks into `package-selected-packages', populating it first
2012if it is still empty."
2013 (unless (consp package-selected-packages)
2014 (package--save-selected-packages (package--find-non-dependencies)))
2015 (memq pkg package-selected-packages))
2016
2017(defun package--get-deps (pkgs)
2018 (let ((seen '()))
2019 (while pkgs
2020 (let ((pkg (pop pkgs)))
2021 (if (memq pkg seen)
2022 nil ;; Done already!
2023 (let ((pkg-desc (cadr (assq pkg package-alist))))
2024 (when pkg-desc
2025 (push pkg seen)
2026 (setq pkgs (append (mapcar #'car (package-desc-reqs pkg-desc))
2027 pkgs)))))))
2028 seen))
2029
2030(defun package--user-installed-p (package)
2031 "Return non-nil if PACKAGE is a user-installed package.
2032PACKAGE is the package name, a symbol. Check whether the package
2033was installed into `package-user-dir' where we assume to have
2034control over."
2035 (let* ((pkg-desc (cadr (assq package package-alist)))
2036 (dir (package-desc-dir pkg-desc)))
2037 (file-in-directory-p dir package-user-dir)))
2038
2039(defun package--removable-packages ()
2040 "Return a list of names of packages no longer needed.
2041These are packages which are neither contained in
2042`package-selected-packages' nor a dependency of one that is."
2043 (let ((needed (package--get-deps package-selected-packages)))
2044 (cl-loop for p in (mapcar #'car package-alist)
2045 unless (or (memq p needed)
2046 ;; Do not auto-remove external packages.
2047 (not (package--user-installed-p p)))
2048 collect p)))
2049
2050(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all)
2051 "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST.
2052Return the first package found in PKG-LIST of which PKG is a
2053dependency. If ALL is non-nil, return all such packages instead.
2054
2055When not specified, PKG-LIST defaults to `package-alist'
2056with PKG-DESC entry removed."
2057 (unless (string= (package-desc-status pkg-desc) "obsolete")
2058 (let* ((pkg (package-desc-name pkg-desc))
2059 (alist (or pkg-list
2060 (remove (assq pkg package-alist)
2061 package-alist))))
2062 (if all
2063 (cl-loop for p in alist
2064 if (assq pkg (package-desc-reqs (cadr p)))
2065 collect (cadr p))
2066 (cl-loop for p in alist thereis
2067 (and (assq pkg (package-desc-reqs (cadr p)))
2068 (cadr p)))))))
2069
2070(defun package--sort-deps-in-alist (package only)
2071 "Return a list of dependencies for PACKAGE sorted by dependency.
2072PACKAGE is included as the first element of the returned list.
2073ONLY is an alist associating package names to package objects.
2074Only these packages will be in the return value and their cdrs are
2075destructively set to nil in ONLY."
2076 (let ((out))
2077 (dolist (dep (package-desc-reqs package))
2078 (when-let* ((cell (assq (car dep) only))
2079 (dep-package (cdr-safe cell)))
2080 (setcdr cell nil)
2081 (setq out (append (package--sort-deps-in-alist dep-package only)
2082 out))))
2083 (cons package out)))
2084
2085(defun package--sort-by-dependence (package-list)
2086 "Return PACKAGE-LIST sorted by dependence.
2087That is, any element of the returned list is guaranteed to not
2088directly depend on any elements that come before it.
2089
2090PACKAGE-LIST is a list of `package-desc' objects.
2091Indirect dependencies are guaranteed to be returned in order only
2092if all the in-between dependencies are also in PACKAGE-LIST."
2093 (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list))
2094 out-list)
2095 (dolist (cell alist out-list)
2096 ;; `package--sort-deps-in-alist' destructively changes alist, so
2097 ;; some cells might already be empty. We check this here.
2098 (when-let* ((pkg-desc (cdr cell)))
2099 (setcdr cell nil)
2100 (setq out-list
2101 (append (package--sort-deps-in-alist pkg-desc alist)
2102 out-list))))))
2103
2104
2105;;; Installation Functions
2106;; As opposed to the previous section (which listed some underlying
2107;; functions necessary for installation), this one contains the actual
2108;; functions that install packages. The package itself can be
2109;; installed in a variety of ways (archives, buffer, file), but
2110;; requirements (dependencies) are always satisfied by looking in
2111;; `package-archive-contents'.
2112
2113(defun package-archive-base (desc)
2114 "Return the package described by DESC."
2115 (cdr (assoc (package-desc-archive desc) package-archives)))
2116
2117(defun package-install-from-archive (pkg-desc)
2118 "Download and install a package defined by PKG-DESC."
2119 ;; This won't happen, unless the archive is doing something wrong.
2120 (when (eq (package-desc-kind pkg-desc) 'dir)
2121 (error "Can't install directory package from archive"))
2122 (let* ((location (package-archive-base pkg-desc))
2123 (file (concat (package-desc-full-name pkg-desc)
2124 (package-desc-suffix pkg-desc))))
2125 (package--with-response-buffer location :file file
2126 (if (or (not (package-check-signature))
2127 (member (package-desc-archive pkg-desc)
2128 package-unsigned-archives))
2129 ;; If we don't care about the signature, unpack and we're
2130 ;; done.
2131 (let ((save-silently t))
2132 (package-unpack pkg-desc))
2133 ;; If we care, check it and *then* write the file.
2134 (let ((content (buffer-string)))
2135 (package--check-signature
2136 location file content nil
2137 ;; This function will be called after signature checking.
2138 (lambda (&optional good-sigs)
2139 ;; Signature checked, unpack now.
2140 (with-temp-buffer ;FIXME: Just use the previous current-buffer.
2141 (set-buffer-multibyte nil)
2142 (cl-assert (not (multibyte-string-p content)))
2143 (insert content)
2144 (let ((save-silently t))
2145 (package-unpack pkg-desc)))
2146 ;; Here the package has been installed successfully, mark it as
2147 ;; signed if appropriate.
2148 (when good-sigs
2149 ;; Write out good signatures into NAME-VERSION.signed file.
2150 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
2151 nil
2152 (expand-file-name
2153 (concat (package-desc-full-name pkg-desc) ".signed")
2154 package-user-dir)
2155 nil 'silent)
2156 ;; Update the old pkg-desc which will be shown on the description buffer.
2157 (setf (package-desc-signed pkg-desc) t)
2158 ;; Update the new (activated) pkg-desc as well.
2159 (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc)
2160 package-alist))))
2161 (setf (package-desc-signed (car pkg-descs)) t))))))))))
2162
2163;;;###autoload
2164(defun package-installed-p (package &optional min-version)
2165 "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed.
2166If PACKAGE is a symbol, it is the package name and MIN-VERSION
2167should be a version list.
2168
2169If PACKAGE is a `package-desc' object, MIN-VERSION is ignored."
2170 (cond
2171 ((package-desc-p package)
2172 (let ((dir (package-desc-dir package)))
2173 (and (stringp dir)
2174 (file-exists-p dir))))
2175 ((and (not package--initialized)
2176 (null min-version)
2177 package-activated-list)
2178 ;; We used the quickstart: make it possible to use package-installed-p
2179 ;; even before package is fully initialized.
2180 (or
2181 (memq package package-activated-list)
2182 ;; Also check built-in packages.
2183 (package-built-in-p package min-version)))
2184 (t
2185 (or
2186 (let ((pkg-descs (cdr (assq package (package--alist)))))
2187 (and pkg-descs
2188 (version-list-<= min-version
2189 (package-desc-version (car pkg-descs)))))
2190 ;; Also check built-in packages.
2191 (package-built-in-p package min-version)))))
2192
2193(defun package-download-transaction (packages)
2194 "Download and install all the packages in PACKAGES.
2195PACKAGES should be a list of `package-desc'.
2196This function assumes that all package requirements in
2197PACKAGES are satisfied, i.e. that PACKAGES is computed
2198using `package-compute-transaction'."
2199 (mapc #'package-install-from-archive packages))
2200
2201(defun package--archives-initialize ()
2202 "Make sure the list of installed and remote packages are initialized."
2203 (unless package--initialized
2204 (package-initialize t))
2205 (unless package-archive-contents
2206 (package-refresh-contents)))
2207
2208(defcustom package-install-upgrade-built-in nil
2209 "Non-nil means that built-in packages can be upgraded via a package archive.
2210If disabled, then `package-install' will not suggest to replace a
2211built-in package with a (possibly newer) version from a package archive."
2212 :type 'boolean
2213 :version "29.1")
2214
2215;;;###autoload
2216(defun package-install (pkg &optional dont-select)
2217 "Install the package PKG.
2218
2219PKG can be a `package-desc', or a symbol naming one of the available
2220packages in an archive in `package-archives'.
2221
2222Mark the installed package as selected by adding it to
2223`package-selected-packages'.
2224
2225When called from Lisp and optional argument DONT-SELECT is
2226non-nil, install the package but do not add it to
2227`package-selected-packages'.
2228
2229If PKG is a `package-desc' and it is already installed, don't try
2230to install it but still mark it as selected.
2231
2232If the command is invoked with a prefix argument, it will allow
2233upgrading of built-in packages, as if `package-install-upgrade-built-in'
2234had been enabled."
2235 (interactive
2236 (progn
2237 ;; Initialize the package system to get the list of package
2238 ;; symbols for completion.
2239 (package--archives-initialize)
2240 (list (intern (completing-read
2241 "Install package: "
2242 (mapcan
2243 (lambda (elt)
2244 (and (or (and (or current-prefix-arg
2245 package-install-upgrade-built-in)
2246 (package--active-built-in-p (car elt)))
2247 (not (package-installed-p (car elt))))
2248 (list (symbol-name (car elt)))))
2249 package-archive-contents)
2250 nil t))
2251 nil)))
2252 (cl-check-type pkg (or symbol package-desc))
2253 (package--archives-initialize)
2254 (add-hook 'post-command-hook #'package-menu--post-refresh)
2255 (let ((name (if (package-desc-p pkg)
2256 (package-desc-name pkg)
2257 pkg)))
2258 (unless (or dont-select (package--user-selected-p name))
2259 (package--save-selected-packages
2260 (cons name package-selected-packages)))
2261 (when (and (or current-prefix-arg package-install-upgrade-built-in)
2262 (package--active-built-in-p pkg))
2263 (setq pkg (or (cadr (assq name package-archive-contents)) pkg)))
2264 (if-let* ((transaction
2265 (if (package-desc-p pkg)
2266 (unless (package-installed-p pkg)
2267 (package-compute-transaction (list pkg)
2268 (package-desc-reqs pkg)))
2269 (package-compute-transaction () (list (list pkg))))))
2270 (progn
2271 (package-download-transaction transaction)
2272 (package--quickstart-maybe-refresh)
2273 (message "Package `%s' installed." name))
2274 (message "`%s' is already installed" name))))
2275
2276(declare-function package-vc-upgrade "package-vc" (pkg))
2277
2278;;;###autoload
2279(defun package-upgrade (name)
2280 "Upgrade package NAME if a newer version exists.
2281
2282NAME should be a symbol."
2283 (interactive
2284 (list (intern (completing-read
2285 "Upgrade package: "
2286 (package--upgradeable-packages t) nil t))))
2287 (cl-check-type name symbol)
2288 (let* ((pkg-desc (cadr (assq name package-alist)))
2289 (package-install-upgrade-built-in (not pkg-desc)))
2290 ;; `pkg-desc' will be nil when the package is an "active built-in".
2291 (if (and pkg-desc (package-vc-p pkg-desc))
2292 (package-vc-upgrade pkg-desc)
2293 (when pkg-desc
2294 (package-delete pkg-desc 'force 'dont-unselect))
2295 (package-install name
2296 ;; An active built-in has never been "selected"
2297 ;; before. Mark it as installed explicitly.
2298 (and pkg-desc 'dont-select)))))
2299
2300(defun package--upgradeable-packages (&optional include-builtins)
2301 ;; Initialize the package system to get the list of package
2302 ;; symbols for completion.
2303 (package--archives-initialize)
2304 (mapcar
2305 #'car
2306 (seq-filter
2307 (lambda (elt)
2308 (or (let ((available
2309 (assq (car elt) package-archive-contents)))
2310 (and available
2311 (or (and
2312 include-builtins
2313 (not (package-desc-version (cadr elt))))
2314 (version-list-<
2315 (package-desc-version (cadr elt))
2316 (package-desc-version (cadr available))))))
2317 (package-vc-p (cadr elt))))
2318 (if include-builtins
2319 (append package-alist
2320 (mapcan
2321 (lambda (elt)
2322 (when (not (assq (car elt) package-alist))
2323 (list (list (car elt) (package--from-builtin elt)))))
2324 package--builtins))
2325 package-alist))))
2326
2327;;;###autoload
2328(defun package-upgrade-all (&optional query)
2329 "Refresh package list and upgrade all packages.
2330If QUERY, ask the user before upgrading packages. When called
2331interactively, QUERY is always true.
2332
2333Currently, packages which are part of the Emacs distribution are
2334not upgraded by this command. To enable upgrading such a package
2335using this command, first upgrade the package to a newer version
2336from ELPA by either using `\\[package-upgrade]' or
2337`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
2338 (interactive (list (not noninteractive)))
2339 (package-refresh-contents)
2340 (let ((upgradeable (package--upgradeable-packages)))
2341 (if (not upgradeable)
2342 (message "No packages to upgrade")
2343 (when (and query
2344 (not (yes-or-no-p
2345 (if (length= upgradeable 1)
2346 "One package to upgrade. Do it? "
2347 (format "%s packages to upgrade. Do it?"
2348 (length upgradeable))))))
2349 (user-error "Upgrade aborted"))
2350 (mapc #'package-upgrade upgradeable))))
2351
2352(defun package--dependencies (pkg)
2353 "Return a list of all transitive dependencies of PKG.
2354If PKG is a package descriptor, the return value is a list of
2355package descriptors. If PKG is a symbol designating a package,
2356the return value is a list of symbols designating packages."
2357 (when-let* ((desc (if (package-desc-p pkg) pkg
2358 (cadr (assq pkg package-archive-contents)))))
2359 ;; Can we have circular dependencies? Assume "nope".
2360 (let ((all (named-let more ((pkg-desc desc))
2361 (let (deps)
2362 (dolist (req (package-desc-reqs pkg-desc))
2363 (setq deps (nconc
2364 (catch 'found
2365 (dolist (p (apply #'append (mapcar #'cdr (package--alist))))
2366 (when (and (string= (car req) (package-desc-name p))
2367 (version-list-<= (cadr req) (package-desc-version p)))
2368 (throw 'found (more p)))))
2369 deps)))
2370 (delete-dups (cons pkg-desc deps))))))
2371 (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all)))))
2372
2373(defun package-strip-rcs-id (str)
2374 "Strip RCS version ID from the version string STR.
2375If the result looks like a dotted numeric version, return it.
2376Otherwise return nil."
2377 (when str
2378 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
2379 (setq str (substring str (match-end 0))))
2380 (let ((l (version-to-list str)))
2381 ;; Don't return `str' but (package-version-join (version-to-list str))
2382 ;; to make sure we use a "canonical name"!
2383 (if l (package-version-join l)))))
2384
2385(declare-function lm-website "lisp-mnt" (&optional file))
2386
2387;;;###autoload
2388(defun package-install-from-buffer ()
2389 "Install a package from the current buffer.
2390The current buffer is assumed to be a single .el or .tar file or
2391a directory. These must follow the packaging guidelines (see
2392info node `(elisp)Packaging').
2393
2394Specially, if current buffer is a directory, the -pkg.el
2395description file is not mandatory, in which case the information
2396is derived from the main .el file in the directory. Using Dired,
2397you can restrict what files to install by marking specific files.
2398
2399Downloads and installs required packages as needed."
2400 (interactive)
2401 (let* ((pkg-desc
2402 (cond
2403 ((derived-mode-p 'dired-mode)
2404 ;; This is the only way a package-desc object with a `dir'
2405 ;; desc-kind can be created. Such packages can't be
2406 ;; uploaded or installed from archives, they can only be
2407 ;; installed from local buffers or directories.
2408 (package-dir-info))
2409 ((derived-mode-p 'tar-mode)
2410 (package-tar-file-info))
2411 (t
2412 ;; Package headers should be parsed from decoded text
2413 ;; (see Bug#48137) where possible.
2414 (if (and (eq buffer-file-coding-system 'no-conversion)
2415 buffer-file-name)
2416 (let* ((package-buffer (current-buffer))
2417 (decoding-system
2418 (car (find-operation-coding-system
2419 'insert-file-contents
2420 (cons buffer-file-name
2421 package-buffer)))))
2422 (with-temp-buffer
2423 (insert-buffer-substring package-buffer)
2424 (decode-coding-region (point-min) (point-max)
2425 decoding-system)
2426 (package-buffer-info)))
2427
2428 (save-excursion
2429 (package-buffer-info))))))
2430 (name (package-desc-name pkg-desc)))
2431 ;; Download and install the dependencies.
2432 (let* ((requires (package-desc-reqs pkg-desc))
2433 (transaction (package-compute-transaction nil requires)))
2434 (package-download-transaction transaction))
2435 ;; Install the package itself.
2436 (package-unpack pkg-desc)
2437 (unless (package--user-selected-p name)
2438 (package--save-selected-packages
2439 (cons name package-selected-packages)))
2440 (package--quickstart-maybe-refresh)
2441 pkg-desc))
2442
2443;;;###autoload
2444(defun package-install-file (file)
2445 "Install a package from FILE.
2446The file can either be a tar file, an Emacs Lisp file, or a
2447directory."
2448 (interactive "fPackage file name: ")
2449 (with-temp-buffer
2450 (if (file-directory-p file)
2451 (progn
2452 (setq default-directory file)
2453 (dired-mode))
2454 (insert-file-contents-literally file)
2455 (set-visited-file-name file)
2456 (set-buffer-modified-p nil)
2457 (when (string-match "\\.tar\\'" file) (tar-mode)))
2458 (package-install-from-buffer)))
2459
2460;;;###autoload
2461(defun package-install-selected-packages (&optional noconfirm)
2462 "Ensure packages in `package-selected-packages' are installed.
2463If some packages are not installed, propose to install them.
2464
2465If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
2466argument, don't ask for confirmation to install packages."
2467 (interactive "P")
2468 (package--archives-initialize)
2469 ;; We don't need to populate `package-selected-packages' before
2470 ;; using here, because the outcome is the same either way (nothing
2471 ;; gets installed).
2472 (if (not package-selected-packages)
2473 (message "`package-selected-packages' is empty, nothing to install")
2474 (let* ((not-installed (seq-remove #'package-installed-p package-selected-packages))
2475 (available (seq-filter (lambda (p) (assq p package-archive-contents)) not-installed))
2476 (difference (- (length not-installed) (length available))))
2477 (cond
2478 (available
2479 (when (or noconfirm
2480 (y-or-n-p
2481 (format "Packages to install: %d (%s), proceed? "
2482 (length available)
2483 (mapconcat #'symbol-name available " "))))
2484 (mapc (lambda (p) (package-install p 'dont-select)) available)))
2485 ((> difference 0)
2486 (message (substitute-command-keys
2487 "Packages that are not available: %d (the rest is already \
2488installed), maybe you need to \\[package-refresh-contents]")
2489 difference))
2490 (t
2491 (message "All your packages are already installed"))))))
2492
2493
2494;;; Package Deletion
2495
2496(defun package--newest-p (pkg)
2497 "Return non-nil if PKG is the newest package with its name."
2498 (equal (cadr (assq (package-desc-name pkg) package-alist))
2499 pkg))
2500
2501(declare-function comp-el-to-eln-filename "comp.c")
2502(defvar package-vc-repository-store)
2503(defun package--delete-directory (dir)
2504 "Delete PKG-DESC directory DIR recursively.
2505Clean-up the corresponding .eln files if Emacs is native
2506compiled."
2507 (when (featurep 'native-compile)
2508 (cl-loop
2509 for file in (directory-files-recursively dir
2510 ;; Exclude lockfiles
2511 (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos))
2512 do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
2513 (if (file-symlink-p (directory-file-name dir))
2514 (delete-file (directory-file-name dir))
2515 (delete-directory dir t)))
2516
2517
2518(defun package-delete (pkg-desc &optional force nosave)
2519 "Delete package PKG-DESC.
2520
2521Argument PKG-DESC is the full description of the package, for example as
2522obtained by `package-get-descriptor'. Interactively, prompt the user
2523for the package name and version.
2524
2525When package is used elsewhere as dependency of another package,
2526refuse deleting it and return an error.
2527If prefix argument FORCE is non-nil, package will be deleted even
2528if it is used elsewhere.
2529If NOSAVE is non-nil, the package is not removed from
2530`package-selected-packages'."
2531 (interactive
2532 (progn
2533 (let* ((package-table
2534 (mapcar
2535 (lambda (p) (cons (package-desc-full-name p) p))
2536 (delq nil
2537 (mapcar (lambda (p) (unless (package-built-in-p p) p))
2538 (apply #'append (mapcar #'cdr (package--alist)))))))
2539 (package-name (completing-read "Delete package: "
2540 (mapcar #'car package-table)
2541 nil t)))
2542 (list (cdr (assoc package-name package-table))
2543 current-prefix-arg nil))))
2544 (let* ((dir (package-desc-dir pkg-desc))
2545 (name (package-desc-name pkg-desc))
2546 (new-package-alist (let ((pkgs (assq name package-alist)))
2547 (if (null (remove pkg-desc (cdr pkgs)))
2548 (remq pkgs package-alist)
2549 package-alist)))
2550 pkg-used-elsewhere-by)
2551 ;; If the user is trying to delete this package, they definitely
2552 ;; don't want it marked as selected, so we remove it from
2553 ;; `package-selected-packages' even if it can't be deleted.
2554 (when (and (null nosave)
2555 (package--user-selected-p name)
2556 ;; Don't deselect if this is an older version of an
2557 ;; upgraded package.
2558 (package--newest-p pkg-desc))
2559 (package--save-selected-packages (remove name package-selected-packages)))
2560 (cond ((not (string-prefix-p (file-name-as-directory
2561 (expand-file-name package-user-dir))
2562 (expand-file-name dir)))
2563 ;; Don't delete "system" packages.
2564 (error "Package `%s' is a system package, not deleting"
2565 (package-desc-full-name pkg-desc)))
2566 ((and (null force)
2567 (setq pkg-used-elsewhere-by
2568 (let ((package-alist new-package-alist))
2569 (package--used-elsewhere-p pkg-desc)))) ;See bug#65475
2570 ;; Don't delete packages used as dependency elsewhere.
2571 (error "Package `%s' is used by `%s' as dependency, not deleting"
2572 (package-desc-full-name pkg-desc)
2573 (package-desc-name pkg-used-elsewhere-by)))
2574 (t
2575 (add-hook 'post-command-hook #'package-menu--post-refresh)
2576 (package--delete-directory dir)
2577 ;; Remove NAME-VERSION.signed and NAME-readme.txt files.
2578 ;;
2579 ;; NAME-readme.txt files are no longer created, but they
2580 ;; may be left around from an earlier install.
2581 (dolist (suffix '(".signed" "readme.txt"))
2582 (let* ((version (package-version-join (package-desc-version pkg-desc)))
2583 (file (concat (if (string= suffix ".signed")
2584 dir
2585 (substring dir 0 (- (length version))))
2586 suffix)))
2587 (when (file-exists-p file)
2588 (delete-file file))))
2589 ;; Update package-alist.
2590 (setq package-alist new-package-alist)
2591 (package--quickstart-maybe-refresh)
2592 (message "Package `%s' deleted."
2593 (package-desc-full-name pkg-desc))))))
2594
2595;;;###autoload
2596(defun package-reinstall (pkg)
2597 "Reinstall package PKG.
2598PKG should be either a symbol, the package name, or a `package-desc'
2599object."
2600 (interactive
2601 (progn
2602 (package--archives-initialize)
2603 (list (intern (completing-read
2604 "Reinstall package: "
2605 (mapcar #'symbol-name
2606 (mapcar #'car package-alist)))))))
2607 (package--archives-initialize)
2608 (package-delete
2609 (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist)))
2610 'force 'nosave)
2611 (package-install pkg 'dont-select))
2612
2613;;;###autoload
2614(defun package-recompile (pkg)
2615 "Byte-compile package PKG again.
2616PKG should be either a symbol, the package name, or a `package-desc'
2617object."
2618 (interactive (list (intern (completing-read
2619 "Recompile package: "
2620 (mapcar #'symbol-name
2621 (mapcar #'car package-alist))))))
2622 (let ((pkg-desc (if (package-desc-p pkg)
2623 pkg
2624 (cadr (assq pkg package-alist)))))
2625 ;; Delete the old .elc files to ensure that we don't inadvertently
2626 ;; load them (in case they contain byte code/macros that are now
2627 ;; invalid).
2628 (dolist (elc (directory-files-recursively
2629 (package-desc-dir pkg-desc) "\\.elc\\'"))
2630 (delete-file elc))
2631 (package--compile pkg-desc)))
2632
2633;;;###autoload
2634(defun package-recompile-all ()
2635 "Byte-compile all installed packages.
2636This is meant to be used only in the case the byte-compiled files
2637are invalid due to changed byte-code, macros or the like."
2638 (interactive)
2639 (pcase-dolist (`(_ ,pkg-desc) package-alist)
2640 (with-demoted-errors "Error while recompiling: %S"
2641 (package-recompile pkg-desc))))
2642
2643;;;###autoload
2644(defun package-autoremove (&optional noconfirm)
2645 "Remove packages that are no longer needed.
2646
2647Packages that are no more needed by other packages in
2648`package-selected-packages' and their dependencies
2649will be deleted.
2650
2651If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
2652argument, don't ask for confirmation to install packages."
2653 (interactive "P")
2654 ;; If `package-selected-packages' is nil, it would make no sense to
2655 ;; try to populate it here, because then `package-autoremove' will
2656 ;; do absolutely nothing.
2657 (when (or noconfirm
2658 package-selected-packages
2659 (yes-or-no-p
2660 (format-message
2661 "`package-selected-packages' is empty! Really remove ALL packages? ")))
2662 (let ((removable (package--removable-packages)))
2663 (if removable
2664 (when (or noconfirm
2665 (y-or-n-p
2666 (format "Packages to delete: %d (%s), proceed? "
2667 (length removable)
2668 (mapconcat #'symbol-name removable " "))))
2669 (mapc (lambda (p)
2670 (package-delete (cadr (assq p package-alist)) t))
2671 removable))
2672 (message "Nothing to autoremove")))))
2673
2674(defun package-isolate (packages &optional temp-init)
2675 "Start an uncustomized Emacs and only load a set of PACKAGES.
2676Interactively, prompt for PACKAGES to load, which should be specified
2677separated by commas.
2678If called from Lisp, PACKAGES should be a list of packages to load.
2679If TEMP-INIT is non-nil, or when invoked with a prefix argument,
2680the Emacs user directory is set to a temporary directory.
2681This command is intended for testing Emacs and/or the packages
2682in a clean environment."
2683 (interactive
2684 (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p))
2685 unless (package-built-in-p p)
2686 collect (cons (package-desc-full-name p) p) into table
2687 finally return
2688 (list
2689 (cl-loop for c in
2690 (completing-read-multiple
2691 "Packages to isolate: " table
2692 nil t)
2693 collect (alist-get c table nil nil #'string=))
2694 current-prefix-arg)))
2695 (let* ((name (concat "package-isolate-"
2696 (mapconcat #'package-desc-full-name packages ",")))
2697 (all-packages (delete-consecutive-dups
2698 (sort (append packages (mapcan #'package--dependencies packages))
2699 (lambda (p0 p1)
2700 (string< (package-desc-name p0) (package-desc-name p1))))))
2701 initial-scratch-message package-load-list)
2702 (with-temp-buffer
2703 (insert ";; This is an isolated testing environment, with these packages enabled:\n\n")
2704 (dolist (package all-packages)
2705 (push (list (package-desc-name package)
2706 (package-version-join (package-desc-version package)))
2707 package-load-list)
2708 (insert ";; - " (package-desc-full-name package))
2709 (unless (memq package packages)
2710 (insert " (dependency)"))
2711 (insert "\n"))
2712 (insert "\n")
2713 (setq initial-scratch-message (buffer-string)))
2714 (apply #'start-process (concat "*" name "*") nil
2715 (list (expand-file-name invocation-name invocation-directory)
2716 "--quick" "--debug-init"
2717 "--init-directory" (if temp-init
2718 (make-temp-file name t)
2719 user-emacs-directory)
2720 (format "--eval=%S"
2721 `(progn
2722 (setq initial-scratch-message ,initial-scratch-message)
2723
2724 (require 'package)
2725 ,@(mapcar
2726 (lambda (dir)
2727 `(add-to-list 'package-directory-list ,dir))
2728 (cons package-user-dir package-directory-list))
2729 (setq package-load-list ',package-load-list)
2730 (package-activate-all)))))))
2731
2732
2733;;;; Package description buffer.
2734
2735;;;###autoload
2736(defun describe-package (package)
2737 "Display the full documentation of PACKAGE (a symbol)."
2738 (interactive
2739 (let* ((guess (or (function-called-at-point)
2740 (symbol-at-point))))
2741 (require 'finder-inf nil t)
2742 ;; Load the package list if necessary (but don't activate them).
2743 (unless package--initialized
2744 (package-initialize t))
2745 (let ((packages (append (mapcar #'car package-alist)
2746 (mapcar #'car package-archive-contents)
2747 (mapcar #'car package--builtins))))
2748 (unless (memq guess packages)
2749 (setq guess nil))
2750 (setq packages (mapcar #'symbol-name packages))
2751 (let ((val
2752 (completing-read (format-prompt "Describe package" guess)
2753 packages nil t nil nil (when guess
2754 (symbol-name guess)))))
2755 (list (and (> (length val) 0) (intern val)))))))
2756 (if (not (or (package-desc-p package) (and package (symbolp package))))
2757 (message "No package specified")
2758 (help-setup-xref (list #'describe-package package)
2759 (called-interactively-p 'interactive))
2760 (with-help-window (help-buffer)
2761 (with-current-buffer standard-output
2762 (describe-package-1 package)))))
2763
2764(defface package-help-section-name
2765 '((t :inherit (bold font-lock-function-name-face)))
2766 "Face used on section names in package description buffers."
2767 :version "25.1")
2768
2769(defun package--print-help-section (name &rest strings)
2770 "Print \"NAME: \", right aligned to the 13th column.
2771If more STRINGS are provided, insert them followed by a newline.
2772Otherwise no newline is inserted."
2773 (declare (indent 1))
2774 (insert (make-string (max 0 (- 11 (string-width name))) ?\s)
2775 (propertize (concat name ": ") 'font-lock-face 'package-help-section-name))
2776 (when strings
2777 (apply #'insert strings)
2778 (insert "\n")))
2779
2780(declare-function lm-commentary "lisp-mnt" (&optional file))
2781
2782(defun package--get-description (desc)
2783 "Return a string containing the long description of the package DESC.
2784The description is read from the installed package files."
2785 ;; Installed packages have nil for kind, so we look for README
2786 ;; first, then fall back to the Commentary header.
2787
2788 ;; We don’t include README.md here, because that is often the home
2789 ;; page on a site like github, and not suitable as the package long
2790 ;; description.
2791 (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org"))
2792 file
2793 (srcdir (package-desc-dir desc))
2794 result)
2795 (while (and files
2796 (not result))
2797 (setq file (pop files))
2798 (when (file-readable-p (expand-file-name file srcdir))
2799 ;; Found a README.
2800 (with-temp-buffer
2801 (insert-file-contents (expand-file-name file srcdir))
2802 (setq result (buffer-string)))))
2803
2804 (or
2805 result
2806
2807 ;; Look for Commentary header.
2808 (lm-commentary (expand-file-name
2809 (format "%s.el" (package-desc-name desc)) srcdir))
2810 "")))
2811
2812(defun package--describe-add-library-links ()
2813 "Add links to library names in package description."
2814 (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
2815 (if (locate-library (match-string 1))
2816 (make-text-button (match-beginning 1) (match-end 1)
2817 'xref (match-string-no-properties 1)
2818 'help-echo "Read this file's commentary"
2819 :type 'package--finder-xref))))
2820
2821(defun describe-package-1 (pkg)
2822 "Insert the package description for PKG.
2823Helper function for `describe-package'."
2824 (require 'lisp-mnt)
2825 (let* ((desc (or
2826 (if (package-desc-p pkg) pkg)
2827 (cadr (assq pkg package-alist))
2828 (let ((built-in (assq pkg package--builtins)))
2829 (if built-in
2830 (package--from-builtin built-in)
2831 (cadr (assq pkg package-archive-contents))))))
2832 (name (if desc (package-desc-name desc) pkg))
2833 (pkg-dir (if desc (package-desc-dir desc)))
2834 (reqs (if desc (package-desc-reqs desc)))
2835 (required-by (if desc (package--used-elsewhere-p desc nil 'all)))
2836 (version (if desc (package-desc-version desc)))
2837 (archive (if desc (package-desc-archive desc)))
2838 (extras (and desc (package-desc-extras desc)))
2839 (website (cdr (assoc :url extras)))
2840 (commit (cdr (assoc :commit extras)))
2841 (keywords (if desc (package-desc--keywords desc)))
2842 (built-in (eq pkg-dir 'builtin))
2843 (installable (and archive (not built-in)))
2844 (status (if desc (package-desc-status desc) "orphan"))
2845 (incompatible-reason (package--incompatible-p desc))
2846 (signed (if desc (package-desc-signed desc)))
2847 (maintainers (or (cdr (assoc :maintainer extras))
2848 (cdr (assoc :maintainers extras))))
2849 (authors (cdr (assoc :authors extras)))
2850 (news (and-let* (pkg-dir
2851 ((not built-in))
2852 (file (expand-file-name "news" pkg-dir))
2853 ((file-regular-p file))
2854 ((file-readable-p file)))
2855 file)))
2856 (when (string= status "avail-obso")
2857 (setq status "available obsolete"))
2858 (when incompatible-reason
2859 (setq status "incompatible"))
2860 (princ (format "Package %S is %s.\n\n" name status))
2861
2862 ;; TODO: Remove the string decorations and reformat the strings
2863 ;; for future l10n.
2864 (package--print-help-section "Status")
2865 (cond (built-in
2866 (insert (propertize (capitalize status)
2867 'font-lock-face 'package-status-built-in)
2868 "."))
2869 (pkg-dir
2870 (insert (propertize (if (member status '("unsigned" "dependency"))
2871 "Installed"
2872 (capitalize status))
2873 'font-lock-face 'package-status-built-in))
2874 (insert (substitute-command-keys " in `"))
2875 (let ((dir (abbreviate-file-name
2876 (file-name-as-directory
2877 (if (file-in-directory-p pkg-dir package-user-dir)
2878 (file-relative-name pkg-dir package-user-dir)
2879 pkg-dir)))))
2880 (help-insert-xref-button dir 'help-package-def pkg-dir))
2881 (if (and (package-built-in-p name)
2882 (not (package-built-in-p name version)))
2883 (insert (substitute-command-keys
2884 "',\n shadowing a ")
2885 (propertize "built-in package"
2886 'font-lock-face 'package-status-built-in))
2887 (insert (substitute-quotes "'")))
2888 (if signed
2889 (insert ".")
2890 (insert " (unsigned)."))
2891 (when (and (package-desc-p desc)
2892 (not required-by)
2893 (member status '("unsigned" "installed")))
2894 (insert " ")
2895 (package-make-button "Delete"
2896 'action #'package-delete-button-action
2897 'package-desc desc)))
2898 (incompatible-reason
2899 (insert (propertize "Incompatible" 'font-lock-face 'font-lock-warning-face)
2900 " because it depends on ")
2901 (if (stringp incompatible-reason)
2902 (insert "Emacs " incompatible-reason ".")
2903 (insert "uninstallable packages.")))
2904 (installable
2905 (insert (capitalize status))
2906 (insert " from " (format "%s" archive))
2907 (insert " -- ")
2908 (package-make-button
2909 "Install"
2910 'action 'package-install-button-action
2911 'package-desc desc))
2912 (t (insert (capitalize status) ".")))
2913 (insert "\n")
2914 (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive.
2915 (package--print-help-section "Archive"
2916 (or archive "n/a")))
2917 (and version
2918 (package--print-help-section "Version"
2919 (package-version-join version)))
2920 (when commit
2921 (package--print-help-section "Commit" commit))
2922 (when desc
2923 (package--print-help-section "Summary"
2924 (package-desc-summary desc)))
2925
2926 (setq reqs (if desc (package-desc-reqs desc)))
2927 (when reqs
2928 (package--print-help-section "Requires")
2929 (let ((first t))
2930 (dolist (req reqs)
2931 (let* ((name (car req))
2932 (vers (cadr req))
2933 (text (format "%s-%s" (symbol-name name)
2934 (package-version-join vers)))
2935 (reason (if (and (listp incompatible-reason)
2936 (assq name incompatible-reason))
2937 " (not available)" "")))
2938 (cond (first (setq first nil))
2939 ((>= (+ 2 (current-column) (length text) (length reason))
2940 (window-width))
2941 (insert ",\n "))
2942 (t (insert ", ")))
2943 (help-insert-xref-button text 'help-package name)
2944 (insert reason)))
2945 (insert "\n")))
2946 (when required-by
2947 (package--print-help-section "Required by")
2948 (let ((first t))
2949 (dolist (pkg required-by)
2950 (let ((text (package-desc-full-name pkg)))
2951 (cond (first (setq first nil))
2952 ((>= (+ 2 (current-column) (length text))
2953 (window-width))
2954 (insert ",\n "))
2955 (t (insert ", ")))
2956 (help-insert-xref-button text 'help-package
2957 (package-desc-name pkg))))
2958 (insert "\n")))
2959 (when website
2960 ;; Prefer https for the website of packages on common domains.
2961 (when (string-match-p (rx bol "http://" (or "elpa." "www." "git." "")
2962 (or "nongnu.org" "gnu.org" "sr.ht"
2963 "emacswiki.org" "gitlab.com" "github.com")
2964 "/")
2965 website)
2966 ;; But only if the user has "https" in `package-archives'.
2967 (let ((gnu (cdr (assoc "gnu" package-archives))))
2968 (and gnu (string-match-p "^https" gnu)
2969 (setq website
2970 (replace-regexp-in-string "^http" "https" website)))))
2971 (package--print-help-section "Website")
2972 (help-insert-xref-button website 'help-url website)
2973 (insert "\n"))
2974 (when keywords
2975 (package--print-help-section "Keywords")
2976 (dolist (k keywords)
2977 (package-make-button
2978 k
2979 'package-keyword k
2980 'action 'package-keyword-button-action)
2981 (insert " "))
2982 (insert "\n"))
2983 (when maintainers
2984 (unless (and (listp (car maintainers)) (listp (cdr maintainers)))
2985 (setq maintainers (list maintainers)))
2986 (package--print-help-section
2987 (if (cdr maintainers) "Maintainers" "Maintainer"))
2988 (dolist (maintainer maintainers)
2989 (when (bolp)
2990 (insert (make-string 13 ?\s)))
2991 (package--print-email-button maintainer)))
2992 (when authors
2993 (package--print-help-section (if (cdr authors) "Authors" "Author"))
2994 (dolist (author authors)
2995 (when (bolp)
2996 (insert (make-string 13 ?\s)))
2997 (package--print-email-button author)))
2998 (let* ((all-pkgs (append (cdr (assq name package-alist))
2999 (cdr (assq name package-archive-contents))
3000 (let ((bi (assq name package--builtins)))
3001 (if bi (list (package--from-builtin bi))))))
3002 (other-pkgs (delete desc all-pkgs)))
3003 (when other-pkgs
3004 (package--print-help-section "Other versions"
3005 (mapconcat (lambda (opkg)
3006 (let* ((ov (package-desc-version opkg))
3007 (dir (package-desc-dir opkg))
3008 (from (or (package-desc-archive opkg)
3009 (if (stringp dir) "installed" dir))))
3010 (if (not ov) (format "%s" from)
3011 (format "%s (%s)"
3012 (make-text-button (package-version-join ov) nil
3013 'font-lock-face 'link
3014 'follow-link t
3015 'action
3016 (lambda (_button)
3017 (describe-package opkg)))
3018 from))))
3019 other-pkgs ", ")
3020 ".")))
3021
3022 (insert "\n")
3023
3024 (let ((start-of-description (point)))
3025 (if built-in
3026 ;; For built-in packages, get the description from the
3027 ;; Commentary header.
3028 (insert (or (lm-commentary (locate-file (format "%s.el" name)
3029 load-path
3030 load-file-rep-suffixes))
3031 ""))
3032
3033 (if (package-installed-p desc)
3034 ;; For installed packages, get the description from the
3035 ;; installed files.
3036 (insert (package--get-description desc))
3037
3038 ;; For non-built-in, non-installed packages, get description from
3039 ;; the archive.
3040 (let* ((basename (format "%s-readme.txt" name))
3041 readme-string)
3042
3043 (package--with-response-buffer (package-archive-base desc)
3044 :file basename :noerror t
3045 (save-excursion
3046 (goto-char (point-max))
3047 (unless (bolp)
3048 (insert ?\n)))
3049 (cl-assert (not enable-multibyte-characters))
3050 (setq readme-string
3051 ;; The readme.txt files are defined to contain utf-8 text.
3052 (decode-coding-region (point-min) (point-max) 'utf-8 t))
3053 t)
3054 (insert (or readme-string
3055 "This package does not provide a description.")))))
3056
3057 ;; Insert news if available.
3058 (when news
3059 (insert "\n" (make-separator-line) "\n"
3060 (propertize "* News" 'face 'package-help-section-name)
3061 "\n\n")
3062 (insert-file-contents news))
3063
3064 ;; Make library descriptions into links.
3065 (goto-char start-of-description)
3066 (package--describe-add-library-links)
3067 ;; Make URLs in the description into links.
3068 (goto-char start-of-description)
3069 (browse-url-add-buttons))))
3070
3071(defun package-install-button-action (button)
3072 "Run `package-install' on the package BUTTON points to.
3073Used for the `action' property of buttons in the buffer created by
3074`describe-package'."
3075 (let ((pkg-desc (button-get button 'package-desc)))
3076 (when (y-or-n-p (format-message "Install package `%s'? "
3077 (package-desc-full-name pkg-desc)))
3078 (package-install pkg-desc nil)
3079 (describe-package (package-desc-name pkg-desc)))))
3080
3081(defun package-delete-button-action (button)
3082 "Run `package-delete' on the package BUTTON points to.
3083Used for the `action' property of buttons in the buffer created by
3084`describe-package'."
3085 (let ((pkg-desc (button-get button 'package-desc)))
3086 (when (y-or-n-p (format-message "Delete package `%s'? "
3087 (package-desc-full-name pkg-desc)))
3088 (package-delete pkg-desc)
3089 (describe-package (package-desc-name pkg-desc)))))
3090
3091(defun package-keyword-button-action (button)
3092 "Show filtered \"*Packages*\" buffer for BUTTON.
3093The buffer is filtered by the `package-keyword' property of BUTTON.
3094Used for the `action' property of buttons in the buffer created by
3095`describe-package'."
3096 (let ((pkg-keyword (button-get button 'package-keyword)))
3097 (package-show-package-list t (list pkg-keyword))))
3098
3099(defun package-make-button (text &rest properties)
3100 "Insert button labeled TEXT with button PROPERTIES at point.
3101PROPERTIES are passed to `insert-text-button', for which this
3102function is a convenience wrapper used by `describe-package-1'."
3103 (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
3104 (button-face (if (display-graphic-p)
3105 (progn
3106 (require 'cus-edit) ; for the custom-button face
3107 'custom-button)
3108 'link)))
3109 (apply #'insert-text-button button-text 'face button-face 'follow-link t
3110 properties)))
3111
3112(defun package--finder-goto-xref (button)
3113 "Jump to a Lisp file for the BUTTON at point."
3114 (let* ((file (button-get button 'xref))
3115 (lib (locate-library file)))
3116 (if lib (finder-commentary lib)
3117 (message "Unable to locate `%s'" file))))
3118
3119(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref)
3120
3121(defun package--print-email-button (recipient)
3122 "Insert a button whose action will send an email to RECIPIENT.
3123NAME should have the form (FULLNAME . EMAIL) where FULLNAME is
3124either a full name or nil, and EMAIL is a valid email address."
3125 (when (car recipient)
3126 (insert (car recipient)))
3127 (when (and (car recipient) (cdr recipient))
3128 (insert " "))
3129 (when (cdr recipient)
3130 (insert "<")
3131 (insert-text-button (cdr recipient)
3132 'follow-link t
3133 'action (lambda (_)
3134 (compose-mail
3135 (format "%s <%s>" (car recipient) (cdr recipient)))))
3136 (insert ">"))
3137 (insert "\n"))
3138
3139
3140;;;; Package menu mode.
3141
3142(defvar-keymap package-menu-mode-map
3143 :doc "Local keymap for `package-menu-mode' buffers."
3144 :parent tabulated-list-mode-map
3145 "C-m" #'package-menu-describe-package
3146 "u" #'package-menu-mark-unmark
3147 "DEL" #'package-menu-backup-unmark
3148 "d" #'package-menu-mark-delete
3149 "i" #'package-menu-mark-install
3150 "U" #'package-menu-mark-upgrades
3151 "r" #'revert-buffer
3152 "~" #'package-menu-mark-obsolete-for-deletion
3153 "w" #'package-browse-url
3154 "b" #'package-report-bug
3155 "x" #'package-menu-execute
3156 "h" #'package-menu-quick-help
3157 "H" #'package-menu-hide-package
3158 "?" #'package-menu-describe-package
3159 "(" #'package-menu-toggle-hiding
3160 "/ /" #'package-menu-clear-filter
3161 "/ a" #'package-menu-filter-by-archive
3162 "/ d" #'package-menu-filter-by-description
3163 "/ k" #'package-menu-filter-by-keyword
3164 "/ N" #'package-menu-filter-by-name-or-description
3165 "/ n" #'package-menu-filter-by-name
3166 "/ s" #'package-menu-filter-by-status
3167 "/ v" #'package-menu-filter-by-version
3168 "/ m" #'package-menu-filter-marked
3169 "/ u" #'package-menu-filter-upgradable)
3170
3171(easy-menu-define package-menu-mode-menu package-menu-mode-map
3172 "Menu for `package-menu-mode'."
3173 '("Package"
3174 ["Describe Package" package-menu-describe-package :help "Display information about this package"]
3175 ["Open Package Website" package-browse-url
3176 :help "Open the website of this package"]
3177 ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
3178 "--"
3179 ["Refresh Package List" revert-buffer
3180 :help "Redownload the package archive(s)"
3181 :active (not package--downloads-in-progress)]
3182 ["Execute Marked Actions" package-menu-execute :help "Perform all the marked actions"]
3183
3184 "--"
3185 ["Mark All Available Upgrades" package-menu-mark-upgrades
3186 :help "Mark packages that have a newer version for upgrading"
3187 :active (not package--downloads-in-progress)]
3188 ["Mark All Obsolete for Deletion" package-menu-mark-obsolete-for-deletion :help "Mark all obsolete packages for deletion"]
3189 ["Mark for Install" package-menu-mark-install :help "Mark a package for installation and move to the next line"]
3190 ["Mark for Deletion" package-menu-mark-delete :help "Mark a package for deletion and move to the next line"]
3191 ["Unmark" package-menu-mark-unmark :help "Clear any marks on a package and move to the next line"]
3192
3193 "--"
3194 ("Filter Packages"
3195 ["Filter by Archive" package-menu-filter-by-archive
3196 :help
3197 "Prompt for archive(s), display only packages from those archives"]
3198 ["Filter by Description" package-menu-filter-by-description
3199 :help
3200 "Prompt for regexp, display only packages with matching description"]
3201 ["Filter by Keyword" package-menu-filter-by-keyword
3202 :help
3203 "Prompt for keyword(s), display only packages with matching keywords"]
3204 ["Filter by Name" package-menu-filter-by-name
3205 :help
3206 "Prompt for regexp, display only packages whose names match the regexp"]
3207 ["Filter by Name or Description" package-menu-filter-by-name-or-description
3208 :help
3209 "Prompt for regexp, display only packages whose name or description matches"]
3210 ["Filter by Status" package-menu-filter-by-status
3211 :help
3212 "Prompt for status(es), display only packages with those statuses"]
3213 ["Filter by Upgrades available" package-menu-filter-upgradable
3214 :help "Display only installed packages for which upgrades are available"]
3215 ["Filter by Version" package-menu-filter-by-version
3216 :help
3217 "Prompt for version and comparison operator, display only packages of matching versions"]
3218 ["Filter Marked" package-menu-filter-marked
3219 :help "Display only packages marked for installation or deletion"]
3220 ["Clear Filter" package-menu-clear-filter
3221 :help "Clear package list filtering, display the entire list again"])
3222
3223 ["Hide by Regexp" package-menu-hide-package
3224 :help "Toggle visibility of obsolete and unwanted packages"]
3225 ["Display Older Versions" package-menu-toggle-hiding
3226 :style toggle :selected (not package-menu--hide-packages)
3227 :help "Display package even if a newer version is already installed"]
3228
3229 "--"
3230 ["Quit" quit-window :help "Quit package selection"]
3231 ["Customize" (customize-group 'package)]))
3232
3233(defvar package-menu--new-package-list nil
3234 "List of newly-available packages since `list-packages' was last called.")
3235
3236(defvar package-menu--transaction-status nil
3237 "Mode-line status of ongoing package transaction.")
3238
3239(defconst package-menu-mode-line-format
3240 '((package-menu-mode-line-info
3241 (:eval (symbol-value 'package-menu-mode-line-info)))))
3242
3243(defvar-local package-menu-mode-line-info nil
3244 "Variable which stores package-menu mode-line format.")
3245
3246(defun package-menu--set-mode-line-format ()
3247 "Display package-menu mode-line."
3248 (when-let* ((buf (get-buffer "*Packages*"))
3249 ((buffer-live-p buf)))
3250 (with-current-buffer buf
3251 (setq package-menu-mode-line-info
3252 (let ((installed 0)
3253 (new 0)
3254 (total (length package-archive-contents))
3255 (to-upgrade (length (package-menu--find-upgrades)))
3256 (total-help "Total number of packages of all package archives")
3257 (installed-help "Total number of packages installed")
3258 (upgrade-help "Total number of packages to upgrade")
3259 (new-help "Total number of packages added recently"))
3260
3261 (save-excursion
3262 (goto-char (point-min))
3263 (while (not (eobp))
3264 (let ((status (package-menu-get-status)))
3265 (cond
3266 ((member status
3267 '("installed" "dependency" "unsigned"))
3268 (setq installed (1+ installed)))
3269 ((equal status "new")
3270 (setq new (1+ new)))))
3271 (forward-line)))
3272
3273 (setq installed (number-to-string installed))
3274 (setq total (number-to-string total))
3275 (setq to-upgrade (number-to-string to-upgrade))
3276
3277 (list
3278 " ["
3279 (propertize "Total: " 'help-echo total-help)
3280 (propertize total
3281 'help-echo total-help
3282 'face 'package-mode-line-total)
3283 " / "
3284 (propertize "Installed: " 'help-echo installed-help)
3285 (propertize installed
3286 'help-echo installed-help
3287 'face 'package-mode-line-installed)
3288 " / "
3289 (propertize "To Upgrade: " 'help-echo upgrade-help)
3290 (propertize to-upgrade
3291 'help-echo upgrade-help
3292 'face 'package-mode-line-to-upgrade)
3293 (when (> new 0)
3294 (concat
3295 " / "
3296 (propertize "New: " 'help-echo new-help)
3297 (propertize (number-to-string new)
3298 'help-echo new-help
3299 'face 'package-mode-line-new)))
3300 "] "))))))
3301(defvar package-menu--tool-bar-map
3302 (let ((map (make-sparse-keymap)))
3303 (tool-bar-local-item-from-menu
3304 #'package-menu-execute "package-menu/execute"
3305 map package-menu-mode-map)
3306 (define-key-after map [separator-1] menu-bar-separator)
3307 (tool-bar-local-item-from-menu
3308 #'package-menu-mark-unmark "package-menu/unmark"
3309 map package-menu-mode-map)
3310 (tool-bar-local-item-from-menu
3311 #'package-menu-mark-install "package-menu/install"
3312 map package-menu-mode-map)
3313 (tool-bar-local-item-from-menu
3314 #'package-menu-mark-delete "package-menu/delete"
3315 map package-menu-mode-map)
3316 (tool-bar-local-item-from-menu
3317 #'package-menu-describe-package "package-menu/info"
3318 map package-menu-mode-map)
3319 (tool-bar-local-item-from-menu
3320 #'package-browse-url "package-menu/url"
3321 map package-menu-mode-map)
3322 (tool-bar-local-item
3323 "package-menu/upgrade" 'package-upgrade-all
3324 'package-upgrade-all
3325 map :help "Upgrade all the packages")
3326 (define-key-after map [separator-2] menu-bar-separator)
3327 (tool-bar-local-item
3328 "search" 'isearch-forward 'search map
3329 :help "Search" :vert-only t)
3330 (tool-bar-local-item-from-menu
3331 #'revert-buffer "refresh"
3332 map package-menu-mode-map)
3333 (tool-bar-local-item-from-menu
3334 #'quit-window "close"
3335 map package-menu-mode-map)
3336 map))
3337
3338(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
3339 "Major mode for browsing a list of packages.
3340The most useful commands here are:
3341
3342 `x': Install the package under point if it isn't already installed,
3343 and delete it if it's already installed,
3344 `i': mark a package for installation, and
3345 `d': mark a package for deletion. Use the `x' command to perform the
3346 actions on the marked files.
3347\\<package-menu-mode-map>
3348\\{package-menu-mode-map}"
3349 :interactive nil
3350 (setq mode-line-process '((package--downloads-in-progress ":Loading")
3351 (package-menu--transaction-status
3352 package-menu--transaction-status)))
3353 (setq-local mode-line-misc-info
3354 (append
3355 mode-line-misc-info
3356 package-menu-mode-line-format))
3357 (setq-local tool-bar-map package-menu--tool-bar-map)
3358 (setq tabulated-list-format
3359 `[("Package" ,package-name-column-width package-menu--name-predicate)
3360 ("Version" ,package-version-column-width package-menu--version-predicate)
3361 ("Status" ,package-status-column-width package-menu--status-predicate)
3362 ("Archive" ,package-archive-column-width package-menu--archive-predicate)
3363 ("Description" 0 package-menu--description-predicate)])
3364 (setq tabulated-list-padding 2)
3365 (setq tabulated-list-sort-key (cons "Status" nil))
3366 (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t)
3367 (tabulated-list-init-header)
3368 (setq revert-buffer-function 'package-menu--refresh-contents)
3369 (setf imenu-prev-index-position-function
3370 #'package--imenu-prev-index-position-function)
3371 (setf imenu-extract-index-name-function
3372 #'package--imenu-extract-index-name-function))
3373
3374(defmacro package--push (pkg-desc status listname)
3375 "Convenience macro for `package-menu--generate'.
3376If the alist stored in the symbol LISTNAME lacks an entry for a
3377package PKG-DESC, add one. The alist is keyed with PKG-DESC."
3378 (declare (obsolete nil "27.1"))
3379 `(unless (assoc ,pkg-desc ,listname)
3380 ;; FIXME: Should we move status into pkg-desc?
3381 (push (cons ,pkg-desc ,status) ,listname)))
3382
3383(defvar package-list-unversioned nil
3384 "If non-nil, include packages that don't have a version in `list-packages'.")
3385
3386(defvar package-list-unsigned nil
3387 "If non-nil, mention in the list which packages were installed without signature.")
3388
3389(defvar package--emacs-version-list (version-to-list emacs-version)
3390 "The value of variable `emacs-version' as a list.")
3391
3392(defun package--ensure-package-menu-mode ()
3393 "Signal a user-error if major mode is not `package-menu-mode'."
3394 (unless (derived-mode-p 'package-menu-mode)
3395 (user-error "The current buffer is not a Package Menu")))
3396
3397(defun package--incompatible-p (pkg &optional shallow)
3398 "Return non-nil if PKG has no chance of being installable.
3399PKG is a `package-desc' object.
3400
3401If SHALLOW is non-nil, this only checks if PKG depends on a
3402higher `emacs-version' than the one being used. Otherwise, also
3403checks the viability of dependencies, according to
3404`package--compatibility-table'.
3405
3406If PKG requires an incompatible Emacs version, the return value
3407is this version (as a string).
3408If PKG requires incompatible packages, the return value is a list
3409of these dependencies, similar to the list returned by
3410`package-desc-reqs'."
3411 (let* ((reqs (package-desc-reqs pkg))
3412 (version (cadr (assq 'emacs reqs))))
3413 (if (and version (version-list-< package--emacs-version-list version))
3414 (package-version-join version)
3415 (unless shallow
3416 (let (out)
3417 (dolist (dep (package-desc-reqs pkg) out)
3418 (let ((dep-name (car dep)))
3419 (unless (eq 'emacs dep-name)
3420 (let ((cv (gethash dep-name package--compatibility-table)))
3421 (when (version-list-< (or cv '(0)) (or (cadr dep) '(0)))
3422 (push dep out)))))))))))
3423
3424(defun package-desc-status (pkg-desc)
3425 "Return the status of `package-desc' object PKG-DESC."
3426 (let* ((name (package-desc-name pkg-desc))
3427 (dir (package-desc-dir pkg-desc))
3428 (lle (assq name package-load-list))
3429 (held (cadr lle))
3430 (version (package-desc-version pkg-desc))
3431 (signed (or (not package-list-unsigned)
3432 (package-desc-signed pkg-desc))))
3433 (cond
3434 ((package-vc-p pkg-desc) "source")
3435 ((eq dir 'builtin) "built-in")
3436 ((and lle (null held)) "disabled")
3437 ((stringp held)
3438 (let ((hv (if (stringp held) (version-to-list held))))
3439 (cond
3440 ((version-list-= version hv) "held")
3441 ((version-list-< version hv) "obsolete")
3442 (t "disabled"))))
3443 (dir ;One of the installed packages.
3444 (cond
3445 ((not (file-exists-p dir)) "deleted")
3446 ;; Not inside `package-user-dir'.
3447 ((not (file-in-directory-p dir package-user-dir)) "external")
3448 ((eq pkg-desc (cadr (assq name package-alist)))
3449 (if (not signed) "unsigned"
3450 (if (package--user-selected-p name)
3451 "installed" "dependency")))
3452 (t "obsolete")))
3453 ((package--incompatible-p pkg-desc) "incompat")
3454 (t
3455 (let* ((ins (cadr (assq name package-alist)))
3456 (ins-v (if ins (package-desc-version ins))))
3457 (cond
3458 ;; Installed obsolete packages are handled in the `dir'
3459 ;; clause above. Here we handle available obsolete, which
3460 ;; are displayed depending on `package-menu--hide-packages'.
3461 ((and ins (version-list-<= version ins-v)) "avail-obso")
3462 (t
3463 (if (memq name package-menu--new-package-list)
3464 "new" "available"))))))))
3465
3466(defvar package-menu--hide-packages t
3467 "Whether available obsolete packages should be hidden.
3468Can be toggled with \\<package-menu-mode-map> \\[package-menu-toggle-hiding].
3469Installed obsolete packages are always displayed.")
3470
3471(defun package-menu-toggle-hiding ()
3472 "In Package Menu, toggle visibility of obsolete available packages.
3473
3474Also hide packages whose name matches a regexp in user option
3475`package-hidden-regexps' (a list). To add regexps to this list,
3476use `package-menu-hide-package'."
3477 (interactive nil package-menu-mode)
3478 (package--ensure-package-menu-mode)
3479 (setq package-menu--hide-packages
3480 (not package-menu--hide-packages))
3481 (if package-menu--hide-packages
3482 (message "Hiding obsolete or unwanted packages")
3483 (message "Displaying all packages"))
3484 (revert-buffer nil 'no-confirm))
3485
3486(defun package--remove-hidden (pkg-list)
3487 "Filter PKG-LIST according to `package-archive-priorities'.
3488PKG-LIST must be a list of `package-desc' objects, all with the
3489same name, sorted by decreasing `package-desc-priority-version'.
3490Return a list of packages tied for the highest priority according
3491to their archives."
3492 (when pkg-list
3493 ;; Variable toggled with `package-menu-toggle-hiding'.
3494 (if (not package-menu--hide-packages)
3495 pkg-list
3496 (let ((installed (cadr (assq (package-desc-name (car pkg-list))
3497 package-alist))))
3498 (when installed
3499 (setq pkg-list
3500 (let ((ins-version (package-desc-version installed)))
3501 (cl-remove-if (lambda (p) (version-list-< (package-desc-version p)
3502 ins-version))
3503 pkg-list))))
3504 (let ((filtered-by-priority
3505 (cond
3506 ((not package-menu-hide-low-priority)
3507 pkg-list)
3508 ((eq package-menu-hide-low-priority 'archive)
3509 (let (max-priority out)
3510 (while pkg-list
3511 (let ((p (pop pkg-list)))
3512 (let ((priority (package-desc-priority p)))
3513 (if (and max-priority (< priority max-priority))
3514 (setq pkg-list nil)
3515 (push p out)
3516 (setq max-priority priority)))))
3517 (nreverse out)))
3518 (pkg-list
3519 (list (car pkg-list))))))
3520 (if (not installed)
3521 filtered-by-priority
3522 (let ((ins-version (package-desc-version installed)))
3523 (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p)
3524 ins-version)
3525 (package-vc-p installed)))
3526 filtered-by-priority))))))))
3527
3528(defcustom package-hidden-regexps nil
3529 "List of regexps matching the name of packages to hide.
3530If the name of a package matches any of these regexps it is
3531omitted from the package menu. To toggle this, type \\[package-menu-toggle-hiding].
3532
3533Values can be interactively added to this list by typing
3534\\[package-menu-hide-package] on a package."
3535 :version "25.1"
3536 :type '(repeat (regexp :tag "Hide packages with name matching")))
3537
3538(defcustom package-menu-use-current-if-no-marks t
3539 "Whether \\<package-menu-mode-map>\\[package-menu-execute] in package menu operates on current package if none are marked.
3540
3541If non-nil, and no packages are marked for installation or
3542deletion, \\<package-menu-mode-map>\\[package-menu-execute] will operate on the current package at point,
3543see `package-menu-execute' for details.
3544The default is t. Set to nil to get back the original behavior
3545of having `package-menu-execute' signal an error when no packages
3546are marked for installation or deletion."
3547 :version "29.1"
3548 :type 'boolean)
3549
3550(defun package-menu--refresh (&optional packages keywords)
3551 "Re-populate the `tabulated-list-entries'.
3552PACKAGES should be nil or t, which means to display all known packages.
3553KEYWORDS should be nil or a list of keywords."
3554 ;; Construct list of (PKG-DESC . STATUS).
3555 (unless packages (setq packages t))
3556 (let ((hidden-names (mapconcat #'identity package-hidden-regexps "\\|"))
3557 info-list)
3558 ;; Installed packages:
3559 (dolist (elt package-alist)
3560 (let ((name (car elt)))
3561 (when (or (eq packages t) (memq name packages))
3562 (dolist (pkg (cdr elt))
3563 (when (package--has-keyword-p pkg keywords)
3564 (push pkg info-list))))))
3565
3566 ;; Built-in packages:
3567 (dolist (elt package--builtins)
3568 (let ((pkg (package--from-builtin elt))
3569 (name (car elt)))
3570 (when (not (eq name 'emacs)) ; Hide the `emacs' package.
3571 (when (and (package--has-keyword-p pkg keywords)
3572 (or package-list-unversioned
3573 (package--bi-desc-version (cdr elt)))
3574 (or (eq packages t) (memq name packages)))
3575 (push pkg info-list)))))
3576
3577 ;; Available and disabled packages:
3578 (unless (equal package--old-archive-priorities package-archive-priorities)
3579 (package-read-all-archive-contents))
3580 (dolist (elt package-archive-contents)
3581 (let ((name (car elt)))
3582 ;; To be displayed it must be in PACKAGES;
3583 (when (and (or (eq packages t) (memq name packages))
3584 ;; and we must either not be hiding anything,
3585 (or (not package-menu--hide-packages)
3586 (not package-hidden-regexps)
3587 ;; or just not hiding this specific package.
3588 (not (string-match hidden-names (symbol-name name)))))
3589 ;; Hide available-obsolete or low-priority packages.
3590 (dolist (pkg (package--remove-hidden (cdr elt)))
3591 (when (package--has-keyword-p pkg keywords)
3592 (push pkg info-list))))))
3593
3594 ;; Print the result.
3595 (tabulated-list-init-header)
3596 (setq tabulated-list-entries
3597 (mapcar #'package-menu--print-info-simple info-list))))
3598
3599(defun package-all-keywords ()
3600 "Collect all package keywords."
3601 (let ((key-list))
3602 (package--mapc (lambda (desc)
3603 (setq key-list (append (package-desc--keywords desc)
3604 key-list))))
3605 key-list))
3606
3607(defun package--mapc (function &optional packages)
3608 "Call FUNCTION for all known PACKAGES.
3609PACKAGES can be nil or t, which means to display all known
3610packages, or a list of packages.
3611
3612Built-in packages are converted with `package--from-builtin'."
3613 (unless packages (setq packages t))
3614 (let (name)
3615 ;; Installed packages:
3616 (dolist (elt package-alist)
3617 (setq name (car elt))
3618 (when (or (eq packages t) (memq name packages))
3619 (mapc function (cdr elt))))
3620
3621 ;; Built-in packages:
3622 (dolist (elt package--builtins)
3623 (setq name (car elt))
3624 (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
3625 (or package-list-unversioned
3626 (package--bi-desc-version (cdr elt)))
3627 (or (eq packages t) (memq name packages)))
3628 (funcall function (package--from-builtin elt))))
3629
3630 ;; Available and disabled packages:
3631 (dolist (elt package-archive-contents)
3632 (setq name (car elt))
3633 (when (or (eq packages t) (memq name packages))
3634 (dolist (pkg (cdr elt))
3635 ;; Hide obsolete packages.
3636 (unless (package-installed-p (package-desc-name pkg)
3637 (package-desc-version pkg))
3638 (funcall function pkg)))))))
3639
3640(defun package--has-keyword-p (desc &optional keywords)
3641 "Test if package DESC has any of the given KEYWORDS.
3642When none are given, the package matches."
3643 (if keywords
3644 (let ((desc-keywords (and desc (package-desc--keywords desc)))
3645 found)
3646 (while (and (not found) keywords)
3647 (let ((k (pop keywords)))
3648 (setq found
3649 (or (string= k (concat "arc:" (package-desc-archive desc)))
3650 (string= k (concat "status:" (package-desc-status desc)))
3651 (member k desc-keywords)))))
3652 found)
3653 t))
3654
3655(defun package-menu--display (remember-pos suffix)
3656 "Display the Package Menu.
3657If REMEMBER-POS is non-nil, keep point on the same entry.
3658
3659If SUFFIX is non-nil, append that to \"Package\" for the first
3660column in the header line."
3661 (setf (car (aref tabulated-list-format 0))
3662 (if suffix
3663 (concat "Package[" suffix "]")
3664 "Package"))
3665 (tabulated-list-init-header)
3666 (tabulated-list-print remember-pos))
3667
3668(defun package-menu--generate (remember-pos &optional packages keywords)
3669 "Populate and display the Package Menu.
3670If REMEMBER-POS is non-nil, keep point on the same entry.
3671PACKAGES should be t, which means to display all known packages,
3672or a list of package names (symbols) to display.
3673
3674With KEYWORDS given, only packages with those keywords are
3675shown."
3676 (package-menu--refresh packages keywords)
3677 (package-menu--display remember-pos
3678 (when keywords
3679 (let ((filters (mapconcat #'identity keywords ",")))
3680 (concat "Package[" filters "]")))))
3681
3682(defun package-menu--print-info (pkg)
3683 "Return a package entry suitable for `tabulated-list-entries'.
3684PKG has the form (PKG-DESC . STATUS).
3685Return (PKG-DESC [NAME VERSION STATUS DOC])."
3686 (package-menu--print-info-simple (car pkg)))
3687(make-obsolete 'package-menu--print-info
3688 'package-menu--print-info-simple "25.1")
3689
3690
3691;;; Package menu faces
3692
3693(defface package-name
3694 '((t :inherit link))
3695 "Face used on package names in the package menu."
3696 :version "25.1")
3697
3698(defface package-description
3699 '((t :inherit default))
3700 "Face used on package description summaries in the package menu."
3701 :version "25.1")
3702
3703;; Shame this hyphenates "built-in", when "font-lock-builtin-face" doesn't.
3704(defface package-status-built-in
3705 '((t :inherit font-lock-builtin-face))
3706 "Face used on the status and version of built-in packages."
3707 :version "25.1")
3708
3709(defface package-status-external
3710 '((t :inherit package-status-built-in))
3711 "Face used on the status and version of external packages."
3712 :version "25.1")
3713
3714(defface package-status-available
3715 '((t :inherit default))
3716 "Face used on the status and version of available packages."
3717 :version "25.1")
3718
3719(defface package-status-new
3720 '((t :inherit (bold package-status-available)))
3721 "Face used on the status and version of new packages."
3722 :version "25.1")
3723
3724(defface package-status-held
3725 '((t :inherit font-lock-constant-face))
3726 "Face used on the status and version of held packages."
3727 :version "25.1")
3728
3729(defface package-status-disabled
3730 '((t :inherit font-lock-warning-face))
3731 "Face used on the status and version of disabled packages."
3732 :version "25.1")
3733
3734(defface package-status-installed
3735 '((t :inherit font-lock-comment-face))
3736 "Face used on the status and version of installed packages."
3737 :version "25.1")
3738
3739(defface package-status-from-source
3740 '((t :inherit font-lock-negation-char-face))
3741 "Face used on the status and version of installed packages."
3742 :version "29.1")
3743
3744(defface package-status-dependency
3745 '((t :inherit package-status-installed))
3746 "Face used on the status and version of dependency packages."
3747 :version "25.1")
3748
3749(defface package-status-unsigned
3750 '((t :inherit font-lock-warning-face))
3751 "Face used on the status and version of unsigned packages."
3752 :version "25.1")
3753
3754(defface package-status-incompat
3755 '((t :inherit error))
3756 "Face used on the status and version of incompat packages."
3757 :version "25.1")
3758
3759(defface package-status-avail-obso
3760 '((t :inherit package-status-incompat))
3761 "Face used on the status and version of avail-obso packages."
3762 :version "25.1")
3763
3764(defface package-mark-install-line
3765 '((((class color) (background light))
3766 :background "darkolivegreen1" :extend t)
3767 (((class color) (background dark))
3768 :background "seagreen" :extend t)
3769 (t :inherit (highlight) :extend t))
3770 "Face used for highlighting in package-menu packages marked to be installed."
3771 :version "31.1")
3772
3773(defface package-mark-delete-line
3774 '((((class color) (background light))
3775 :background "rosybrown1" :extend t)
3776 (((class color) (background dark))
3777 :background "indianred4" :extend t)
3778 (t :inherit (highlight) :extend t))
3779 "Face used for highlighting in package-menu packages marked to be deleted."
3780 :version "31.1")
3781
3782(defface package-mode-line-total nil
3783 "Face for the total number of packages displayed on the mode line."
3784 :version "31.1")
3785
3786(defface package-mode-line-installed '((t :inherit package-status-installed))
3787 "Face for the number of installed packages displayed on the mode line."
3788 :version "31.1")
3789
3790(defface package-mode-line-to-upgrade '((t :inherit bold))
3791 "Face for the number of packages to upgrade displayed on the mode line."
3792 :version "31.1")
3793
3794(defface package-mode-line-new '((t :inherit package-status-new))
3795 "Face for the number of new packages displayed on the mode line."
3796 :version "31.1")
3797
3798
3799;;; Package menu printing
3800
3801(defun package-menu--print-info-simple (pkg)
3802 "Return a package entry suitable for `tabulated-list-entries'.
3803PKG is a `package-desc' object.
3804Return (PKG-DESC [NAME VERSION STATUS DOC])."
3805 (let* ((status (package-desc-status pkg))
3806 (face (pcase status
3807 ("built-in" 'package-status-built-in)
3808 ("external" 'package-status-external)
3809 ("available" 'package-status-available)
3810 ("avail-obso" 'package-status-avail-obso)
3811 ("new" 'package-status-new)
3812 ("held" 'package-status-held)
3813 ("disabled" 'package-status-disabled)
3814 ("installed" 'package-status-installed)
3815 ("source" 'package-status-from-source)
3816 ("dependency" 'package-status-dependency)
3817 ("unsigned" 'package-status-unsigned)
3818 ("incompat" 'package-status-incompat)
3819 (_ 'font-lock-warning-face)))) ; obsolete.
3820 (list pkg
3821 `[(,(symbol-name (package-desc-name pkg))
3822 face package-name
3823 font-lock-face package-name
3824 follow-link t
3825 package-desc ,pkg
3826 action package-menu-describe-package)
3827 ,(propertize
3828 (if (package-vc-p pkg)
3829 (progn
3830 (require 'package-vc)
3831 (package-vc-commit pkg))
3832 (package-version-join
3833 (package-desc-version pkg)))
3834 'font-lock-face face)
3835 ,(propertize status 'font-lock-face face)
3836 ,(propertize (or (package-desc-archive pkg) "")
3837 'font-lock-face face)
3838 ,(propertize (package-desc-summary pkg)
3839 'font-lock-face 'package-description)])))
3840
3841(defvar package-menu--old-archive-contents nil
3842 "`package-archive-contents' before the latest refresh.")
3843
3844(defun package-menu--refresh-contents (&optional _arg _noconfirm)
3845 "In Package Menu, download the Emacs Lisp package archive.
3846Fetch the contents of each archive specified in
3847`package-archives', and then refresh the package menu.
3848
3849`package-menu-mode' sets `revert-buffer-function' to this
3850function. The args ARG and NOCONFIRM, passed from
3851`revert-buffer', are ignored."
3852 (package--ensure-package-menu-mode)
3853 (setq package-menu--old-archive-contents package-archive-contents)
3854 (setq package-menu--new-package-list nil)
3855 (package-refresh-contents package-menu-async))
3856(define-obsolete-function-alias 'package-menu-refresh 'revert-buffer "27.1")
3857
3858(defun package-menu--overlay-line (face)
3859 "Highlight whole line with face FACE."
3860 (let ((ov (make-overlay (line-beginning-position)
3861 (1+ (line-end-position)))))
3862 (overlay-put ov 'pkg-menu-ov t)
3863 (overlay-put ov 'evaporate t)
3864 (overlay-put ov 'face face)))
3865
3866(defun package-menu--remove-overlay ()
3867 "Remove all overlays done by `package-menu--overlay-line' in current line."
3868 (remove-overlays (line-beginning-position)
3869 (1+ (line-end-position))
3870 'pkg-menu-ov t))
3871
3872(defun package-menu-hide-package ()
3873 "Hide in Package Menu packages that match a regexp.
3874Prompt for the regexp to match against package names.
3875The default regexp will hide only the package whose name is at point.
3876
3877The regexp is added to the list in the user option
3878`package-hidden-regexps' and saved for future sessions.
3879
3880To unhide a package, type
3881`\\[customize-variable] RET package-hidden-regexps', and then modify
3882the regexp such that it no longer matches the package's name.
3883
3884Type \\[package-menu-toggle-hiding] to toggle package hiding."
3885 (declare (interactive-only "change `package-hidden-regexps' instead."))
3886 (interactive nil package-menu-mode)
3887 (package--ensure-package-menu-mode)
3888 (let* ((name (when (derived-mode-p 'package-menu-mode)
3889 (concat "\\`" (regexp-quote (symbol-name (package-desc-name
3890 (tabulated-list-get-id))))
3891 "\\'")))
3892 (re (read-string "Hide packages matching regexp: " name)))
3893 ;; Test if it is valid.
3894 (string-match re "")
3895 (push re package-hidden-regexps)
3896 (customize-save-variable 'package-hidden-regexps package-hidden-regexps)
3897 (package-menu--post-refresh)
3898 (let ((hidden
3899 (cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e))))
3900 package-archive-contents)))
3901 (message "Packages to hide: %d. Type `%s' to toggle or `%s' to customize"
3902 (length hidden)
3903 (substitute-command-keys "\\[package-menu-toggle-hiding]")
3904 (substitute-command-keys "\\[customize-variable] RET package-hidden-regexps")))))
3905
3906
3907(defun package-menu-describe-package (&optional button)
3908 "Describe the current package.
3909The current package is the package at point.
3910If optional arg BUTTON is non-nil, describe its associated
3911package(s); this is always nil in interactive invocations."
3912 (interactive nil package-menu-mode)
3913 (let ((pkg-desc (if button (button-get button 'package-desc)
3914 (tabulated-list-get-id))))
3915 (if pkg-desc
3916 (describe-package pkg-desc)
3917 (user-error "No package here"))))
3918
3919;; fixme numeric argument
3920(defun package-menu-mark-delete (&optional _num)
3921 "Mark the current package for deletion and move to the next line.
3922The current package is the package at point."
3923 (interactive "p" package-menu-mode)
3924 (package--ensure-package-menu-mode)
3925 (if (member (package-menu-get-status)
3926 '("installed" "source" "dependency" "obsolete" "unsigned"))
3927 (progn (package-menu--overlay-line 'package-mark-delete-line)
3928 (tabulated-list-put-tag "D" t))
3929 (forward-line)))
3930
3931(defun package-menu-mark-install (&optional _num)
3932 "Mark the current package for installation and move to the next line.
3933The current package is the package at point."
3934 (interactive "p" package-menu-mode)
3935 (package--ensure-package-menu-mode)
3936 (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency"))
3937 (progn (package-menu--overlay-line 'package-mark-install-line)
3938 (tabulated-list-put-tag "I" t))
3939 (forward-line)))
3940
3941(defun package-menu-mark-unmark (&optional _num)
3942 "Clear any marks on the current package and move to the next line.
3943The current package is the package at point."
3944 (interactive "p" package-menu-mode)
3945 (package--ensure-package-menu-mode)
3946 (package-menu--remove-overlay)
3947 (tabulated-list-put-tag " " t))
3948
3949(defun package-menu-backup-unmark ()
3950 "Back up one line and clear any marks on that line's package."
3951 (interactive nil package-menu-mode)
3952 (package--ensure-package-menu-mode)
3953 (forward-line -1)
3954 (package-menu--remove-overlay)
3955 (tabulated-list-put-tag " "))
3956
3957(defun package-menu-mark-obsolete-for-deletion ()
3958 "Mark all obsolete packages for deletion."
3959 (interactive nil package-menu-mode)
3960 (package--ensure-package-menu-mode)
3961 (save-excursion
3962 (goto-char (point-min))
3963 (while (not (eobp))
3964 (if (equal (package-menu-get-status) "obsolete")
3965 (progn (package-menu--overlay-line 'package-mark-delete-line)
3966 (tabulated-list-put-tag "D" t))
3967 (forward-line 1)))))
3968
3969(defvar package--quick-help-keys
3970 '((("mark for installation," . 9)
3971 ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1))
3972 ("next," "previous")
3973 ("Hide-package," "(-toggle-hidden")
3974 ("g-refresh-contents," "/-filter," "help")))
3975
3976(defun package--prettify-quick-help-key (desc)
3977 "Prettify DESC to be displayed as a help menu."
3978 (if (listp desc)
3979 (if (listp (cdr desc))
3980 (mapconcat #'package--prettify-quick-help-key desc " ")
3981 (let ((place (cdr desc))
3982 (out (copy-sequence (car desc))))
3983 (add-text-properties place (1+ place)
3984 '(face help-key-binding)
3985 out)
3986 out))
3987 (package--prettify-quick-help-key (cons desc 0))))
3988
3989(defun package-menu-quick-help ()
3990 "Show short help for key bindings in `package-menu-mode'.
3991You can view the full list of keys with \\[describe-mode]."
3992 (interactive nil package-menu-mode)
3993 (package--ensure-package-menu-mode)
3994 (message (mapconcat #'package--prettify-quick-help-key
3995 package--quick-help-keys "\n")))
3996
3997(defun package-menu-get-status ()
3998 "Return status description of package at point in Package Menu."
3999 (package--ensure-package-menu-mode)
4000 (let* ((id (tabulated-list-get-id))
4001 (entry (and id (assoc id tabulated-list-entries))))
4002 (if entry
4003 (aref (cadr entry) 2)
4004 "")))
4005
4006(defun package-archive-priority (archive)
4007 "Return the priority of ARCHIVE.
4008
4009The archive priorities are specified in
4010`package-archive-priorities'. If not given there, the priority
4011defaults to 0."
4012 (or (cdr (assoc archive package-archive-priorities))
4013 0))
4014
4015(defun package-desc-priority-version (pkg-desc)
4016 "Return the version PKG-DESC with the archive priority prepended.
4017
4018This allows for easy comparison of package versions from
4019different archives if archive priorities are meant to be taken in
4020consideration."
4021 (cons (package-desc-priority pkg-desc)
4022 (package-desc-version pkg-desc)))
4023
4024(defun package-menu--find-upgrades ()
4025 "In Package Menu, return an alist of packages that can be upgraded.
4026The alist has the same form as `package-alist', namely a list
4027of elements of the form (PKG . DESCS), but where DESCS is the `package-desc'
4028object corresponding to the newer version."
4029 (let (installed available upgrades)
4030 ;; Build list of installed/available packages in this buffer.
4031 (dolist (entry tabulated-list-entries)
4032 ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
4033 (let ((pkg-desc (car entry))
4034 (status (aref (cadr entry) 2)))
4035 (cond ((member status '("installed" "dependency" "unsigned" "external" "built-in"))
4036 (push pkg-desc installed))
4037 ((member status '("available" "new"))
4038 (setq available (package--append-to-alist pkg-desc available))))))
4039 ;; Loop through list of installed packages, finding upgrades.
4040 (dolist (pkg-desc installed)
4041 (let* ((name (package-desc-name pkg-desc))
4042 (avail-pkg (cadr (assq name available))))
4043 (and avail-pkg
4044 (version-list-< (package-desc-priority-version pkg-desc)
4045 (package-desc-priority-version avail-pkg))
4046 (or (not (package--active-built-in-p pkg-desc))
4047 package-install-upgrade-built-in)
4048 (push (cons name avail-pkg) upgrades))))
4049 upgrades))
4050
4051(defvar package-menu--mark-upgrades-pending nil
4052 "Whether mark-upgrades is waiting for a refresh to finish.")
4053
4054(defun package-menu--mark-upgrades-1 ()
4055 "Mark all upgradable packages in the Package Menu.
4056Implementation of `package-menu-mark-upgrades'."
4057 (setq package-menu--mark-upgrades-pending nil)
4058 (let ((upgrades (package-menu--find-upgrades)))
4059 (if (null upgrades)
4060 (message "No packages to upgrade")
4061 (widen)
4062 (save-excursion
4063 (goto-char (point-min))
4064 (while (not (eobp))
4065 (let* ((pkg-desc (tabulated-list-get-id))
4066 (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades))))
4067 (cond ((null upgrade)
4068 (forward-line 1))
4069 ((equal pkg-desc upgrade)
4070 (package-menu-mark-install))
4071 (t
4072 (package-menu-mark-delete))))))
4073 (message "Packages marked for upgrading: %d"
4074 (length upgrades)))))
4075
4076
4077(defun package-menu-mark-upgrades ()
4078 "Mark all upgradable packages in the Package Menu.
4079For each installed package for which a newer version is available,
4080place an (I)nstall flag on the available version and a (D)elete flag
4081on the installed version. A subsequent \\[package-menu-execute] command will upgrade
4082the marked packages.
4083
4084If there's an async refresh operation in progress, the flags will
4085be placed as part of `package-menu--post-refresh' instead of
4086immediately."
4087 (interactive nil package-menu-mode)
4088 (package--ensure-package-menu-mode)
4089 (if (not package--downloads-in-progress)
4090 (package-menu--mark-upgrades-1)
4091 (setq package-menu--mark-upgrades-pending t)
4092 (message "Waiting for refresh to finish...")))
4093
4094(defun package-menu--list-to-prompt (packages &optional include-dependencies)
4095 "Return a string listing PACKAGES that's usable in a prompt.
4096PACKAGES is a list of `package-desc' objects.
4097Formats the returned string to be usable in a minibuffer
4098prompt (see `package-menu--prompt-transaction-p').
4099
4100If INCLUDE-DEPENDENCIES, also include the number of uninstalled
4101dependencies."
4102 ;; The case where `package' is empty is handled in
4103 ;; `package-menu--prompt-transaction-p' below.
4104 (format "%d (%s)%s"
4105 (length packages)
4106 (mapconcat #'package-desc-full-name packages " ")
4107 (let ((deps
4108 (seq-remove
4109 #'package-installed-p
4110 (delete-dups
4111 (apply
4112 #'nconc
4113 (mapcar (lambda (package)
4114 (package--dependencies
4115 (package-desc-name package)))
4116 packages))))))
4117 (if (and include-dependencies deps)
4118 (if (length= deps 1)
4119 (format " plus 1 dependency")
4120 (format " plus %d dependencies" (length deps)))
4121 ""))))
4122
4123(defun package-menu--prompt-transaction-p (delete install upgrade)
4124 "Prompt the user about DELETE, INSTALL, and UPGRADE.
4125DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects.
4126Either may be nil, but not all."
4127 (y-or-n-p
4128 (concat
4129 (when delete
4130 (format "Packages to delete: %s. "
4131 (package-menu--list-to-prompt delete)))
4132 (when install
4133 (format "Packages to install: %s. "
4134 (package-menu--list-to-prompt install t)))
4135 (when upgrade
4136 (format "Packages to upgrade: %s. "
4137 (package-menu--list-to-prompt upgrade)))
4138 "Proceed? ")))
4139
4140
4141(defun package-menu--partition-transaction (install delete)
4142 "Return an alist describing an INSTALL DELETE transaction.
4143Alist contains three entries, upgrade, delete, and install, each
4144with a list of package names.
4145
4146The upgrade entry contains any `package-desc' objects in INSTALL
4147whose name coincides with an object in DELETE. The delete and
4148the install entries are the same as DELETE and INSTALL with such
4149objects removed."
4150 (let* ((upg (cl-intersection install delete :key #'package-desc-name))
4151 (ins (cl-set-difference install upg :key #'package-desc-name))
4152 (del (cl-set-difference delete upg :key #'package-desc-name)))
4153 `((delete . ,del) (install . ,ins) (upgrade . ,upg))))
4154
4155(defun package-menu--perform-transaction (install-list delete-list)
4156 "Install packages in INSTALL-LIST and delete DELETE-LIST.
4157Return nil if there were no errors; non-nil otherwise."
4158 (let ((errors nil))
4159 (if install-list
4160 (let ((status-format (format ":Installing %%d/%d"
4161 (length install-list)))
4162 (i 0)
4163 (package-menu--transaction-status))
4164 (dolist (pkg install-list)
4165 (setq package-menu--transaction-status
4166 (format status-format (incf i)))
4167 (force-mode-line-update)
4168 (redisplay 'force)
4169 ;; Don't mark as selected, `package-menu-execute' already
4170 ;; does that.
4171 (package-install pkg 'dont-select))))
4172 (let ((package-menu--transaction-status ":Deleting"))
4173 (force-mode-line-update)
4174 (redisplay 'force)
4175 (dolist (elt (package--sort-by-dependence delete-list))
4176 (condition-case-unless-debug err
4177 (let ((inhibit-message (or inhibit-message package-menu-async)))
4178 (package-delete elt nil 'nosave))
4179 (error
4180 (push (package-desc-full-name elt) errors)
4181 (message "Error trying to delete `%s': %s"
4182 (package-desc-full-name elt)
4183 (error-message-string err))))))
4184 errors))
4185
4186(defun package--update-selected-packages (add remove)
4187 "Update the `package-selected-packages' list according to ADD and REMOVE.
4188ADD and REMOVE must be disjoint lists of package names (or
4189`package-desc' objects) to be added and removed to the selected
4190packages list, respectively."
4191 (dolist (p add)
4192 (cl-pushnew (if (package-desc-p p) (package-desc-name p) p)
4193 package-selected-packages))
4194 (dolist (p remove)
4195 (setq package-selected-packages
4196 (remove (if (package-desc-p p) (package-desc-name p) p)
4197 package-selected-packages)))
4198 (when (or add remove)
4199 (package--save-selected-packages package-selected-packages)))
4200
4201(defun package-menu-execute (&optional noquery)
4202 "Perform Package Menu actions on marked packages.
4203Packages marked for installation are downloaded and installed,
4204packages marked for deletion are removed, and packages marked for
4205upgrading are downloaded and upgraded.
4206
4207If no packages are marked, the action taken depends on the state
4208of the current package, the one at point. If it's not already
4209installed, this command will install the package; if it's installed,
4210the command will delete the package.
4211
4212Optional argument NOQUERY non-nil means do not ask the user to
4213confirm the installations/deletions; this is always nil in interactive
4214invocations."
4215 (interactive nil package-menu-mode)
4216 (package--ensure-package-menu-mode)
4217 (let (install-list delete-list cmd pkg-desc)
4218 (save-excursion
4219 (goto-char (point-min))
4220 (while (not (eobp))
4221 (setq cmd (char-after))
4222 (unless (eq cmd ?\s)
4223 ;; This is the key PKG-DESC.
4224 (setq pkg-desc (tabulated-list-get-id))
4225 (cond ((eq cmd ?D)
4226 (push pkg-desc delete-list))
4227 ((eq cmd ?I)
4228 (push pkg-desc install-list))))
4229 (forward-line)))
4230 ;; Nothing marked.
4231 (unless (or delete-list install-list)
4232 ;; Not on a package line.
4233 (unless (and (tabulated-list-get-id)
4234 package-menu-use-current-if-no-marks)
4235 (user-error "No operations specified"))
4236 (let* ((id (tabulated-list-get-id))
4237 (status (package-menu-get-status)))
4238 (cond
4239 ((member status '("installed"))
4240 (push id delete-list))
4241 ((member status '("available" "avail-obso" "new" "dependency"))
4242 (push id install-list))
4243 (t (user-error "No default action available for status: %s"
4244 status)))))
4245 (let-alist (package-menu--partition-transaction install-list delete-list)
4246 (when (or noquery
4247 (package-menu--prompt-transaction-p .delete .install .upgrade))
4248 (let ((message-template
4249 (concat "[ "
4250 (when .delete
4251 (format "Delete %d " (length .delete)))
4252 (when .install
4253 (format "Install %d " (length .install)))
4254 (when .upgrade
4255 (format "Upgrade %d " (length .upgrade)))
4256 "]")))
4257 (message "Operation %s started" message-template)
4258 ;; Packages being upgraded are not marked as selected.
4259 (package--update-selected-packages .install .delete)
4260 (unless (package-menu--perform-transaction install-list delete-list)
4261 ;; If there weren't errors, output data.
4262 (if-let* ((removable (package--removable-packages)))
4263 (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them"
4264 (length removable)
4265 (substitute-command-keys "\\[package-autoremove]"))
4266 (message "Operation %s finished" message-template))))))))
4267
4268(defun package-menu--version-predicate (A B)
4269 "Predicate to sort \"*Packages*\" buffer by the version column.
4270This is used for `tabulated-list-format' in `package-menu-mode'."
4271 (let ((vA (or (ignore-error error (version-to-list (aref (cadr A) 1))) '(0)))
4272 (vB (or (ignore-error error (version-to-list (aref (cadr B) 1))) '(0))))
4273 (if (version-list-= vA vB)
4274 (package-menu--name-predicate A B)
4275 (version-list-< vA vB))))
4276
4277(defun package-menu--status-predicate (A B)
4278 "Predicate to sort \"*Packages*\" buffer by the status column.
4279This is used for `tabulated-list-format' in `package-menu-mode'."
4280 (let ((sA (aref (cadr A) 2))
4281 (sB (aref (cadr B) 2)))
4282 (cond ((string= sA sB)
4283 (package-menu--name-predicate A B))
4284 ((string= sA "new") t)
4285 ((string= sB "new") nil)
4286 ((string-prefix-p "avail" sA)
4287 (if (string-prefix-p "avail" sB)
4288 (package-menu--name-predicate A B)
4289 t))
4290 ((string-prefix-p "avail" sB) nil)
4291 ((string= sA "installed") t)
4292 ((string= sB "installed") nil)
4293 ((string= sA "dependency") t)
4294 ((string= sB "dependency") nil)
4295 ((string= sA "source") t)
4296 ((string= sB "source") nil)
4297 ((string= sA "unsigned") t)
4298 ((string= sB "unsigned") nil)
4299 ((string= sA "held") t)
4300 ((string= sB "held") nil)
4301 ((string= sA "external") t)
4302 ((string= sB "external") nil)
4303 ((string= sA "built-in") t)
4304 ((string= sB "built-in") nil)
4305 ((string= sA "obsolete") t)
4306 ((string= sB "obsolete") nil)
4307 ((string= sA "incompat") t)
4308 ((string= sB "incompat") nil)
4309 (t (string< sA sB)))))
4310
4311(defun package-menu--description-predicate (A B)
4312 "Predicate to sort \"*Packages*\" buffer by the description column.
4313This is used for `tabulated-list-format' in `package-menu-mode'."
4314 (let ((dA (aref (cadr A) (if (cdr package-archives) 4 3)))
4315 (dB (aref (cadr B) (if (cdr package-archives) 4 3))))
4316 (if (string= dA dB)
4317 (package-menu--name-predicate A B)
4318 (string< dA dB))))
4319
4320(defun package-menu--name-predicate (A B)
4321 "Predicate to sort \"*Packages*\" buffer by the name column.
4322This is used for `tabulated-list-format' in `package-menu-mode'."
4323 (string< (symbol-name (package-desc-name (car A)))
4324 (symbol-name (package-desc-name (car B)))))
4325
4326(defun package-menu--archive-predicate (A B)
4327 "Predicate to sort \"*Packages*\" buffer by the archive column.
4328This is used for `tabulated-list-format' in `package-menu-mode'."
4329 (let ((a (or (package-desc-archive (car A)) ""))
4330 (b (or (package-desc-archive (car B)) "")))
4331 (if (string= a b)
4332 (package-menu--name-predicate A B)
4333 (string< a b))))
4334
4335(defun package-menu--populate-new-package-list ()
4336 "Decide which packages are new in `package-archive-contents'.
4337Store this list in `package-menu--new-package-list'."
4338 ;; Find which packages are new.
4339 (when package-menu--old-archive-contents
4340 (dolist (elt package-archive-contents)
4341 (unless (assq (car elt) package-menu--old-archive-contents)
4342 (push (car elt) package-menu--new-package-list)))
4343 (setq package-menu--old-archive-contents nil)))
4344
4345(defun package-menu--find-and-notify-upgrades ()
4346 "Notify the user of upgradable packages."
4347 (when-let* ((upgrades (package-menu--find-upgrades)))
4348 (message "Packages that can be upgraded: %d; type `%s' to mark for upgrading."
4349 (length upgrades)
4350 (substitute-command-keys "\\[package-menu-mark-upgrades]"))))
4351
4352
4353(defun package-menu--post-refresh ()
4354 "Revert \"*Packages*\" buffer and check for new packages and upgrades.
4355Do nothing if there's no *Packages* buffer.
4356
4357This function is called after `package-refresh-contents' and it
4358is added to `post-command-hook' by any function which alters the
4359package database (`package-install' and `package-delete'). When
4360run, it removes itself from `post-command-hook'."
4361 (remove-hook 'post-command-hook #'package-menu--post-refresh)
4362 (let ((buf (get-buffer "*Packages*")))
4363 (when (buffer-live-p buf)
4364 (with-current-buffer buf
4365 (package-menu--populate-new-package-list)
4366 (run-hooks 'tabulated-list-revert-hook)
4367 (tabulated-list-print 'remember 'update)))))
4368
4369(defun package-menu--mark-or-notify-upgrades ()
4370 "If there's a *Packages* buffer, check for upgrades and possibly mark them.
4371Do nothing if there's no *Packages* buffer. If there are
4372upgrades, mark them if `package-menu--mark-upgrades-pending' is
4373non-nil, otherwise just notify the user that there are upgrades.
4374This function is called after `package-refresh-contents'."
4375 (let ((buf (get-buffer "*Packages*")))
4376 (when (buffer-live-p buf)
4377 (with-current-buffer buf
4378 (if package-menu--mark-upgrades-pending
4379 (package-menu--mark-upgrades-1)
4380 (package-menu--find-and-notify-upgrades))))))
4381
4382;;;###autoload
4383(defun list-packages (&optional no-fetch)
4384 "Display a list of packages.
4385This first fetches the updated list of packages before
4386displaying, unless a prefix argument NO-FETCH is specified.
4387The list is displayed in a buffer named `*Packages*', and
4388includes the package's version, availability status, and a
4389short description."
4390 (interactive "P")
4391 (require 'finder-inf nil t)
4392 ;; Initialize the package system if necessary.
4393 (unless package--initialized
4394 (package-initialize t))
4395 ;; Integrate the package-menu with updating the archives.
4396 (add-hook 'package--post-download-archives-hook
4397 #'package-menu--post-refresh)
4398 (add-hook 'package--post-download-archives-hook
4399 #'package-menu--mark-or-notify-upgrades 'append)
4400 (add-hook 'package--post-download-archives-hook
4401 #'package-menu--set-mode-line-format 'append)
4402
4403 ;; Generate the Package Menu.
4404 (let ((buf (get-buffer-create "*Packages*")))
4405 (with-current-buffer buf
4406 ;; Since some packages have their descriptions include non-ASCII
4407 ;; characters...
4408 (setq buffer-file-coding-system 'utf-8)
4409 (package-menu-mode)
4410
4411 ;; Fetch the remote list of packages.
4412 (unless no-fetch (package-menu--refresh-contents))
4413
4414 ;; If we're not async, this would be redundant.
4415 (when package-menu-async
4416 (package-menu--generate nil t)))
4417 ;; The package menu buffer has keybindings. If the user types
4418 ;; `M-x list-packages', that suggests it should become current.
4419 (pop-to-buffer-same-window buf)))
4420
4421;;;###autoload
4422(defalias 'package-list-packages 'list-packages)
4423
4424;; Used in finder.el
4425(defun package-show-package-list (&optional packages keywords)
4426 "Display PACKAGES in a *Packages* buffer.
4427This is similar to `list-packages', but it does not fetch the
4428updated list of packages, and it only displays packages with
4429names in PACKAGES (which should be a list of symbols).
4430
4431When KEYWORDS are given, only packages with those KEYWORDS are
4432shown."
4433 (interactive)
4434 (require 'finder-inf nil t)
4435 (let* ((buf (get-buffer-create "*Packages*"))
4436 (win (get-buffer-window buf)))
4437 (with-current-buffer buf
4438 (package-menu-mode)
4439 (package-menu--generate nil packages keywords))
4440 (if win
4441 (select-window win)
4442 (switch-to-buffer buf))))
4443
4444(defun package-menu--filter-by (predicate suffix)
4445 "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header.
4446PREDICATE is a function which will be called with one argument, a
4447`package-desc' object, and returns t if that object should be
4448listed in the Package Menu.
4449
4450SUFFIX is passed on to `package-menu--display' and is added to
4451the header line of the first column."
4452 ;; Update `tabulated-list-entries' so that it contains all
4453 ;; packages before searching.
4454 (package-menu--refresh t nil)
4455 (let (found-entries)
4456 (dolist (entry tabulated-list-entries)
4457 (when (funcall predicate (car entry))
4458 (push entry found-entries)))
4459 (if found-entries
4460 (progn
4461 (setq tabulated-list-entries found-entries)
4462 (package-menu--display t suffix))
4463 (user-error "No packages found"))))
4464
4465(defun package-menu-filter-by-archive (archive)
4466 "Filter the \"*Packages*\" buffer by ARCHIVE.
4467Display only packages from package archive ARCHIVE.
4468ARCHIVE can be the name of a single archive (a string), or
4469a list of archive names. If ARCHIVE is nil or an empty
4470string, show all packages.
4471
4472When called interactively, prompt for ARCHIVE. To specify
4473several archives, type their names separated by commas."
4474 (interactive (list (completing-read-multiple
4475 "Filter by archive: "
4476 (mapcar #'car package-archives)))
4477 package-menu-mode)
4478 (package--ensure-package-menu-mode)
4479 (let ((archives (ensure-list archive)))
4480 (package-menu--filter-by
4481 (lambda (pkg-desc)
4482 (let ((pkg-archive (package-desc-archive pkg-desc)))
4483 (or (null archives)
4484 (and pkg-archive
4485 (member pkg-archive archives)))))
4486 (concat "archive:" (string-join archives ",")))))
4487
4488(defun package-menu-filter-by-description (description)
4489 "Filter the \"*Packages*\" buffer by the regexp DESCRIPTION.
4490Display only packages whose description matches the regexp
4491given as DESCRIPTION.
4492
4493When called interactively, prompt for DESCRIPTION.
4494
4495If DESCRIPTION is nil or the empty string, show all packages."
4496 (interactive (list (read-regexp "Filter by description (regexp)"))
4497 package-menu-mode)
4498 (package--ensure-package-menu-mode)
4499 (if (or (not description) (string-empty-p description))
4500 (package-menu--generate t t)
4501 (package-menu--filter-by (lambda (pkg-desc)
4502 (string-match description
4503 (package-desc-summary pkg-desc)))
4504 (format "desc:%s" description))))
4505
4506(defun package-menu-filter-by-keyword (keyword)
4507 "Filter the \"*Packages*\" buffer by KEYWORD.
4508Display only packages whose keywords match the specified KEYWORD.
4509KEYWORD can be a string or a list of strings. If KEYWORD is nil
4510or the empty string, show all packages.
4511
4512In addition to package keywords, KEYWORD can include the name(s)
4513of archive(s) and the package status, such as \"available\"
4514or \"built-in\" or \"obsolete\".
4515
4516When called interactively, prompt for KEYWORD. To specify several
4517keywords, type them separated by commas."
4518 (interactive (list (completing-read-multiple
4519 "Keywords: "
4520 (package-all-keywords)))
4521 package-menu-mode)
4522 (package--ensure-package-menu-mode)
4523 (when (stringp keyword)
4524 (setq keyword (list keyword)))
4525 (if (not keyword)
4526 (package-menu--generate t t)
4527 (package-menu--filter-by (lambda (pkg-desc)
4528 (package--has-keyword-p pkg-desc keyword))
4529 (concat "keyword:" (string-join keyword ",")))))
4530
4531(define-obsolete-function-alias
4532 'package-menu-filter #'package-menu-filter-by-keyword "27.1")
4533
4534(defun package-menu-filter-by-name-or-description (name-or-description)
4535 "Filter the \"*Packages*\" buffer by the regexp NAME-OR-DESCRIPTION.
4536Display only packages whose name or description matches the regexp
4537NAME-OR-DESCRIPTION.
4538
4539When called interactively, prompt for NAME-OR-DESCRIPTION.
4540
4541If NAME-OR-DESCRIPTION is nil or the empty string, show all
4542packages."
4543 (interactive (list (read-regexp "Filter by name or description (regexp)"))
4544 package-menu-mode)
4545 (package--ensure-package-menu-mode)
4546 (if (or (not name-or-description) (string-empty-p name-or-description))
4547 (package-menu--generate t t)
4548 (package-menu--filter-by (lambda (pkg-desc)
4549 (or (string-match name-or-description
4550 (package-desc-summary pkg-desc))
4551 (string-match name-or-description
4552 (symbol-name
4553 (package-desc-name pkg-desc)))))
4554 (format "name-or-desc:%s" name-or-description))))
4555
4556(defun package-menu-filter-by-name (name)
4557 "Filter the \"*Packages*\" buffer by the regexp NAME.
4558Display only packages whose name matches the regexp NAME.
4559
4560When called interactively, prompt for NAME.
4561
4562If NAME is nil or the empty string, show all packages."
4563 (interactive (list (read-regexp "Filter by name (regexp)"))
4564 package-menu-mode)
4565 (package--ensure-package-menu-mode)
4566 (if (or (not name) (string-empty-p name))
4567 (package-menu--generate t t)
4568 (package-menu--filter-by (lambda (pkg-desc)
4569 (string-match-p name (symbol-name
4570 (package-desc-name pkg-desc))))
4571 (format "name:%s" name))))
4572
4573(defun package-menu-filter-by-status (status)
4574 "Filter the \"*Packages*\" buffer by STATUS.
4575Display only packages with specified STATUS.
4576STATUS can be a single status, a string, or a list of strings.
4577If STATUS is nil or the empty string, show all packages.
4578
4579When called interactively, prompt for STATUS. To specify
4580several possible status values, type them separated by commas."
4581 (interactive (list (completing-read "Filter by status: "
4582 '("avail-obso"
4583 "available"
4584 "built-in"
4585 "dependency"
4586 "disabled"
4587 "external"
4588 "held"
4589 "incompat"
4590 "installed"
4591 "source"
4592 "new"
4593 "unsigned")))
4594 package-menu-mode)
4595 (package--ensure-package-menu-mode)
4596 (if (or (not status) (string-empty-p status))
4597 (package-menu--generate t t)
4598 (let ((status-list
4599 (if (listp status)
4600 status
4601 (split-string status ","))))
4602 (package-menu--filter-by
4603 (lambda (pkg-desc)
4604 (member (package-desc-status pkg-desc) status-list))
4605 (format "status:%s" (string-join status-list ","))))))
4606
4607(defun package-menu-filter-by-version (version predicate)
4608 "Filter the \"*Packages*\" buffer by VERSION and PREDICATE.
4609Display only packages whose version satisfies the condition
4610defined by VERSION and PREDICATE.
4611
4612When called interactively, prompt for one of the comparison operators
4613`<', `>' or `=', and for a version. Show only packages whose version
4614is lower (`<'), equal (`=') or higher (`>') than the specified VERSION.
4615
4616When called from Lisp, VERSION should be a version string and
4617PREDICATE should be the symbol `=', `<' or `>'.
4618
4619If VERSION is nil or the empty string, show all packages."
4620 (interactive (let ((choice (intern
4621 (char-to-string
4622 (read-char-choice
4623 "Filter by version? [Type =, <, > or q] "
4624 '(?< ?> ?= ?q))))))
4625 (if (eq choice 'q)
4626 '(quit nil)
4627 (list (read-from-minibuffer
4628 (concat "Filter by version ("
4629 (pcase choice
4630 ('= "= equal to")
4631 ('< "< less than")
4632 ('> "> greater than"))
4633 "): "))
4634 choice)))
4635 package-menu-mode)
4636 (package--ensure-package-menu-mode)
4637 (unless (equal predicate 'quit)
4638 (if (or (not version) (string-empty-p version))
4639 (package-menu--generate t t)
4640 (package-menu--filter-by
4641 (let ((fun (pcase predicate
4642 ('= #'version-list-=)
4643 ('< #'version-list-<)
4644 ('> (lambda (a b) (not (version-list-<= a b))))
4645 (_ (error "Unknown predicate: %s" predicate))))
4646 (ver (version-to-list version)))
4647 (lambda (pkg-desc)
4648 (funcall fun (package-desc-version pkg-desc) ver)))
4649 (format "versions:%s%s" predicate version)))))
4650
4651(defun package-menu-filter-marked ()
4652 "Filter \"*Packages*\" buffer by non-empty mark.
4653Show only the packages that have been marked for installation or deletion.
4654Unlike other filters, this leaves the marks intact."
4655 (interactive nil package-menu-mode)
4656 (package--ensure-package-menu-mode)
4657 (widen)
4658 (let (found-entries mark pkg-id entry marks)
4659 (save-excursion
4660 (goto-char (point-min))
4661 (while (not (eobp))
4662 (setq mark (char-after))
4663 (unless (eq mark ?\s)
4664 (setq pkg-id (tabulated-list-get-id))
4665 (setq entry (package-menu--print-info-simple pkg-id))
4666 (push entry found-entries)
4667 ;; remember the mark
4668 (push (cons pkg-id mark) marks))
4669 (forward-line))
4670 (if found-entries
4671 (progn
4672 (setq tabulated-list-entries found-entries)
4673 (package-menu--display t nil)
4674 ;; redo the marks, but we must remember the marks!!
4675 (goto-char (point-min))
4676 (while (not (eobp))
4677 (setq mark (cdr (assq (tabulated-list-get-id) marks)))
4678 (tabulated-list-put-tag (char-to-string mark) t)))
4679 (user-error "No packages found")))))
4680
4681(defun package-menu-filter-upgradable ()
4682 "Filter \"*Packages*\" buffer to show only upgradable packages."
4683 (interactive nil package-menu-mode)
4684 (let ((pkgs (mapcar #'car (package-menu--find-upgrades))))
4685 (package-menu--filter-by
4686 (lambda (pkg)
4687 (memql (package-desc-name pkg) pkgs))
4688 "upgradable")))
4689
4690(defun package-menu-clear-filter ()
4691 "Clear any filter currently applied to the \"*Packages*\" buffer."
4692 (interactive nil package-menu-mode)
4693 (package--ensure-package-menu-mode)
4694 (package-menu--generate t t))
4695
4696(defun package-list-packages-no-fetch ()
4697 "Display a list of packages.
4698Does not fetch the updated list of packages before displaying.
4699The list is displayed in a buffer named `*Packages*'."
4700 (interactive)
4701 (list-packages t))
4702
4703;;;###autoload
4704(defun package-get-version ()
4705 "Return the version number of the package in which this is used.
4706Assumes it is used from an Elisp file placed inside the top-level directory
4707of an installed ELPA package.
4708The return value is a string (or nil in case we can't find it).
4709It works in more cases if the call is in the file which contains
4710the `Version:' header."
4711 ;; In a sense, this is a lie, but it does just what we want: precomputes
4712 ;; the version at compile time and hardcodes it into the .elc file!
4713 (declare (pure t))
4714 ;; Hack alert!
4715 (let ((file (or (macroexp-file-name) buffer-file-name)))
4716 (cond
4717 ((null file) nil)
4718 ;; Packages are normally installed into directories named "<pkg>-<vers>",
4719 ;; so get the version number from there.
4720 ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file)
4721 (match-string 1 file))
4722 ;; For packages run straight from the an elpa.git clone, there's no
4723 ;; "-<vers>" in the directory name, so we have to fetch the version
4724 ;; the hard way.
4725 (t
4726 (let* ((pkgdir (file-name-directory file))
4727 (pkgname (file-name-nondirectory (directory-file-name pkgdir)))
4728 (mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
4729 (unless (file-readable-p mainfile) (setq mainfile file))
4730 (when (file-readable-p mainfile)
4731 (require 'lisp-mnt)
4732 (lm-package-version mainfile)))))))
4733
4734
4735;;;; Quickstart: precompute activation actions for faster start up.
4736
4737;; Activating packages via `package-initialize' is costly: for N installed
4738;; packages, it needs to read all N <pkg>-pkg.el files first to decide
4739;; which packages to activate, and then again N <pkg>-autoloads.el files.
4740;; To speed this up, we precompute a mega-autoloads file which is the
4741;; concatenation of all those <pkg>-autoloads.el, so we can activate
4742;; all packages by loading this one file (and hence without initializing
4743;; package.el).
4744
4745;; Other than speeding things up, this also offers a bootstrap feature:
4746;; it lets us activate packages according to `package-load-list' and
4747;; `package-user-dir' even before those vars are set.
4748
4749(defcustom package-quickstart nil
4750 "Precompute activation actions to speed up startup.
4751This requires the use of `package-quickstart-refresh' every time the
4752activations need to be changed, such as when `package-load-list' is modified."
4753 :type 'boolean
4754 :version "27.1")
4755
4756;;;###autoload
4757(defcustom package-quickstart-file
4758 (locate-user-emacs-file "package-quickstart.el")
4759 "Location of the file used to speed up activation of packages at startup."
4760 :type 'file
4761 :group 'applications
4762 :initialize #'custom-initialize-delay
4763 :version "27.1")
4764
4765(defun package--quickstart-maybe-refresh ()
4766 (if package-quickstart
4767 ;; FIXME: Delay refresh in case we're installing/deleting
4768 ;; several packages!
4769 (package-quickstart-refresh)
4770 (delete-file (concat package-quickstart-file "c"))
4771 (delete-file package-quickstart-file)))
4772
4773(defvar package--quickstart-dir nil
4774 "Set by `package-quickstart-file' to the directory containing it.")
4775
4776(defun package--quickstart-rel (file)
4777 "Return an expr depending on `package--quickstart-dir' which evaluates to FILE.
4778
4779If FILE is in `package--quickstart-dir', returns an expression that is
4780relative to that directory, so if that directory is moved we can still
4781find FILE."
4782 (if (file-in-directory-p file package--quickstart-dir)
4783 `(file-name-concat package--quickstart-dir ,(file-relative-name file package--quickstart-dir))
4784 file))
4785
4786(defun package-quickstart-refresh ()
4787 "(Re)Generate the `package-quickstart-file'."
4788 (interactive)
4789 (package-initialize 'no-activate)
4790 (require 'info)
4791 (let ((package--quickstart-pkgs ())
4792 ;; Pretend we haven't activated anything yet!
4793 (package-activated-list ())
4794 ;; Make sure we can load this file without load-source-file-function.
4795 (coding-system-for-write 'emacs-internal)
4796 ;; Ensure that `pp' and `prin1-to-string' calls further down
4797 ;; aren't truncated.
4798 (print-length nil)
4799 (print-level nil)
4800 (Info-directory-list '(""))
4801 (package--quickstart-dir nil))
4802 (dolist (elt package-alist)
4803 (condition-case err
4804 (package-activate (car elt))
4805 ;; Don't let failure of activation of a package arbitrarily stop
4806 ;; activation of further packages.
4807 (error (message "%s" (error-message-string err)))))
4808 (setq package--quickstart-pkgs (nreverse package--quickstart-pkgs))
4809 (with-temp-file package-quickstart-file
4810 (emacs-lisp-mode) ;For `syntax-ppss'.
4811 (insert ";;; Quickstart file to activate all packages at startup -*- lexical-binding:t -*-\n")
4812 (insert ";; ¡¡ This file is autogenerated by `package-quickstart-refresh', DO NOT EDIT !!\n\n")
4813 (setq package--quickstart-dir
4814 (file-name-directory (expand-file-name package-quickstart-file)))
4815 (pp '(setq package--quickstart-dir
4816 (file-name-directory (expand-file-name load-file-name)))
4817 (current-buffer))
4818 (dolist (pkg package--quickstart-pkgs)
4819 (let* ((file
4820 ;; Prefer uncompiled files (and don't accept .so files).
4821 (let ((load-suffixes '(".el" ".elc")))
4822 (locate-library (package--autoloads-file-name pkg))))
4823 (pfile (prin1-to-string (package--quickstart-rel file))))
4824 (insert "(let* ((load-file-name " pfile ")\
4825\(load-true-file-name load-file-name))\n")
4826 (insert-file-contents file)
4827 ;; Fixup the special #$ reader form and throw away comments.
4828 (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
4829 (unless (ppss-string-terminator (save-match-data (syntax-ppss)))
4830 (replace-match (if (match-end 1) "" pfile) t t)))
4831 (unless (bolp) (insert "\n"))
4832 (insert ")\n")))
4833 (pp `(defvar package-activated-list) (current-buffer))
4834 (pp `(setq package-activated-list
4835 (delete-dups
4836 (append ',(mapcar #'package-desc-name package--quickstart-pkgs)
4837 package-activated-list)))
4838 (current-buffer))
4839 (let ((info-dirs
4840 (mapcar #'package--quickstart-rel (butlast Info-directory-list))))
4841 (when info-dirs
4842 (pp `(progn (require 'info)
4843 (info-initialize)
4844 (setq Info-directory-list
4845 (append (list . ,info-dirs) Info-directory-list)))
4846 (current-buffer))))
4847 ;; Use `\s' instead of a space character, so this code chunk is not
4848 ;; mistaken for an actual file-local section of package.el.
4849 (insert "
4850;; Local\sVariables:
4851;; version-control: never
4852;; no-update-autoloads: t
4853;; byte-compile-warnings: (not make-local)
4854;; End:
4855"))
4856 ;; FIXME: Do it asynchronously in an Emacs subprocess, and
4857 ;; don't show the byte-compiler warnings.
4858 (byte-compile-file package-quickstart-file)))
4859
4860(defun package--imenu-prev-index-position-function ()
4861 "Move point to previous line in package-menu buffer.
4862This function is used as a value for
4863`imenu-prev-index-position-function'."
4864 (unless (bobp)
4865 (forward-line -1)))
4866
4867(defun package--imenu-extract-index-name-function ()
4868 "Return imenu name for line at point.
4869This function is used as a value for
4870`imenu-extract-index-name-function'. Point should be at the
4871beginning of the line."
4872 (let ((package-desc (tabulated-list-get-id)))
4873 (format "%s (%s): %s"
4874 (package-desc-name package-desc)
4875 (package-version-join (package-desc-version package-desc))
4876 (package-desc-summary package-desc))))
4877
4878(defun package--query-desc (&optional alist)
4879 "Query the user for a package or return the package at point.
4880The optional argument ALIST must consist of elements with the
4881form (PKG-NAME PKG-DESC). If not specified, it will default to
4882`package-alist'."
4883 (or (tabulated-list-get-id)
4884 (let ((alist (or alist package-alist)))
4885 (cadr (assoc (completing-read "Package: " alist nil t)
4886 alist #'string=)))))
4887
4888(defun package-browse-url (desc &optional secondary)
4889 "Open the website of the package under point in a browser.
4890`browse-url' is used to determine the browser to be used. If
4891SECONDARY (interactively, the prefix), use the secondary browser.
4892DESC must be a `package-desc' object."
4893 (interactive (list (package--query-desc)
4894 current-prefix-arg)
4895 package-menu-mode)
4896 (unless desc
4897 (user-error "No package here"))
4898 (let ((url (cdr (assoc :url (package-desc-extras desc)))))
4899 (unless url
4900 (user-error "No website for %s" (package-desc-name desc)))
4901 (if secondary
4902 (funcall browse-url-secondary-browser-function url)
4903 (browse-url url))))
4904
4905(declare-function ietf-drums-parse-address "ietf-drums"
4906 (string &optional decode))
4907
4908(defun package-maintainers (pkg-desc &optional no-error)
4909 "Return an email address for the maintainers of PKG-DESC.
4910The email address may contain commas, if there are multiple
4911maintainers. If no maintainers are found, an error will be
4912signaled. If the optional argument NO-ERROR is non-nil no error
4913will be signaled in that case."
4914 (unless (package-desc-p pkg-desc)
4915 (error "Invalid package description: %S" pkg-desc))
4916 (let* ((name (package-desc-name pkg-desc))
4917 (extras (package-desc-extras pkg-desc))
4918 (maint (alist-get :maintainer extras)))
4919 (unless (listp (cdr maint))
4920 (setq maint (list maint)))
4921 (cond
4922 ((and (null maint) (null no-error))
4923 (user-error "Package `%s' has no explicit maintainer" name))
4924 ((and (not (progn
4925 (require 'ietf-drums)
4926 (ietf-drums-parse-address (cdar maint))))
4927 (null no-error))
4928 (user-error "Package `%s' has no maintainer address" name))
4929 (t
4930 (with-temp-buffer
4931 (mapc #'package--print-email-button maint)
4932 (replace-regexp-in-string
4933 "\n" ", " (string-trim
4934 (buffer-substring-no-properties
4935 (point-min) (point-max)))))))))
4936
4937;;;###autoload
4938(defun package-report-bug (desc)
4939 "Prepare a message to send to the maintainers of a package.
4940DESC must be a `package-desc' object."
4941 (interactive (list (package--query-desc package-alist))
4942 package-menu-mode)
4943 (let ((maint (package-maintainers desc))
4944 (name (symbol-name (package-desc-name desc)))
4945 (pkgdir (package-desc-dir desc))
4946 vars)
4947 (when pkgdir
4948 (dolist-with-progress-reporter (group custom-current-group-alist)
4949 "Scanning for modified user options..."
4950 (when (and (car group)
4951 (file-in-directory-p (car group) pkgdir))
4952 (dolist (ent (get (cdr group) 'custom-group))
4953 (when (and (custom-variable-p (car ent))
4954 (boundp (car ent))
4955 (not (eq (custom--standard-value (car ent))
4956 (default-toplevel-value (car ent)))))
4957 (push (car ent) vars))))))
4958 (dlet ((reporter-prompt-for-summary-p t))
4959 (reporter-submit-bug-report maint name vars))))
4960
4961;;;; Introspection
4962
4963(defun package-get-descriptor (pkg-name)
4964 "Return the `package-desc' of PKG-NAME."
4965 (unless package--initialized (package-initialize 'no-activate))
4966 (or (package--get-activatable-pkg pkg-name)
4967 (cadr (assq pkg-name package-alist))
4968 (cadr (assq pkg-name package-archive-contents))))
4969
4970(provide 'package)
4971
4972;;; package.el ends here
diff --git a/lisp/package/package-compile.el b/lisp/package/package-compile.el
new file mode 100644
index 00000000000..ffe94880efd
--- /dev/null
+++ b/lisp/package/package-compile.el
@@ -0,0 +1,111 @@
1;;; package-compile.el --- Byte-Compilation of Packages -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;; Code:
23
24(require 'package-core)
25
26(defvar warning-minimum-level)
27(defvar byte-compile-ignore-files)
28
29(defcustom package-native-compile nil
30 "Non-nil means to natively compile packages as part of their installation.
31This controls ahead-of-time compilation of packages when they are
32installed. If this option is nil, packages will be natively
33compiled when they are loaded for the first time.
34
35This option does not have any effect if Emacs was not built with
36native compilation support."
37 :type '(boolean)
38 :risky t
39 :version "28.1"
40 :group 'package)
41
42(defun package--parse-elpaignore (pkg-desc)
43 "Return a list of regular expressions to match files ignored by PKG-DESC."
44 (let* ((pkg-dir (file-name-as-directory (package-desc-dir pkg-desc)))
45 (ignore (expand-file-name ".elpaignore" pkg-dir))
46 files)
47 (when (file-exists-p ignore)
48 (with-temp-buffer
49 (insert-file-contents ignore)
50 (goto-char (point-min))
51 (while (not (eobp))
52 (push (wildcard-to-regexp
53 (let ((line (buffer-substring
54 (line-beginning-position)
55 (line-end-position))))
56 (file-name-concat pkg-dir (string-trim-left line "/"))))
57 files)
58 (forward-line)))
59 files)))
60
61(defun package--compile (pkg-desc)
62 "Byte-compile installed package PKG-DESC.
63This assumes that `pkg-desc' has already been activated with
64`package-activate-1'."
65 (let ((byte-compile-ignore-files (package--parse-elpaignore pkg-desc))
66 (warning-minimum-level :error)
67 (load-path load-path))
68 (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
69
70(defun package--native-compile-async (pkg-desc)
71 "Native compile installed package PKG-DESC asynchronously.
72This assumes that `pkg-desc' has already been activated with
73`package-activate-1'."
74 (when (native-comp-available-p)
75 (let ((warning-minimum-level :error))
76 (native-compile-async (package-desc-dir pkg-desc) t))))
77
78
79
80;;;###autoload
81(defun package-recompile (pkg)
82 "Byte-compile package PKG again.
83PKG should be either a symbol, the package name, or a `package-desc'
84object."
85 (interactive (list (intern (completing-read
86 "Recompile package: "
87 (mapcar #'symbol-name
88 (mapcar #'car package-alist))))))
89 (let ((pkg-desc (if (package-desc-p pkg)
90 pkg
91 (cadr (assq pkg package-alist)))))
92 ;; Delete the old .elc files to ensure that we don't inadvertently
93 ;; load them (in case they contain byte code/macros that are now
94 ;; invalid).
95 (dolist (elc (directory-files-recursively
96 (package-desc-dir pkg-desc) "\\.elc\\'"))
97 (delete-file elc))
98 (package--compile pkg-desc)))
99
100;;;###autoload
101(defun package-recompile-all ()
102 "Byte-compile all installed packages.
103This is meant to be used only in the case the byte-compiled files
104are invalid due to changed byte-code, macros or the like."
105 (interactive)
106 (pcase-dolist (`(_ ,pkg-desc) package-alist)
107 (with-demoted-errors "Error while recompiling: %S"
108 (package-recompile pkg-desc))))
109
110(provide 'package-compile)
111;;; package-compile.el ends here
diff --git a/lisp/package/package-core.el b/lisp/package/package-core.el
new file mode 100644
index 00000000000..83a04402705
--- /dev/null
+++ b/lisp/package/package-core.el
@@ -0,0 +1,927 @@
1;;; package-core.el --- Core of the Emacs Package Manager -*- lexical-binding:t -*-
2
3;; Copyright (C) 2007-2025 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;; TODO
30
31;;; Code:
32
33(eval-and-compile (require 'cl-lib))
34(eval-when-compile (require 'epg)) ;For setf accessors.
35(eval-when-compile (require 'inline)) ;For `define-inline'
36
37(defvar package--default-summary "No description available.")
38
39(defvar package-list-unversioned nil
40 "If non-nil, include packages that don't have a version in `list-packages'.")
41
42(defvar package-list-unsigned nil
43 "If non-nil, mention in the list which packages were installed without signature.")
44
45(defvar package--emacs-version-list (version-to-list emacs-version)
46 "The value of variable `emacs-version' as a list.")
47
48(define-inline package-vc-p (pkg-desc)
49 "Return non-nil if PKG-DESC is a VC package."
50 (inline-letevals (pkg-desc)
51 (inline-quote (eq (package-desc-kind ,pkg-desc) 'vc))))
52
53(cl-defstruct (package-desc
54 ;; Rename the default constructor from `make-package-desc'.
55 (:constructor package-desc-create)
56 ;; Has the same interface as the old `define-package',
57 ;; which is still used in the "foo-pkg.el" files. Extra
58 ;; options can be supported by adding additional keys.
59 (:constructor
60 package-desc-from-define
61 (name-string version-string &optional summary requirements
62 &rest rest-plist
63 &aux
64 (name (intern name-string))
65 (version (if (eq (car-safe version-string) 'vc)
66 (version-to-list (cdr version-string))
67 (version-to-list version-string)))
68 (reqs (mapcar (lambda (elt)
69 (list (car elt)
70 (version-to-list (cadr elt))))
71 (if (eq 'quote (car requirements))
72 (nth 1 requirements)
73 requirements)))
74 (kind (plist-get rest-plist :kind))
75 (archive (plist-get rest-plist :archive))
76 (extras (let (alist)
77 (while rest-plist
78 (unless (memq (car rest-plist) '(:kind :archive))
79 (let ((value (cadr rest-plist)))
80 (when value
81 (push (cons (car rest-plist)
82 (if (eq (car-safe value) 'quote)
83 (cadr value)
84 value))
85 alist))))
86 (setq rest-plist (cddr rest-plist)))
87 alist)))))
88 "Structure containing information about an individual package.
89Slots:
90
91`name' Name of the package, as a symbol.
92
93`version' Version of the package, as a version list.
94
95`summary' Short description of the package, typically taken from
96 the first line of the file.
97
98`reqs' Requirements of the package. A list of (PACKAGE
99 VERSION-LIST) naming the dependent package and the minimum
100 required version.
101
102`kind' The distribution format of the package. Currently, it is
103 either `single' or `tar'.
104
105`archive' The name of the archive (as a string) whence this
106 package came.
107
108`dir' The directory where the package is installed (if installed),
109 `builtin' if it is built-in, or nil otherwise.
110
111`extras' Optional alist of additional keyword-value pairs.
112
113`signed' Flag to indicate that the package is signed by provider."
114 name
115 version
116 (summary package--default-summary)
117 reqs
118 kind
119 archive
120 dir
121 extras
122 signed)
123
124(cl-defstruct (package--bi-desc
125 (:constructor package-make-builtin (version summary))
126 (:type vector))
127 "Package descriptor format used in finder-inf.el and package--builtins."
128 version
129 reqs
130 summary)
131
132(defun package--from-builtin (bi-desc)
133 "Create a `package-desc' object from BI-DESC.
134BI-DESC should be a `package--bi-desc' object."
135 (package-desc-create :name (pop bi-desc)
136 :version (package--bi-desc-version bi-desc)
137 :summary (package--bi-desc-summary bi-desc)
138 :dir 'builtin))
139
140(defun package-desc--keywords (pkg-desc)
141 "Return keywords of package-desc object PKG-DESC.
142These keywords come from the foo-pkg.el file, and in general
143corresponds to the keywords in the \"Keywords\" header of the
144package."
145 (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc)))))
146 (if (eq (car-safe keywords) 'quote)
147 (nth 1 keywords)
148 keywords)))
149
150(defun package--read-pkg-desc (kind)
151 "Read a `define-package' form in current buffer.
152Return the pkg-desc, with desc-kind set to KIND."
153 (goto-char (point-min))
154 (let* ((pkg-def-parsed (read (current-buffer)))
155 (pkg-desc
156 (when (eq (car pkg-def-parsed) 'define-package)
157 (apply #'package-desc-from-define
158 (append (cdr pkg-def-parsed))))))
159 (when pkg-desc
160 (setf (package-desc-kind pkg-desc) kind)
161 pkg-desc)))
162
163(defgroup package nil
164 "Manager for Emacs Lisp packages."
165 :group 'applications
166 :version "24.1")
167
168
169;;; Customization options
170
171;;;###autoload
172(defcustom package-enable-at-startup t
173 "Whether to make installed packages available when Emacs starts.
174If non-nil, packages are made available before reading the init
175file (but after reading the early init file). This means that if
176you wish to set this variable, you must do so in the early init
177file. Regardless of the value of this variable, packages are not
178made available if `user-init-file' is nil (e.g. Emacs was started
179with \"-q\").
180
181Even if the value is nil, you can type \\[package-initialize] to
182make installed packages available at any time, or you can
183call (package-activate-all) in your init-file.
184
185Note that this variable must be set to a non-default value in
186your early-init file, as the variable's value is used before
187loading the regular init file. Therefore, if you customize it
188via Customize, you should save your customized setting into
189your `early-init-file'."
190 :type 'boolean
191 :version "24.1")
192
193(defcustom package-load-list '(all)
194 "List of packages for `package-activate-all' to make available.
195Each element in this list should be a list (NAME VERSION), or the
196symbol `all'. The symbol `all' says to make available the latest
197installed versions of all packages not specified by other
198elements.
199
200For an element (NAME VERSION), NAME is a package name (a symbol).
201VERSION should be t, a string, or nil.
202If VERSION is t, the most recent version is made available.
203If VERSION is a string, only that version is ever made available.
204 Any other version, even if newer, is silently ignored.
205 Hence, the package is \"held\" at that version.
206If VERSION is nil, the package is not made available (it is \"disabled\")."
207 :type '(repeat (choice (const all)
208 (list :tag "Specific package"
209 (symbol :tag "Package name")
210 (choice :tag "Version"
211 (const :tag "disable" nil)
212 (const :tag "most recent" t)
213 (string :tag "specific version")))))
214 :risky t
215 :version "24.1")
216
217(defcustom package-pinned-packages nil
218 "An alist of packages that are pinned to specific archives.
219This can be useful if you have multiple package archives enabled,
220and want to control which archive a given package gets installed from.
221
222Each element of the alist has the form (PACKAGE . ARCHIVE), where:
223 PACKAGE is a symbol representing a package
224 ARCHIVE is a string representing an archive (it should be the car of
225an element in `package-archives', e.g. \"gnu\").
226
227Adding an entry to this variable means that only ARCHIVE will be
228considered as a source for PACKAGE. If other archives provide PACKAGE,
229they are ignored (for this package). If ARCHIVE does not contain PACKAGE,
230the package will be unavailable."
231 :type '(alist :key-type (symbol :tag "Package")
232 :value-type (string :tag "Archive name"))
233 ;; This could prevent you from receiving updates for a package,
234 ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue
235 ;; if PACKAGE has a known vulnerability that is fixed in newer versions.
236 :risky t
237 :version "24.4")
238
239;;;###autoload
240(defcustom package-user-dir (locate-user-emacs-file "elpa")
241 "Directory containing the user's Emacs Lisp packages.
242The directory name should be absolute.
243Apart from this directory, Emacs also looks for system-wide
244packages in `package-directory-list'."
245 :type 'directory
246 :initialize #'custom-initialize-delay
247 :risky t
248 :group 'applications
249 :version "24.1")
250
251;;;###autoload
252(defcustom package-directory-list
253 ;; Defaults are subdirs named "elpa" in the site-lisp dirs.
254 (let (result)
255 (dolist (f load-path)
256 (and (stringp f)
257 (equal (file-name-nondirectory f) "site-lisp")
258 (push (expand-file-name "elpa" f) result)))
259 (nreverse result))
260 "List of additional directories containing Emacs Lisp packages.
261Each directory name should be absolute.
262
263These directories contain packages intended for system-wide; in
264contrast, `package-user-dir' contains packages for personal use."
265 :type '(repeat directory)
266 :initialize #'custom-initialize-delay
267 :group 'applications
268 :risky t
269 :version "24.1")
270
271(defcustom package-selected-packages nil
272 "Store here packages installed explicitly by user.
273This variable is fed automatically by Emacs when installing a new package.
274This variable is used by `package-autoremove' to decide
275which packages are no longer needed.
276You can use it to (re)install packages on other machines
277by running `package-install-selected-packages'.
278
279To check if a package is contained in this list here, use
280`package--user-selected-p', as it may populate the variable with
281a sane initial value."
282 :version "25.1"
283 :type '(repeat symbol))
284
285;; Pseudo fields.
286(defun package-version-join (vlist)
287 "Return the version string corresponding to the list VLIST.
288This is, approximately, the inverse of `version-to-list'.
289\(Actually, it returns only one of the possible inverses, since
290`version-to-list' is a many-to-one operation.)"
291 (if (null vlist)
292 ""
293 (let ((str-list (list "." (int-to-string (car vlist)))))
294 (dolist (num (cdr vlist))
295 (cond
296 ((>= num 0)
297 (push (int-to-string num) str-list)
298 (push "." str-list))
299 ((< num -4)
300 (error "Invalid version list `%s'" vlist))
301 (t
302 ;; pre, or beta, or alpha
303 (cond ((equal "." (car str-list))
304 (pop str-list))
305 ((not (string-match "[0-9]+" (car str-list)))
306 (error "Invalid version list `%s'" vlist)))
307 (push (cond ((= num -1) "pre")
308 ((= num -2) "beta")
309 ((= num -3) "alpha")
310 ((= num -4) "snapshot"))
311 str-list))))
312 (if (equal "." (car str-list))
313 (pop str-list))
314 (apply #'concat (nreverse str-list)))))
315
316
317
318;;; Installed packages
319;; The following variables store information about packages present in
320;; the system. The most important of these is `package-alist'. The
321;; command `package-activate-all' is also closely related to this
322;; section.
323
324(defvar package--builtins nil
325 "Alist of built-in packages.
326The actual value is initialized by loading the library
327`finder-inf'; this is not done until it is needed, e.g. by the
328function `package-built-in-p'.
329
330Each element has the form (PKG . PACKAGE-BI-DESC), where PKG is a package
331name (a symbol) and DESC is a `package--bi-desc' structure.")
332(put 'package--builtins 'risky-local-variable t)
333
334(defvar package-alist nil
335 "Alist of all packages available for activation.
336Each element has the form (PKG . DESCS), where PKG is a package
337name (a symbol) and DESCS is a non-empty list of `package-desc'
338structures, sorted by decreasing versions.
339
340This variable is set automatically by `package-load-descriptor',
341called via `package-activate-all'. To change which packages are
342loaded and/or activated, customize `package-load-list'.")
343(put 'package-alist 'risky-local-variable t)
344
345;;;; Public interfaces for accessing built-in package info
346
347(defun package-versioned-builtin-packages ()
348 "Return a list of all the versioned built-in packages.
349The return value is a list of names of built-in packages represented as
350symbols."
351 (mapcar #'car package--builtin-versions))
352
353(defun package-builtin-package-version (package)
354 "Return the version of a built-in PACKAGE given by its symbol.
355The return value is a list of integers representing the version of
356PACKAGE, in the format returned by `version-to-list', or nil if the
357package is built-in but has no version or is not a built-in package."
358 (alist-get package package--builtin-versions))
359
360;;;###autoload
361(defvar package-activated-list nil
362 ;; FIXME: This should implicitly include all builtin packages.
363 "List of the names of currently activated packages.")
364(put 'package-activated-list 'risky-local-variable t)
365
366;;;; Populating `package-alist'.
367
368;; The following functions are called on each installed package by
369;; `package-load-all-descriptors', which ultimately populates the
370;; `package-alist' variable.
371
372(defun package-process-define-package (exp)
373 "Process define-package expression EXP and push it to `package-alist'.
374EXP should be a form read from a foo-pkg.el file.
375Convert EXP into a `package-desc' object using the
376`package-desc-from-define' constructor before pushing it to
377`package-alist'.
378
379If there already exists a package by the same name in
380`package-alist', insert this object there such that the packages
381are sorted with the highest version first."
382 (when (eq (car-safe exp) 'define-package)
383 (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp)))
384 (name (package-desc-name new-pkg-desc))
385 (version (package-desc-version new-pkg-desc))
386 (old-pkgs (assq name package-alist)))
387 (if (null old-pkgs)
388 ;; If there's no old package, just add this to `package-alist'.
389 (push (list name new-pkg-desc) package-alist)
390 ;; If there is, insert the new package at the right place in the list.
391 (while
392 (if (and (cdr old-pkgs)
393 (version-list-< version
394 (package-desc-version (cadr old-pkgs))))
395 (setq old-pkgs (cdr old-pkgs))
396 (push new-pkg-desc (cdr old-pkgs))
397 nil)))
398 new-pkg-desc)))
399
400(defun package-load-descriptor (pkg-dir)
401 "Load the package description file in directory PKG-DIR.
402Create a new `package-desc' object, add it to `package-alist' and
403return it."
404 (let ((pkg-file (expand-file-name (package--description-file pkg-dir)
405 pkg-dir))
406 (signed-file (concat pkg-dir ".signed")))
407 (when (file-exists-p pkg-file)
408 (with-temp-buffer
409 (insert-file-contents pkg-file)
410 (goto-char (point-min))
411 (let ((pkg-desc (or (package-process-define-package
412 (read (current-buffer)))
413 (error "Can't find define-package in %s" pkg-file))))
414 (setf (package-desc-dir pkg-desc) pkg-dir)
415 (if (file-exists-p signed-file)
416 (setf (package-desc-signed pkg-desc) t))
417 pkg-desc)))))
418
419(defun package-load-all-descriptors ()
420 "Load descriptors for installed Emacs Lisp packages.
421This looks for package subdirectories in `package-user-dir' and
422`package-directory-list'. The variable `package-load-list'
423controls which package subdirectories may be loaded.
424
425In each valid package subdirectory, this function loads the
426description file containing a call to `define-package', which
427updates `package-alist'."
428 (dolist (dir (cons package-user-dir package-directory-list))
429 (when (file-directory-p dir)
430 (dolist (pkg-dir (directory-files dir t "\\`[^.]"))
431 (when (file-directory-p pkg-dir)
432 (package-load-descriptor pkg-dir))))))
433
434(defun package--alist ()
435 "Return `package-alist', after computing it if needed."
436 (or package-alist
437 (progn (package-load-all-descriptors)
438 package-alist)))
439
440
441;;; Package activation
442;; Section for functions used by `package-activate', which see.
443
444(defun package-disabled-p (pkg-name version)
445 "Return whether PKG-NAME at VERSION can be activated.
446The decision is made according to `package-load-list'.
447Return nil if the package can be activated.
448Return t if the package is completely disabled.
449Return the max version (as a string) if the package is held at a lower version."
450 (let ((force (assq pkg-name package-load-list)))
451 (cond ((null force) (not (memq 'all package-load-list)))
452 ((null (setq force (cadr force))) t) ; disabled
453 ((eq force t) nil)
454 ((stringp force) ; held
455 (unless (version-list-= version (version-to-list force))
456 force))
457 (t (error "Invalid element in `package-load-list'")))))
458
459(defun package-built-in-p (package &optional min-version)
460 "Return non-nil if PACKAGE is built-in to Emacs.
461Optional arg MIN-VERSION, if non-nil, should be a version list
462specifying the minimum acceptable version."
463 (if (package-desc-p package) ;; was built-in and then was converted
464 (eq 'builtin (package-desc-dir package))
465 (let ((bi (assq package package--builtin-versions)))
466 (cond
467 (bi (version-list-<= min-version (cdr bi)))
468 ((remove 0 min-version) nil)
469 (t
470 (require 'finder-inf nil t) ; For `package--builtins'.
471 (assq package package--builtins))))))
472
473(defun package--active-built-in-p (package)
474 "Return non-nil if the built-in version of PACKAGE is used.
475If the built-in version of PACKAGE is used and PACKAGE is
476also available for installation from an archive, it is an
477indication that PACKAGE was never upgraded to any newer
478version from the archive."
479 (and (not (assq (cond
480 ((package-desc-p package)
481 (package-desc-name package))
482 ((stringp package) (intern package))
483 ((symbolp package) package)
484 ((error "Unknown package format: %S" package)))
485 (package--alist)))
486 (package-built-in-p package)))
487
488(defun package--autoloads-file-name (pkg-desc)
489 "Return the absolute name of the autoloads file, sans extension.
490PKG-DESC is a `package-desc' object."
491 (expand-file-name
492 (format "%s-autoloads" (package-desc-name pkg-desc))
493 (package-desc-dir pkg-desc)))
494
495(defvar Info-directory-list)
496(declare-function info-initialize "info" ())
497
498(defvar package--quickstart-pkgs t
499 "If set to a list, we're computing the set of pkgs to activate.")
500
501(defsubst package--library-stem (file)
502 (catch 'done
503 (let (result)
504 (dolist (suffix (get-load-suffixes) file)
505 (setq result (string-trim file nil suffix))
506 (unless (equal file result)
507 (throw 'done result))))))
508
509(defun package--reload-previously-loaded (pkg-desc &optional warn)
510 "Force reimportation of files in PKG-DESC already present in `load-history'.
511New editions of files contain macro definitions and
512redefinitions, the overlooking of which would cause
513byte-compilation of the new package to fail.
514If WARN is a string, display a warning (using WARN as a format string)
515before reloading the files. WARN must have two %-sequences
516corresponding to package name (a symbol) and a list of files loaded (as
517sexps)."
518 (with-demoted-errors "Error in package--load-files-for-activation: %s"
519 (let* (result
520 (dir (package-desc-dir pkg-desc))
521 ;; A previous implementation would skip `dir' itself.
522 ;; However, in normal use reloading from the same directory
523 ;; never happens anyway, while in certain cases external to
524 ;; Emacs a package in the same directory not necessary
525 ;; stays byte-identical, e.g. during development. Just
526 ;; don't special-case `dir'.
527 (effective-path (or (bound-and-true-p find-library-source-path)
528 load-path))
529 (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))
530 (history (mapcar #'file-truename
531 (cl-remove-if-not #'stringp
532 (mapcar #'car load-history)))))
533 (dolist (file files)
534 (when-let* ((library (package--library-stem
535 (file-relative-name file dir)))
536 (canonical (locate-library library nil effective-path))
537 (truename (file-truename canonical))
538 ;; Normally, all files in a package are compiled by
539 ;; now, but don't assume that. E.g. different
540 ;; versions can add or remove `no-byte-compile'.
541 (altname (if (string-suffix-p ".el" truename)
542 (replace-regexp-in-string
543 "\\.el\\'" ".elc" truename t)
544 (replace-regexp-in-string
545 "\\.elc\\'" ".el" truename t)))
546 (found (or (member truename history)
547 (and (not (string= altname truename))
548 (member altname history))))
549 (recent-index (length found)))
550 (unless (equal (file-name-base library)
551 (format "%s-autoloads" (package-desc-name pkg-desc)))
552 (push (cons (expand-file-name library dir) recent-index) result))))
553 (when (and result warn)
554 (display-warning 'package
555 (format warn (package-desc-name pkg-desc)
556 (mapcar #'car result))))
557 (mapc (lambda (c) (load (car c) nil t))
558 (sort result (lambda (x y) (< (cdr x) (cdr y))))))))
559
560(defun package-desc-full-name (pkg-desc)
561 "Return full name of package-desc object PKG-DESC.
562This is the name of the package with its version appended."
563 (if (package-vc-p pkg-desc)
564 (symbol-name (package-desc-name pkg-desc))
565 (format "%s-%s"
566 (package-desc-name pkg-desc)
567 (package-version-join (package-desc-version pkg-desc)))))
568
569(defun package-activate-1 (pkg-desc &optional reload deps)
570 "Activate package given by PKG-DESC, even if it was already active.
571If DEPS is non-nil, also activate its dependencies (unless they
572are already activated).
573If RELOAD is non-nil, also `load' any files inside the package which
574correspond to previously loaded files."
575 (let* ((name (package-desc-name pkg-desc))
576 (pkg-dir (package-desc-dir pkg-desc)))
577 (unless pkg-dir
578 (error "Internal error: unable to find directory for `%s'"
579 (package-desc-full-name pkg-desc)))
580 (catch 'exit
581 ;; Activate its dependencies recursively.
582 ;; FIXME: This doesn't check whether the activated version is the
583 ;; required version.
584 (when deps
585 (dolist (req (package-desc-reqs pkg-desc))
586 (unless (package-activate (car req))
587 (message "Unable to activate package `%s'.\nRequired package `%s-%s' is unavailable"
588 name (car req) (package-version-join (cadr req)))
589 (throw 'exit nil))))
590 (if (listp package--quickstart-pkgs)
591 ;; We're only collecting the set of packages to activate!
592 (push pkg-desc package--quickstart-pkgs)
593 (when (or reload (assq name package--builtin-versions))
594 (package--reload-previously-loaded
595 pkg-desc (unless reload
596 "Package %S is activated too late.
597The following files have already been loaded: %S")))
598 (with-demoted-errors "Error loading autoloads: %s"
599 (load (package--autoloads-file-name pkg-desc) nil t)))
600 ;; Add info node.
601 (when (file-exists-p (expand-file-name "dir" pkg-dir))
602 ;; FIXME: not the friendliest, but simple.
603 (require 'info)
604 (info-initialize)
605 (add-to-list 'Info-directory-list pkg-dir))
606 (push name package-activated-list)
607 ;; Don't return nil.
608 t)))
609
610;;;; `package-activate'
611
612(defun package--get-activatable-pkg (pkg-name)
613 ;; Is "activatable" a word?
614 (let ((pkg-descs (cdr (assq pkg-name package-alist))))
615 ;; Check if PACKAGE is available in `package-alist'.
616 (while
617 (when pkg-descs
618 (let ((available-version (package-desc-version (car pkg-descs))))
619 (or (package-disabled-p pkg-name available-version)
620 ;; Prefer a builtin package.
621 (package-built-in-p pkg-name available-version))))
622 (setq pkg-descs (cdr pkg-descs)))
623 (car pkg-descs)))
624
625(defvar package--initialized nil
626 "Non-nil if `package-initialize' has been run.")
627
628;; This function activates a newer version of a package if an older
629;; one was already activated. It also loads a features of this
630;; package which were already loaded.
631(defun package-activate (package &optional force)
632 "Activate the package named PACKAGE.
633If FORCE is true, (re-)activate it if it's already activated.
634Newer versions are always activated, regardless of FORCE."
635 (let ((pkg-desc (package--get-activatable-pkg package)))
636 (cond
637 ;; If no such package is found, maybe it's built-in.
638 ((null pkg-desc)
639 (package-built-in-p package))
640 ;; If the package is already activated, just return t.
641 ((and (memq package package-activated-list) (not force))
642 t)
643 ;; Otherwise, proceed with activation.
644 (t (package-activate-1 pkg-desc nil 'deps)))))
645
646
647;;; Installation -- Local operations
648;; This section contains a variety of features regarding installing a
649;; package to/from disk. This includes autoload generation,
650;; unpacking, compiling, as well as defining a package from the
651;; current buffer.
652
653;;;; Unpacking
654
655;;;###autoload
656(defvar package--activated nil
657 "Non-nil if `package-activate-all' has been run.")
658
659(declare-function package-read-all-archive-contents "package-elpa" ())
660
661(defvar package--compatibility-table nil
662 "Hash table connecting package names to their compatibility.
663Each key is a symbol, the name of a package.
664
665The value is either nil, representing an incompatible package, or
666a version list, representing the highest compatible version of
667that package which is available.
668
669A package is considered incompatible if it requires an Emacs
670version higher than the one being used. To check for package
671\(in)compatibility, don't read this table directly, use
672`package--incompatible-p' which also checks dependencies.")
673
674(defun package--add-to-compatibility-table (pkg)
675 "If PKG is compatible (without dependencies), add to the compatibility table.
676PKG is a package-desc object.
677Only adds if its version is higher than what's already stored in
678the table."
679 (unless (package--incompatible-p pkg 'shallow)
680 (let* ((name (package-desc-name pkg))
681 (version (or (package-desc-version pkg) '(0)))
682 (table-version (gethash name package--compatibility-table)))
683 (when (or (not table-version)
684 (version-list-< table-version version))
685 (puthash name version package--compatibility-table)))))
686
687(defun package--mapc (function &optional packages)
688 "Call FUNCTION for all known PACKAGES.
689PACKAGES can be nil or t, which means to display all known
690packages, or a list of packages.
691
692Built-in packages are converted with `package--from-builtin'."
693 (unless packages (setq packages t))
694 (let (name)
695 ;; Installed packages:
696 (dolist (elt package-alist)
697 (setq name (car elt))
698 (when (or (eq packages t) (memq name packages))
699 (mapc function (cdr elt))))
700
701 ;; Built-in packages:
702 (dolist (elt package--builtins)
703 (setq name (car elt))
704 (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
705 (or package-list-unversioned
706 (package--bi-desc-version (cdr elt)))
707 (or (eq packages t) (memq name packages)))
708 (funcall function (package--from-builtin elt))))
709
710 ;; Available and disabled packages:
711 (dolist (elt (bound-and-true-p package-archive-contents))
712 (setq name (car elt))
713 (when (or (eq packages t) (memq name packages))
714 (dolist (pkg (cdr elt))
715 ;; Hide obsolete packages.
716 (unless (package-installed-p (package-desc-name pkg)
717 (package-desc-version pkg))
718 (funcall function pkg)))))))
719
720(defun package--build-compatibility-table ()
721 "Build `package--compatibility-table' with `package--mapc'."
722 ;; Initialize the list of built-ins.
723 (require 'finder-inf nil t)
724 ;; Build compat table.
725 (setq package--compatibility-table (make-hash-table :test 'eq))
726 (package--mapc #'package--add-to-compatibility-table))
727
728;;;###autoload
729(defun package-initialize (&optional no-activate)
730 "Load Emacs Lisp packages, and activate them.
731The variable `package-load-list' controls which packages to load.
732If optional arg NO-ACTIVATE is non-nil, don't activate packages.
733
734It is not necessary to adjust `load-path' or `require' the
735individual packages after calling `package-initialize' -- this is
736taken care of by `package-initialize'.
737
738If `package-initialize' is called twice during Emacs startup,
739signal a warning, since this is a bad idea except in highly
740advanced use cases. To suppress the warning, remove the
741superfluous call to `package-initialize' from your init-file. If
742you have code which must run before `package-initialize', put
743that code in the early init-file."
744 (interactive)
745 (when (and package--initialized (not after-init-time))
746 (lwarn '(package reinitialization) :warning
747 "Unnecessary call to `package-initialize' in init file"))
748 (setq package-alist nil)
749 (package-load-all-descriptors)
750 (require 'package)
751 (package-read-all-archive-contents)
752 (setq package--initialized t)
753 (unless no-activate
754 (package-activate-all))
755 ;; This uses `package--mapc' so it must be called after
756 ;; `package--initialized' is t.
757 (package--build-compatibility-table))
758
759;;;###autoload
760(progn ;; Make the function usable without loading `package.el'.
761(defun package-activate-all ()
762 "Activate all installed packages.
763The variable `package-load-list' controls which packages to load."
764 (setq package--activated t)
765 (let* ((elc (concat package-quickstart-file "c"))
766 (qs (if (file-readable-p elc) elc
767 (if (file-readable-p package-quickstart-file)
768 package-quickstart-file))))
769 ;; The quickstart file presumes that it has a blank slate,
770 ;; so don't use it if we already activated some packages.
771 (or (and qs (not (bound-and-true-p package-activated-list))
772 ;; Skip `load-source-file-function' which would slow us down by
773 ;; a factor 2 when loading the .el file (this assumes we were
774 ;; careful to save this file so it doesn't need any decoding).
775 (with-demoted-errors "Error during quickstart: %S"
776 (let ((load-source-file-function nil))
777 (unless (boundp 'package-activated-list)
778 (setq package-activated-list nil))
779 (load qs nil 'nomessage)
780 t)))
781 (progn
782 (require 'package)
783 ;; Silence the "unknown function" warning when this is compiled
784 ;; inside `loaddefs.el'.
785 ;; FIXME: We use `with-no-warnings' because the effect of
786 ;; `declare-function' is currently not scoped, so if we use
787 ;; it here, we end up with a redefinition warning instead :-)
788 (with-no-warnings
789 (package--activate-all)))))))
790
791(defun package--activate-all ()
792 (dolist (elt (package--alist))
793 (condition-case err
794 (package-activate (car elt))
795 ;; Don't let failure of activation of a package arbitrarily stop
796 ;; activation of further packages.
797 (error (message "%s" (error-message-string err))))))
798
799(defun package-strip-rcs-id (str)
800 "Strip RCS version ID from the version string STR.
801If the result looks like a dotted numeric version, return it.
802Otherwise return nil."
803 (when str
804 (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str)
805 (setq str (substring str (match-end 0))))
806 (let ((l (version-to-list str)))
807 ;; Don't return `str' but (package-version-join (version-to-list str))
808 ;; to make sure we use a "canonical name"!
809 (if l (package-version-join l)))))
810
811(defun package--incompatible-p (pkg &optional shallow)
812 "Return non-nil if PKG has no chance of being installable.
813PKG is a `package-desc' object.
814
815If SHALLOW is non-nil, this only checks if PKG depends on a
816higher `emacs-version' than the one being used. Otherwise, also
817checks the viability of dependencies, according to
818`package--compatibility-table'.
819
820If PKG requires an incompatible Emacs version, the return value
821is this version (as a string).
822If PKG requires incompatible packages, the return value is a list
823of these dependencies, similar to the list returned by
824`package-desc-reqs'."
825 (let* ((reqs (package-desc-reqs pkg))
826 (version (cadr (assq 'emacs reqs))))
827 (if (and version (version-list-< package--emacs-version-list version))
828 (package-version-join version)
829 (unless shallow
830 (let (out)
831 (dolist (dep (package-desc-reqs pkg) out)
832 (let ((dep-name (car dep)))
833 (unless (eq 'emacs dep-name)
834 (let ((cv (gethash dep-name package--compatibility-table)))
835 (when (version-list-< (or cv '(0)) (or (cadr dep) '(0)))
836 (push dep out)))))))))))
837
838(defun package--find-non-dependencies ()
839 "Return a list of installed packages which are not dependencies.
840Finds all packages in `package-alist' which are not dependencies
841of any other packages.
842Used to populate `package-selected-packages'."
843 (let ((dep-list
844 (delete-dups
845 (apply #'append
846 (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p))))
847 package-alist)))))
848 (cl-loop for p in package-alist
849 for name = (car p)
850 unless (memq name dep-list)
851 collect name)))
852
853(defun package--save-selected-packages (&optional value)
854 "Set and save `package-selected-packages' to VALUE."
855 (when (or value after-init-time)
856 ;; It is valid to set it to nil, for example when the last package
857 ;; is uninstalled. But it shouldn't be done at init time, to
858 ;; avoid overwriting configurations that haven't yet been loaded.
859 (setq package-selected-packages (sort value #'string<)))
860 (if after-init-time
861 (customize-save-variable 'package-selected-packages package-selected-packages)
862 (add-hook 'after-init-hook #'package--save-selected-packages)))
863
864(defun package--user-selected-p (pkg)
865 "Return non-nil if PKG is a package was installed by the user.
866PKG is a package name.
867This looks into `package-selected-packages', populating it first
868if it is still empty."
869 (unless (consp package-selected-packages)
870 (package--save-selected-packages (package--find-non-dependencies)))
871 (memq pkg package-selected-packages))
872
873(defun package-desc-status (pkg-desc)
874 "Return the status of `package-desc' object PKG-DESC."
875 (let* ((name (package-desc-name pkg-desc))
876 (dir (package-desc-dir pkg-desc))
877 (lle (assq name package-load-list))
878 (held (cadr lle))
879 (version (package-desc-version pkg-desc))
880 (signed (or (not package-list-unsigned)
881 (package-desc-signed pkg-desc))))
882 (cond
883 ((package-vc-p pkg-desc) "source")
884 ((eq dir 'builtin) "built-in")
885 ((and lle (null held)) "disabled")
886 ((stringp held)
887 (let ((hv (if (stringp held) (version-to-list held))))
888 (cond
889 ((version-list-= version hv) "held")
890 ((version-list-< version hv) "obsolete")
891 (t "disabled"))))
892 (dir ;One of the installed packages.
893 (cond
894 ((not (file-exists-p dir)) "deleted")
895 ;; Not inside `package-user-dir'.
896 ((not (file-in-directory-p dir package-user-dir)) "external")
897 ((eq pkg-desc (cadr (assq name package-alist)))
898 (if (not signed) "unsigned"
899 (if (package--user-selected-p name)
900 "installed" "dependency")))
901 (t "obsolete")))
902 ((package--incompatible-p pkg-desc) "incompat")
903 (t
904 (let* ((ins (cadr (assq name package-alist)))
905 (ins-v (if ins (package-desc-version ins))))
906 (cond
907 ;; Installed obsolete packages are handled in the `dir'
908 ;; clause above. Here we handle available obsolete, which
909 ;; are displayed depending on `package-menu--hide-packages'.
910 ((and ins (version-list-<= version ins-v)) "avail-obso")
911 (t
912 (if (memq name (bound-and-true-p package-menu--new-package-list))
913 "new" "available"))))))))
914
915(defun package--query-desc (&optional alist)
916 "Query the user for a package or return the package at point.
917The optional argument ALIST must consist of elements with the
918form (PKG-NAME PKG-DESC). If not specified, it will default to
919`package-alist'."
920 (or (and (fboundp 'tabulated-list-get-id)
921 (tabulated-list-get-id))
922 (let ((alist (or alist package-alist)))
923 (cadr (assoc (completing-read "Package: " alist nil t)
924 alist #'string=)))))
925
926(provide 'package-core)
927;;; package-core.el ends here
diff --git a/lisp/package/package-describe.el b/lisp/package/package-describe.el
new file mode 100644
index 00000000000..15a7f78ffaf
--- /dev/null
+++ b/lisp/package/package-describe.el
@@ -0,0 +1,419 @@
1;;; package-describe.el --- Help buffer for packages -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;; Code:
23
24(require 'package-core)
25(require 'package-elpa)
26(require 'package-misc)
27(require 'package-install)
28
29(require 'browse-url)
30(require 'lisp-mnt)
31
32(defface package-help-section-name
33 '((t :inherit (bold font-lock-function-name-face)))
34 "Face used on section names in package description buffers."
35 :version "25.1"
36 :group 'package)
37
38(defun package--print-help-section (name &rest strings)
39 "Print \"NAME: \", right aligned to the 13th column.
40If more STRINGS are provided, insert them followed by a newline.
41Otherwise no newline is inserted."
42 (declare (indent 1))
43 (insert (make-string (max 0 (- 11 (string-width name))) ?\s)
44 (propertize (concat name ": ") 'font-lock-face 'package-help-section-name))
45 (when strings
46 (apply #'insert strings)
47 (insert "\n")))
48
49(defun package--get-description (desc)
50 "Return a string containing the long description of the package DESC.
51The description is read from the installed package files."
52 ;; Installed packages have nil for kind, so we look for README
53 ;; first, then fall back to the Commentary header.
54
55 ;; We don’t include README.md here, because that is often the home
56 ;; page on a site like github, and not suitable as the package long
57 ;; description.
58 (let ((files '("README-elpa" "README-elpa.md" "README" "README.rst" "README.org"))
59 file
60 (srcdir (package-desc-dir desc))
61 result)
62 (while (and files
63 (not result))
64 (setq file (pop files))
65 (when (file-readable-p (expand-file-name file srcdir))
66 ;; Found a README.
67 (with-temp-buffer
68 (insert-file-contents (expand-file-name file srcdir))
69 (setq result (buffer-string)))))
70
71 (or
72 result
73
74 ;; Look for Commentary header.
75 (lm-commentary (expand-file-name
76 (format "%s.el" (package-desc-name desc)) srcdir))
77 "")))
78
79(defun package--describe-add-library-links ()
80 "Add links to library names in package description."
81 (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t)
82 (if (locate-library (match-string 1))
83 (make-text-button (match-beginning 1) (match-end 1)
84 'xref (match-string-no-properties 1)
85 'help-echo "Read this file's commentary"
86 :type 'package--finder-xref))))
87
88(defun package-install-button-action (button)
89 "Run `package-install' on the package BUTTON points to.
90Used for the `action' property of buttons in the buffer created by
91`describe-package'."
92 (let ((pkg-desc (button-get button 'package-desc)))
93 (when (y-or-n-p (format-message "Install package `%s'? "
94 (package-desc-full-name pkg-desc)))
95 (package-install pkg-desc nil)
96 (describe-package (package-desc-name pkg-desc)))))
97
98(defun package-delete-button-action (button)
99 "Run `package-delete' on the package BUTTON points to.
100Used for the `action' property of buttons in the buffer created by
101`describe-package'."
102 (let ((pkg-desc (button-get button 'package-desc)))
103 (when (y-or-n-p (format-message "Delete package `%s'? "
104 (package-desc-full-name pkg-desc)))
105 (package-delete pkg-desc)
106 (describe-package (package-desc-name pkg-desc)))))
107
108(defun package-keyword-button-action (button)
109 "Show filtered \"*Packages*\" buffer for BUTTON.
110The buffer is filtered by the `package-keyword' property of BUTTON.
111Used for the `action' property of buttons in the buffer created by
112`describe-package'."
113 (let ((pkg-keyword (button-get button 'package-keyword)))
114 (package-show-package-list t (list pkg-keyword))))
115
116(defun package-make-button (text &rest properties)
117 "Insert button labeled TEXT with button PROPERTIES at point.
118PROPERTIES are passed to `insert-text-button', for which this
119function is a convenience wrapper used by `describe-package-1'."
120 (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
121 (button-face (if (display-graphic-p)
122 (progn
123 (require 'cus-edit) ; for the custom-button face
124 'custom-button)
125 'link)))
126 (apply #'insert-text-button button-text 'face button-face 'follow-link t
127 properties)))
128
129(defun package--finder-goto-xref (button)
130 "Jump to a Lisp file for the BUTTON at point."
131 (let* ((file (button-get button 'xref))
132 (lib (locate-library file)))
133 (if lib (finder-commentary lib)
134 (message "Unable to locate `%s'" file))))
135
136(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref)
137
138(defun describe-package-1 (pkg)
139 "Insert the package description for PKG.
140Helper function for `describe-package'."
141 (require 'lisp-mnt)
142 (let* ((desc (or
143 (if (package-desc-p pkg) pkg)
144 (cadr (assq pkg package-alist))
145 (let ((built-in (assq pkg package--builtins)))
146 (if built-in
147 (package--from-builtin built-in)
148 (cadr (assq pkg package-archive-contents))))))
149 (name (if desc (package-desc-name desc) pkg))
150 (pkg-dir (if desc (package-desc-dir desc)))
151 (reqs (if desc (package-desc-reqs desc)))
152 (required-by (if desc (package--used-elsewhere-p desc nil 'all)))
153 (version (if desc (package-desc-version desc)))
154 (archive (if desc (package-desc-archive desc)))
155 (extras (and desc (package-desc-extras desc)))
156 (website (cdr (assoc :url extras)))
157 (commit (cdr (assoc :commit extras)))
158 (keywords (if desc (package-desc--keywords desc)))
159 (built-in (eq pkg-dir 'builtin))
160 (installable (and archive (not built-in)))
161 (status (if desc (package-desc-status desc) "orphan"))
162 (incompatible-reason (package--incompatible-p desc))
163 (signed (if desc (package-desc-signed desc)))
164 (maintainers (or (cdr (assoc :maintainer extras))
165 (cdr (assoc :maintainers extras))))
166 (authors (cdr (assoc :authors extras)))
167 (news (and-let* (pkg-dir
168 ((not built-in))
169 (file (expand-file-name "news" pkg-dir))
170 ((file-regular-p file))
171 ((file-readable-p file)))
172 file)))
173 (when (string= status "avail-obso")
174 (setq status "available obsolete"))
175 (when incompatible-reason
176 (setq status "incompatible"))
177 (princ (format "Package %S is %s.\n\n" name status))
178
179 ;; TODO: Remove the string decorations and reformat the strings
180 ;; for future l10n.
181 (package--print-help-section "Status")
182 (cond (built-in
183 (insert (propertize (capitalize status)
184 'font-lock-face 'package-status-built-in)
185 "."))
186 (pkg-dir
187 (insert (propertize (if (member status '("unsigned" "dependency"))
188 "Installed"
189 (capitalize status))
190 'font-lock-face 'package-status-built-in))
191 (insert (substitute-command-keys " in `"))
192 (let ((dir (abbreviate-file-name
193 (file-name-as-directory
194 (if (file-in-directory-p pkg-dir package-user-dir)
195 (file-relative-name pkg-dir package-user-dir)
196 pkg-dir)))))
197 (help-insert-xref-button dir 'help-package-def pkg-dir))
198 (if (and (package-built-in-p name)
199 (not (package-built-in-p name version)))
200 (insert (substitute-command-keys
201 "',\n shadowing a ")
202 (propertize "built-in package"
203 'font-lock-face 'package-status-built-in))
204 (insert (substitute-quotes "'")))
205 (if signed
206 (insert ".")
207 (insert " (unsigned)."))
208 (when (and (package-desc-p desc)
209 (not required-by)
210 (member status '("unsigned" "installed")))
211 (insert " ")
212 (package-make-button "Delete"
213 'action #'package-delete-button-action
214 'package-desc desc)))
215 (incompatible-reason
216 (insert (propertize "Incompatible" 'font-lock-face 'font-lock-warning-face)
217 " because it depends on ")
218 (if (stringp incompatible-reason)
219 (insert "Emacs " incompatible-reason ".")
220 (insert "uninstallable packages.")))
221 (installable
222 (insert (capitalize status))
223 (insert " from " (format "%s" archive))
224 (insert " -- ")
225 (package-make-button
226 "Install"
227 'action 'package-install-button-action
228 'package-desc desc))
229 (t (insert (capitalize status) ".")))
230 (insert "\n")
231 (unless (and pkg-dir (not archive)) ; Installed pkgs don't have archive.
232 (package--print-help-section "Archive"
233 (or archive "n/a")))
234 (and version
235 (package--print-help-section "Version"
236 (package-version-join version)))
237 (when commit
238 (package--print-help-section "Commit" commit))
239 (when desc
240 (package--print-help-section "Summary"
241 (package-desc-summary desc)))
242
243 (setq reqs (if desc (package-desc-reqs desc)))
244 (when reqs
245 (package--print-help-section "Requires")
246 (let ((first t))
247 (dolist (req reqs)
248 (let* ((name (car req))
249 (vers (cadr req))
250 (text (format "%s-%s" (symbol-name name)
251 (package-version-join vers)))
252 (reason (if (and (listp incompatible-reason)
253 (assq name incompatible-reason))
254 " (not available)" "")))
255 (cond (first (setq first nil))
256 ((>= (+ 2 (current-column) (length text) (length reason))
257 (window-width))
258 (insert ",\n "))
259 (t (insert ", ")))
260 (help-insert-xref-button text 'help-package name)
261 (insert reason)))
262 (insert "\n")))
263 (when required-by
264 (package--print-help-section "Required by")
265 (let ((first t))
266 (dolist (pkg required-by)
267 (let ((text (package-desc-full-name pkg)))
268 (cond (first (setq first nil))
269 ((>= (+ 2 (current-column) (length text))
270 (window-width))
271 (insert ",\n "))
272 (t (insert ", ")))
273 (help-insert-xref-button text 'help-package
274 (package-desc-name pkg))))
275 (insert "\n")))
276 (when website
277 ;; Prefer https for the website of packages on common domains.
278 (when (string-match-p (rx bol "http://" (or "elpa." "www." "git." "")
279 (or "nongnu.org" "gnu.org" "sr.ht"
280 "emacswiki.org" "gitlab.com" "github.com")
281 "/")
282 website)
283 ;; But only if the user has "https" in `package-archives'.
284 (let ((gnu (cdr (assoc "gnu" package-archives))))
285 (and gnu (string-match-p "^https" gnu)
286 (setq website
287 (replace-regexp-in-string "^http" "https" website)))))
288 (package--print-help-section "Website")
289 (help-insert-xref-button website 'help-url website)
290 (insert "\n"))
291 (when keywords
292 (package--print-help-section "Keywords")
293 (dolist (k keywords)
294 (package-make-button
295 k
296 'package-keyword k
297 'action 'package-keyword-button-action)
298 (insert " "))
299 (insert "\n"))
300 (when maintainers
301 (unless (and (listp (car maintainers)) (listp (cdr maintainers)))
302 (setq maintainers (list maintainers)))
303 (package--print-help-section
304 (if (cdr maintainers) "Maintainers" "Maintainer"))
305 (dolist (maintainer maintainers)
306 (when (bolp)
307 (insert (make-string 13 ?\s)))
308 (package--print-email-button maintainer)))
309 (when authors
310 (package--print-help-section (if (cdr authors) "Authors" "Author"))
311 (dolist (author authors)
312 (when (bolp)
313 (insert (make-string 13 ?\s)))
314 (package--print-email-button author)))
315 (let* ((all-pkgs (append (cdr (assq name package-alist))
316 (cdr (assq name package-archive-contents))
317 (let ((bi (assq name package--builtins)))
318 (if bi (list (package--from-builtin bi))))))
319 (other-pkgs (delete desc all-pkgs)))
320 (when other-pkgs
321 (package--print-help-section "Other versions"
322 (mapconcat (lambda (opkg)
323 (let* ((ov (package-desc-version opkg))
324 (dir (package-desc-dir opkg))
325 (from (or (package-desc-archive opkg)
326 (if (stringp dir) "installed" dir))))
327 (if (not ov) (format "%s" from)
328 (format "%s (%s)"
329 (make-text-button (package-version-join ov) nil
330 'font-lock-face 'link
331 'follow-link t
332 'action
333 (lambda (_button)
334 (describe-package opkg)))
335 from))))
336 other-pkgs ", ")
337 ".")))
338
339 (insert "\n")
340
341 (let ((start-of-description (point)))
342 (if built-in
343 ;; For built-in packages, get the description from the
344 ;; Commentary header.
345 (insert (or (lm-commentary (locate-file (format "%s.el" name)
346 load-path
347 load-file-rep-suffixes))
348 ""))
349
350 (if (package-installed-p desc)
351 ;; For installed packages, get the description from the
352 ;; installed files.
353 (insert (package--get-description desc))
354
355 ;; For non-built-in, non-installed packages, get description from
356 ;; the archive.
357 (let* ((basename (format "%s-readme.txt" name))
358 readme-string)
359
360 (package--with-response-buffer (package-archive-base desc)
361 :file basename :noerror t
362 (save-excursion
363 (goto-char (point-max))
364 (unless (bolp)
365 (insert ?\n)))
366 (cl-assert (not enable-multibyte-characters))
367 (setq readme-string
368 ;; The readme.txt files are defined to contain utf-8 text.
369 (decode-coding-region (point-min) (point-max) 'utf-8 t))
370 t)
371 (insert (or readme-string
372 "This package does not provide a description.")))))
373
374 ;; Insert news if available.
375 (when news
376 (insert "\n" (make-separator-line) "\n"
377 (propertize "* News" 'face 'package-help-section-name)
378 "\n\n")
379 (insert-file-contents news))
380
381 ;; Make library descriptions into links.
382 (goto-char start-of-description)
383 (package--describe-add-library-links)
384 ;; Make URLs in the description into links.
385 (goto-char start-of-description)
386 (browse-url-add-buttons))))
387
388;;;###autoload
389(defun describe-package (package)
390 "Display the full documentation of PACKAGE (a symbol)."
391 (interactive
392 (let* ((guess (or (function-called-at-point)
393 (symbol-at-point))))
394 (require 'finder-inf nil t)
395 ;; Load the package list if necessary (but don't activate them).
396 (unless package--initialized
397 (package-initialize t))
398 (let ((packages (append (mapcar #'car package-alist)
399 (mapcar #'car package-archive-contents)
400 (mapcar #'car package--builtins))))
401 (unless (memq guess packages)
402 (setq guess nil))
403 (setq packages (mapcar #'symbol-name packages))
404 (let ((val
405 (completing-read (format-prompt "Describe package" guess)
406 packages nil t nil nil (when guess
407 (symbol-name guess)))))
408 (list (and (> (length val) 0) (intern val)))))))
409 (if (not (or (package-desc-p package) (and package (symbolp package))))
410 (message "No package specified")
411 (help-setup-xref (list #'describe-package package)
412 (called-interactively-p 'interactive))
413 (with-help-window (help-buffer)
414 (with-current-buffer standard-output
415 (describe-package-1 package)))))
416
417
418(provide 'package-describe)
419;;; package-describe.el ends here
diff --git a/lisp/package/package-elpa.el b/lisp/package/package-elpa.el
new file mode 100644
index 00000000000..3eb3e504ea5
--- /dev/null
+++ b/lisp/package/package-elpa.el
@@ -0,0 +1,629 @@
1;;; package-elpa.el --- ELPA integration -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Tom Tromey <tromey@redhat.com>
6;; Daniel Hackney <dan@haxney.org>
7
8;; This program is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with this program. If not, see <https://www.gnu.org/licenses/>.
20
21;;; Commentary:
22
23;;
24
25;;; Code:
26
27(require 'package-core)
28
29(require 'epg)
30(require 'url-http)
31(require 'url-handlers)
32
33(defgroup package-archive nil
34 "Archive configuration of the package manager."
35 :group 'applications
36 :version "31.1")
37
38(defcustom package-archives `(("gnu" .
39 ,(format "http%s://elpa.gnu.org/packages/"
40 (if (gnutls-available-p) "s" "")))
41 ("nongnu" .
42 ,(format "http%s://elpa.nongnu.org/nongnu/"
43 (if (gnutls-available-p) "s" ""))))
44 "An alist of archives from which to fetch.
45The default value points to the GNU Emacs package repository.
46
47Each element has the form (ID . LOCATION).
48 ID is an archive name, as a string.
49 LOCATION specifies the base location for the archive.
50 If it starts with \"http(s):\", it is treated as an HTTP(S) URL;
51 otherwise it should be an absolute directory name.
52 (Other types of URL are currently not supported.)
53
54Only add locations that you trust, since fetching and installing
55a package can run arbitrary code.
56
57HTTPS URLs should be used where possible, as they offer superior
58security."
59 :type '(alist :key-type (string :tag "Archive name")
60 :value-type (string :tag "URL or directory name"))
61 :risky t
62 :version "28.1")
63
64(defcustom package-archive-priorities nil
65 "An alist of priorities for packages.
66
67Each element has the form (ARCHIVE-ID . PRIORITY).
68
69When installing packages, the package with the highest version
70number from the archive with the highest priority is
71selected. When higher versions are available from archives with
72lower priorities, the user has to select those manually.
73
74Archives not in this list have the priority 0, as have packages
75that are already installed. If you use negative priorities for
76the archives, they will not be upgraded automatically.
77
78See also `package-menu-hide-low-priority'."
79 :type '(alist :key-type (string :tag "Archive name")
80 :value-type (integer :tag "Priority (default is 0)"))
81 :risky t
82 :version "25.1")
83
84(defcustom package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)
85 "Directory containing GnuPG keyring or nil.
86This variable specifies the GnuPG home directory used by package.
87That directory is passed via the option \"--homedir\" to GnuPG.
88If nil, do not use the option \"--homedir\", but stick with GnuPG's
89default directory."
90 :type `(choice
91 (const
92 :tag "Default Emacs package management GnuPG home directory"
93 ,(expand-file-name "gnupg" package-user-dir))
94 (const
95 :tag "Default GnuPG directory (GnuPG option --homedir not used)"
96 nil)
97 (directory :tag "A specific GnuPG --homedir"))
98 :risky t
99 :version "26.1")
100
101(defcustom package-check-signature 'allow-unsigned
102 "Non-nil means to check package signatures when installing.
103
104This also applies to the \"archive-contents\" file that lists the
105contents of the archive.
106
107The value can be one of:
108
109 t Accept a package only if it comes with at least
110 one verified signature.
111
112 `all' Same as t, but verify all signatures if there
113 are more than one.
114
115 `allow-unsigned' Install a package even if it is unsigned,
116 but verify the signature if possible (that
117 is, if it is signed, we have the key for it,
118 and GnuPG is installed).
119
120 nil Package signatures are ignored."
121 :type '(choice (const :value nil :tag "Never")
122 (const :value allow-unsigned :tag "Allow unsigned")
123 (const :value t :tag "Check always")
124 (const :value all :tag "Check always (all signatures)"))
125 :risky t
126 :version "27.1")
127
128(defun package-check-signature ()
129 "Check whether we have a usable OpenPGP configuration.
130If so, and variable `package-check-signature' is
131`allow-unsigned', return `allow-unsigned', otherwise return the
132value of variable `package-check-signature'."
133 (if (eq package-check-signature 'allow-unsigned)
134 (and (epg-find-configuration 'OpenPGP)
135 'allow-unsigned)
136 package-check-signature))
137
138(defcustom package-unsigned-archives nil
139 "List of archives where we do not check for package signatures.
140This should be a list of strings matching the names of package
141archives in the variable `package-archives'."
142 :type '(repeat (string :tag "Archive name"))
143 :risky t
144 :version "24.4")
145
146(defun package--write-file-no-coding (file-name)
147 "Write file FILE-NAME without encoding using coding system."
148 (let ((buffer-file-coding-system 'no-conversion))
149 (write-region (point-min) (point-max) file-name nil 'silent)))
150
151(defun package--archive-file-exists-p (location file)
152 "Return t if FILE exists in remote LOCATION."
153 (let ((http (string-match "\\`https?:" location)))
154 (if http
155 (progn
156 (require 'url-http)
157 (url-http-file-exists-p (concat location file)))
158 (file-exists-p (expand-file-name file location)))))
159
160(defun package--display-verify-error (context sig-file)
161 "Show error details with CONTEXT for failed verification of SIG-FILE.
162The details are shown in a new buffer called \"*Error\"."
163 (unless (equal (epg-context-error-output context) "")
164 (with-output-to-temp-buffer "*Error*"
165 (with-current-buffer standard-output
166 (if (epg-context-result-for context 'verify)
167 (insert (format "Failed to verify signature %s:\n" sig-file)
168 (mapconcat #'epg-signature-to-string
169 (epg-context-result-for context 'verify)
170 "\n"))
171 (insert (format "Error while verifying signature %s:\n" sig-file)))
172 (insert "\nCommand output:\n" (epg-context-error-output context))))))
173
174(defmacro package--with-work-buffer (location file &rest body)
175 "Run BODY in a buffer containing the contents of FILE at LOCATION.
176LOCATION is the base location of a package archive, and should be
177one of the URLs (or file names) specified in `package-archives'.
178FILE is the name of a file relative to that base location.
179
180This macro retrieves FILE from LOCATION into a temporary buffer,
181and evaluates BODY while that buffer is current. This work
182buffer is killed afterwards. Return the last value in BODY."
183 (declare (indent 2) (debug t)
184 (obsolete package--with-response-buffer "25.1"))
185 `(with-temp-buffer
186 (if (string-match-p "\\`https?:" ,location)
187 (url-insert-file-contents (concat ,location ,file))
188 (unless (file-name-absolute-p ,location)
189 (error "Archive location %s is not an absolute file name"
190 ,location))
191 (insert-file-contents (expand-file-name ,file ,location)))
192 ,@body))
193
194(cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
195 "Access URL and run BODY in a buffer containing the response.
196Point is after the headers when BODY runs.
197FILE, if provided, is added to URL.
198URL can be a local file name, which must be absolute.
199ASYNC, if non-nil, runs the request asynchronously.
200ERROR-FORM is run only if a connection error occurs. If NOERROR
201is non-nil, don't propagate connection errors (does not apply to
202errors signaled by ERROR-FORM or by BODY).
203
204\(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
205 (declare (indent defun) (debug (sexp body)))
206 (while (keywordp (car body))
207 (setq body (cdr (cdr body))))
208 `(package--with-response-buffer-1 ,url (lambda () ,@body)
209 :file ,file
210 :async ,async
211 :error-function (lambda () ,error-form)
212 :noerror ,noerror))
213
214(defmacro package--unless-error (body &rest before-body)
215 (declare (debug t) (indent 1))
216 (let ((err (make-symbol "err")))
217 `(with-temp-buffer
218 (set-buffer-multibyte nil)
219 (when (condition-case ,err
220 (progn ,@before-body t)
221 (error (funcall error-function)
222 (unless noerror
223 (signal (car ,err) (cdr ,err)))))
224 (funcall ,body)))))
225
226(cl-defun package--with-response-buffer-1 (url body &key async file error-function noerror &allow-other-keys)
227 (if (string-match-p "\\`https?:" url)
228 (let ((url (url-expand-file-name file url)))
229 (if async
230 (package--unless-error #'ignore
231 (url-retrieve
232 url
233 (lambda (status)
234 (let ((b (current-buffer)))
235 (package--unless-error body
236 (when-let* ((er (plist-get status :error)))
237 (error "Error retrieving: %s %S" url er))
238 (with-current-buffer b
239 (goto-char (point-min))
240 (unless (search-forward-regexp "^\r?\n\r?" nil t)
241 (error "Error retrieving: %s %S"
242 url "incomprehensible buffer")))
243 (url-insert b)
244 (kill-buffer b)
245 (goto-char (point-min)))))
246 nil
247 'silent))
248 (package--unless-error body
249 ;; Copy&pasted from url-insert-file-contents,
250 ;; except it calls `url-insert' because we want the contents
251 ;; literally (but there's no url-insert-file-contents-literally).
252 (let ((buffer (url-retrieve-synchronously url)))
253 (unless buffer (signal 'file-error (list url "No Data")))
254 (when (fboundp 'url-http--insert-file-helper)
255 ;; XXX: This is HTTP/S specific and should be moved
256 ;; to url-http instead. See bug#17549.
257 (url-http--insert-file-helper buffer url))
258 (url-insert buffer)
259 (kill-buffer buffer)
260 (goto-char (point-min))))))
261 (package--unless-error body
262 (unless (file-name-absolute-p url)
263 (error "Location %s is not a url nor an absolute file name" url))
264 (insert-file-contents-literally (expand-file-name file url)))))
265
266(define-error 'bad-signature "Failed to verify signature")
267
268(defun package--check-signature-content (content string &optional sig-file)
269 "Check signature CONTENT against STRING.
270SIG-FILE is the name of the signature file, used when signaling
271errors."
272 (let ((context (epg-make-context 'OpenPGP)))
273 (when package-gnupghome-dir
274 (setf (epg-context-home-directory context) package-gnupghome-dir))
275 (condition-case error
276 (epg-verify-string context content string)
277 (error (package--display-verify-error context sig-file)
278 (signal 'bad-signature error)))
279 (let (good-signatures had-fatal-error)
280 ;; The .sig file may contain multiple signatures. Success if one
281 ;; of the signatures is good.
282 (dolist (sig (epg-context-result-for context 'verify))
283 (if (eq (epg-signature-status sig) 'good)
284 (push sig good-signatures)
285 ;; If `package-check-signature' is allow-unsigned, don't
286 ;; signal error when we can't verify signature because of
287 ;; missing public key. Other errors are still treated as
288 ;; fatal (bug#17625).
289 (unless (and (eq (package-check-signature) 'allow-unsigned)
290 (eq (epg-signature-status sig) 'no-pubkey))
291 (setq had-fatal-error t))))
292 (when (or (null good-signatures)
293 (and (eq (package-check-signature) 'all)
294 had-fatal-error))
295 (package--display-verify-error context sig-file)
296 (signal 'bad-signature (list sig-file)))
297 good-signatures)))
298
299(defun package--check-signature (location file &optional string async callback unwind)
300 "Check signature of the current buffer.
301Download the signature file from LOCATION by appending \".sig\"
302to FILE.
303GnuPG keyring location depends on `package-gnupghome-dir'.
304STRING is the string to verify, it defaults to `buffer-string'.
305If ASYNC is non-nil, the download of the signature file is
306done asynchronously.
307
308If the signature does not verify, signal an error.
309If the signature is verified and CALLBACK was provided, `funcall'
310CALLBACK with the list of good signatures as argument (the list
311can be empty).
312If no signatures file is found, and `package-check-signature' is
313`allow-unsigned', call CALLBACK with a nil argument.
314Otherwise, an error is signaled.
315
316UNWIND, if provided, is a function to be called after everything
317else, even if an error is signaled."
318 (let ((sig-file (concat file ".sig"))
319 (string (or string (buffer-string))))
320 (package--with-response-buffer location :file sig-file
321 :async async :noerror t
322 ;; Connection error is assumed to mean "no sig-file".
323 :error-form (let ((allow-unsigned
324 (eq (package-check-signature) 'allow-unsigned)))
325 (when (and callback allow-unsigned)
326 (funcall callback nil))
327 (when unwind (funcall unwind))
328 (unless allow-unsigned
329 (error "Unsigned file `%s' at %s" file location)))
330 ;; OTOH, an error here means "bad signature", which we never
331 ;; suppress. (Bug#22089)
332 (unwind-protect
333 (let ((sig (package--check-signature-content
334 (buffer-substring (point) (point-max))
335 string sig-file)))
336 (when callback (funcall callback sig))
337 sig)
338 (when unwind (funcall unwind))))))
339
340;;; Packages on Archives
341;; The following variables store information about packages available
342;; from archives. The most important of these is
343;; `package-archive-contents' which is initially populated by the
344;; function `package-read-all-archive-contents' from a cache on disk.
345;; The `package-initialize' command is also closely related to this
346;; section, but it has its own section.
347
348(defconst package-archive-version 1
349 "Version number of the package archive understood by package.el.
350Lower version numbers than this will probably be understood as well.")
351
352;; We don't prime the cache since it tends to get out of date.
353(defvar package-archive-contents nil
354 "Cache of the contents of all archives in `package-archives'.
355This is an alist mapping package names (symbols) to
356non-empty lists of `package-desc' structures.")
357(put 'package-archive-contents 'risky-local-variable t)
358
359;; Package descriptor objects used inside the "archive-contents" file.
360;; Changing this defstruct implies changing the format of the
361;; "archive-contents" files.
362(cl-defstruct (package--ac-desc
363 (:constructor package-make-ac-desc (version reqs summary kind extras))
364 (:copier nil)
365 (:type vector))
366 version reqs summary kind extras)
367
368(defun package-get-descriptor (pkg-name)
369 "Return the `package-desc' of PKG-NAME."
370 (unless package--initialized (package-initialize 'no-activate))
371 (or (package--get-activatable-pkg pkg-name)
372 (cadr (assq pkg-name package-alist))
373 (cadr (assq pkg-name package-archive-contents))))
374
375(defun package--append-to-alist (pkg-desc alist)
376 "Append an entry for PKG-DESC to the start of ALIST and return it.
377This entry takes the form (`package-desc-name' PKG-DESC).
378
379If ALIST already has an entry with this name, destructively add
380PKG-DESC to the cdr of this entry instead, sorted by version
381number."
382 (let* ((name (package-desc-name pkg-desc))
383 (priority-version (package-desc-priority-version pkg-desc))
384 (existing-packages (assq name alist)))
385 (if (not existing-packages)
386 (cons (list name pkg-desc)
387 alist)
388 (while (if (and (cdr existing-packages)
389 (version-list-< priority-version
390 (package-desc-priority-version
391 (cadr existing-packages))))
392 (setq existing-packages (cdr existing-packages))
393 (push pkg-desc (cdr existing-packages))
394 nil))
395 alist)))
396
397(defun package--add-to-archive-contents (package archive)
398 "Add the PACKAGE from the given ARCHIVE if necessary.
399PACKAGE should have the form (NAME . PACKAGE--AC-DESC).
400Also, add the originating archive to the `package-desc' structure."
401 (let* ((name (car package))
402 (version (package--ac-desc-version (cdr package)))
403 (pkg-desc
404 (package-desc-create
405 :name name
406 :version version
407 :reqs (package--ac-desc-reqs (cdr package))
408 :summary (package--ac-desc-summary (cdr package))
409 :kind (package--ac-desc-kind (cdr package))
410 :archive archive
411 :extras (and (> (length (cdr package)) 4)
412 ;; Older archive-contents files have only 4
413 ;; elements here.
414 (package--ac-desc-extras (cdr package)))))
415 (pinned-to-archive (assoc name package-pinned-packages)))
416 ;; Skip entirely if pinned to another archive.
417 (when (not (and pinned-to-archive
418 (not (equal (cdr pinned-to-archive) archive))))
419 (setq package-archive-contents
420 (package--append-to-alist pkg-desc package-archive-contents)))))
421
422(defun package--read-archive-file (file)
423 "Read cached archive FILE data, if it exists.
424Return the data from the file, or nil if the file does not exist.
425If the archive version is too new, signal an error."
426 (let ((filename (expand-file-name file package-user-dir)))
427 (when (file-exists-p filename)
428 (with-temp-buffer
429 (let ((coding-system-for-read 'utf-8))
430 (insert-file-contents filename))
431 (let ((contents (read (current-buffer))))
432 (if (> (car contents) package-archive-version)
433 (error "Package archive version %d is higher than %d"
434 (car contents) package-archive-version))
435 (cdr contents))))))
436
437(defun package-read-archive-contents (archive)
438 "Read cached archive file for ARCHIVE.
439If successful, set or update the variable `package-archive-contents'.
440ARCHIVE should be a string matching the name of a package archive
441in the variable `package-archives'.
442If the archive version is too new, signal an error."
443 ;; Version 1 of 'archive-contents' is identical to our internal
444 ;; representation.
445 (let* ((contents-file (format "archives/%s/archive-contents" archive))
446 (contents (package--read-archive-file contents-file)))
447 (when contents
448 (dolist (package contents)
449 (if package
450 (package--add-to-archive-contents package archive)
451 (lwarn '(package refresh) :warning
452 "Ignoring nil package on `%s' package archive" archive))))))
453
454(defvar package--old-archive-priorities nil
455 "Store currently used `package-archive-priorities'.
456This is the value of `package-archive-priorities' last time
457`package-read-all-archive-contents' was called. It can be used
458by arbitrary functions to decide whether it is necessary to call
459it again.")
460
461(defvar package-read-archive-hook (list #'package-read-archive-contents)
462 "List of functions to call to read the archive contents.
463Each function must take an optional argument, a symbol indicating
464what archive to read in. The symbol ought to be a key in
465`package-archives'.")
466
467(defun package-read-all-archive-contents ()
468 "Read cached archive file for all archives in `package-archives'.
469If successful, set or update `package-archive-contents'."
470 (setq package-archive-contents nil)
471 (setq package--old-archive-priorities package-archive-priorities)
472 (dolist (archive package-archives)
473 (run-hook-with-args 'package-read-archive-hook (car archive))))
474
475(defvar package--downloads-in-progress nil
476 "List of in-progress asynchronous downloads.")
477
478;;;###autoload
479(defun package-import-keyring (&optional file)
480 "Import keys from FILE."
481 (interactive "fFile: ")
482 (setq file (expand-file-name file))
483 (let ((context (epg-make-context 'OpenPGP)))
484 (when package-gnupghome-dir
485 (with-file-modes #o700
486 (make-directory package-gnupghome-dir t))
487 (setf (epg-context-home-directory context) package-gnupghome-dir))
488 (message "Importing %s..." (file-name-nondirectory file))
489 (epg-import-keys-from-file context file)
490 (message "Importing %s...done" (file-name-nondirectory file))))
491
492(defvar package--post-download-archives-hook nil
493 "Hook run after the archive contents are downloaded.
494Don't run this hook directly. It is meant to be run as part of
495`package--update-downloads-in-progress'.")
496(put 'package--post-download-archives-hook 'risky-local-variable t)
497
498(defun package--update-downloads-in-progress (entry)
499 "Remove ENTRY from `package--downloads-in-progress'.
500Once it's empty, run `package--post-download-archives-hook'."
501 ;; Keep track of the downloading progress.
502 (setq package--downloads-in-progress
503 (remove entry package--downloads-in-progress))
504 ;; If this was the last download, run the hook.
505 (unless package--downloads-in-progress
506 (package-read-all-archive-contents)
507 (package--build-compatibility-table)
508 ;; We message before running the hook, so the hook can give
509 ;; messages as well.
510 (message "Package refresh done")
511 (run-hooks 'package--post-download-archives-hook)))
512
513(defun package--download-one-archive (archive file &optional async)
514 "Retrieve an archive file FILE from ARCHIVE, and cache it.
515ARCHIVE should be a cons cell of the form (NAME . LOCATION),
516similar to an entry in `package-alist'. Save the cached copy to
517\"archives/NAME/FILE\" in `package-user-dir'."
518 ;; The downloaded archive contents will be read as part of
519 ;; `package--update-downloads-in-progress'.
520 (when async
521 (cl-pushnew (cons archive file) package--downloads-in-progress
522 :test #'equal))
523 (package--with-response-buffer (cdr archive) :file file
524 :async async
525 :error-form (package--update-downloads-in-progress (cons archive file))
526 (let* ((location (cdr archive))
527 (name (car archive))
528 (content (buffer-string))
529 (dir (expand-file-name (concat "archives/" name) package-user-dir))
530 (local-file (expand-file-name file dir)))
531 (when (listp (read content))
532 (make-directory dir t)
533 (if (or (not (package-check-signature))
534 (member name package-unsigned-archives))
535 ;; If we don't care about the signature, save the file and
536 ;; we're done.
537 (progn
538 (cl-assert (not enable-multibyte-characters))
539 (let ((coding-system-for-write 'binary))
540 (write-region content nil local-file nil 'silent))
541 (package--update-downloads-in-progress (cons archive file)))
542 ;; If we care, check it (perhaps async) and *then* write the file.
543 (package--check-signature
544 location file content async
545 ;; This function will be called after signature checking.
546 (lambda (&optional good-sigs)
547 (cl-assert (not enable-multibyte-characters))
548 (let ((coding-system-for-write 'binary))
549 (write-region content nil local-file nil 'silent))
550 ;; Write out good signatures into archive-contents.signed file.
551 (when good-sigs
552 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
553 nil (concat local-file ".signed") nil 'silent)))
554 (lambda () (package--update-downloads-in-progress (cons archive file)))))))))
555
556(defun package--download-and-read-archives (&optional async)
557 "Download descriptions of all `package-archives' and read them.
558Populate `package-archive-contents' with the result.
559
560If optional argument ASYNC is non-nil, perform the downloads
561asynchronously."
562 (dolist (archive package-archives)
563 (condition-case-unless-debug err
564 (package--download-one-archive archive "archive-contents" async)
565 (error (message "Failed to download `%s' archive: %s"
566 (car archive)
567 (error-message-string err))))))
568
569(defvar package-refresh-contents-hook (list #'package--download-and-read-archives)
570 "List of functions to call to refresh the package archive.
571Each function may take an optional argument indicating that the
572operation ought to be executed asynchronously.")
573
574;;;###autoload
575(defun package-refresh-contents (&optional async)
576 "Download descriptions of all configured ELPA packages.
577For each archive configured in the variable `package-archives',
578inform Emacs about the latest versions of all packages it offers,
579and make them available for download.
580Optional argument ASYNC specifies whether to perform the
581downloads in the background. This is always the case when the command
582is invoked interactively."
583 (interactive (list t))
584 (when async
585 (message "Refreshing package contents..."))
586 (unless (file-exists-p package-user-dir)
587 (make-directory package-user-dir t))
588 (let ((default-keyring (expand-file-name "package-keyring.gpg"
589 data-directory))
590 (inhibit-message (or inhibit-message async)))
591 (when (and (package-check-signature) (file-exists-p default-keyring))
592 (condition-case-unless-debug error
593 (package-import-keyring default-keyring)
594 (error (message "Cannot import default keyring: %s"
595 (error-message-string error))))))
596
597 (run-hook-with-args 'package-refresh-contents-hook async))
598
599(defun package--archives-initialize ()
600 "Make sure the list of installed and remote packages are initialized."
601 (unless package--initialized
602 (package-initialize t))
603 (unless package-archive-contents
604 (package-refresh-contents)))
605
606(defun package-archive-priority (archive)
607 "Return the priority of ARCHIVE.
608
609The archive priorities are specified in
610`package-archive-priorities'. If not given there, the priority
611defaults to 0."
612 (or (cdr (assoc archive package-archive-priorities))
613 0))
614
615(defun package-desc-priority (pkg-desc)
616 "Return the priority of the archive of package-desc object PKG-DESC."
617 (package-archive-priority (package-desc-archive pkg-desc)))
618
619(defun package-desc-priority-version (pkg-desc)
620 "Return the version PKG-DESC with the archive priority prepended.
621
622This allows for easy comparison of package versions from
623different archives if archive priorities are meant to be taken in
624consideration."
625 (cons (package-desc-priority pkg-desc)
626 (package-desc-version pkg-desc)))
627
628(provide 'package-elpa)
629;;; package-elpa.el ends here
diff --git a/lisp/package/package-install.el b/lisp/package/package-install.el
new file mode 100644
index 00000000000..5a96fedd528
--- /dev/null
+++ b/lisp/package/package-install.el
@@ -0,0 +1,1053 @@
1;;; package-install.el --- Physical Package Management -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6;; Keywords:
7
8;; This program is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation, either version 3 of the License, or
11;; (at your option) any later version.
12
13;; This program is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with this program. If not, see <https://www.gnu.org/licenses/>.
20
21;;; Commentary:
22
23;;
24
25;;; Code:
26
27(require 'package-core)
28(require 'package-misc)
29(require 'package-elpa)
30(require 'package-compile)
31(require 'package-quickstart)
32
33(require 'epg)
34(require 'tar-mode)
35(require 'lisp-mnt)
36
37(defcustom package-install-upgrade-built-in nil
38 "Non-nil means that built-in packages can be upgraded via a package archive.
39If disabled, then `package-install' will not suggest to replace a
40built-in package with a (possibly newer) version from a package archive."
41 :type 'boolean
42 :version "29.1"
43 :group 'package)
44
45(defun package-compute-transaction (packages requirements &optional seen)
46 "Return a list of packages to be installed, including PACKAGES.
47PACKAGES should be a list of `package-desc'.
48
49REQUIREMENTS should be a list of additional requirements; each
50element in this list should have the form (PACKAGE VERSION-LIST),
51where PACKAGE is a package name and VERSION-LIST is the required
52version of that package.
53
54This function recursively computes the requirements of the
55packages in REQUIREMENTS, and returns a list of all the packages
56that must be installed. Packages that are already installed are
57not included in this list.
58
59SEEN is used internally to detect infinite recursion."
60 ;; FIXME: We really should use backtracking to explore the whole
61 ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1
62 ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0:
63 ;; the current code might fail to see that it could install foo by using the
64 ;; older bar-1.3).
65 (dolist (elt requirements)
66 (let* ((next-pkg (car elt))
67 (next-version (cadr elt))
68 (already ()))
69 (dolist (pkg packages)
70 (if (eq next-pkg (package-desc-name pkg))
71 (setq already pkg)))
72 (when already
73 (if (version-list-<= next-version (package-desc-version already))
74 ;; `next-pkg' is already in `packages', but its position there
75 ;; means it might be installed too late: remove it from there, so
76 ;; we re-add it (along with its dependencies) at an earlier place
77 ;; below (bug#16994).
78 (if (memq already seen) ;Avoid inf-loop on dependency cycles.
79 (message "Dependency cycle going through %S"
80 (package-desc-full-name already))
81 (setq packages (delq already packages))
82 (setq already nil))
83 (error "Need package `%s-%s', but only %s is being installed"
84 next-pkg (package-version-join next-version)
85 (package-version-join (package-desc-version already)))))
86 (cond
87 (already nil)
88 ((package-installed-p next-pkg next-version) nil)
89
90 (t
91 ;; A package is required, but not installed. It might also be
92 ;; blocked via `package-load-list'.
93 (let ((pkg-descs (cdr (assq next-pkg package-archive-contents)))
94 (found nil)
95 (found-something nil)
96 (problem nil))
97 (while (and pkg-descs (not found))
98 (let* ((pkg-desc (pop pkg-descs))
99 (version (package-desc-version pkg-desc))
100 (disabled (package-disabled-p next-pkg version)))
101 (cond
102 ((version-list-< version next-version)
103 ;; pkg-descs is sorted by priority, not version, so
104 ;; don't error just yet.
105 (unless found-something
106 (setq found-something (package-version-join version))))
107 (disabled
108 (unless problem
109 (setq problem
110 (if (stringp disabled)
111 (format-message
112 "Package `%s' held at version %s, but version %s required"
113 next-pkg disabled
114 (package-version-join next-version))
115 (format-message "Required package `%s' is disabled"
116 next-pkg)))))
117 (t (setq found pkg-desc)))))
118 (unless found
119 (cond
120 (problem (error "%s" problem))
121 (found-something
122 (error "Need package `%s-%s', but only %s is available"
123 next-pkg (package-version-join next-version)
124 found-something))
125 (t
126 (if (eq next-pkg 'emacs)
127 (error "This package requires Emacs version %s"
128 (package-version-join next-version))
129 (error (if (not next-version)
130 (format "Package `%s' is unavailable" next-pkg)
131 (format "Package `%s' (version %s) is unavailable"
132 next-pkg (package-version-join next-version))))))))
133 (setq packages
134 (package-compute-transaction (cons found packages)
135 (package-desc-reqs found)
136 (cons found seen))))))))
137 packages)
138
139(defun package--get-deps (pkgs)
140 (let ((seen '()))
141 (while pkgs
142 (let ((pkg (pop pkgs)))
143 (if (memq pkg seen)
144 nil ;; Done already!
145 (let ((pkg-desc (cadr (assq pkg package-alist))))
146 (when pkg-desc
147 (push pkg seen)
148 (setq pkgs (append (mapcar #'car (package-desc-reqs pkg-desc))
149 pkgs)))))))
150 seen))
151
152(defun package--user-installed-p (package)
153 "Return non-nil if PACKAGE is a user-installed package.
154PACKAGE is the package name, a symbol. Check whether the package
155was installed into `package-user-dir' where we assume to have
156control over."
157 (let* ((pkg-desc (cadr (assq package package-alist)))
158 (dir (package-desc-dir pkg-desc)))
159 (file-in-directory-p dir package-user-dir)))
160
161(defun package--removable-packages ()
162 "Return a list of names of packages no longer needed.
163These are packages which are neither contained in
164`package-selected-packages' nor a dependency of one that is."
165 (let ((needed (package--get-deps package-selected-packages)))
166 (cl-loop for p in (mapcar #'car package-alist)
167 unless (or (memq p needed)
168 ;; Do not auto-remove external packages.
169 (not (package--user-installed-p p)))
170 collect p)))
171
172(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all)
173 "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST.
174Return the first package found in PKG-LIST of which PKG is a
175dependency. If ALL is non-nil, return all such packages instead.
176
177When not specified, PKG-LIST defaults to `package-alist'
178with PKG-DESC entry removed."
179 (unless (string= (package-desc-status pkg-desc) "obsolete")
180 (let* ((pkg (package-desc-name pkg-desc))
181 (alist (or pkg-list
182 (remove (assq pkg package-alist)
183 package-alist))))
184 (if all
185 (cl-loop for p in alist
186 if (assq pkg (package-desc-reqs (cadr p)))
187 collect (cadr p))
188 (cl-loop for p in alist thereis
189 (and (assq pkg (package-desc-reqs (cadr p)))
190 (cadr p)))))))
191
192(defun package--sort-deps-in-alist (package only)
193 "Return a list of dependencies for PACKAGE sorted by dependency.
194PACKAGE is included as the first element of the returned list.
195ONLY is an alist associating package names to package objects.
196Only these packages will be in the return value and their cdrs are
197destructively set to nil in ONLY."
198 (let ((out))
199 (dolist (dep (package-desc-reqs package))
200 (when-let* ((cell (assq (car dep) only))
201 (dep-package (cdr-safe cell)))
202 (setcdr cell nil)
203 (setq out (append (package--sort-deps-in-alist dep-package only)
204 out))))
205 (cons package out)))
206
207(defun package--sort-by-dependence (package-list)
208 "Return PACKAGE-LIST sorted by dependence.
209That is, any element of the returned list is guaranteed to not
210directly depend on any elements that come before it.
211
212PACKAGE-LIST is a list of `package-desc' objects.
213Indirect dependencies are guaranteed to be returned in order only
214if all the in-between dependencies are also in PACKAGE-LIST."
215 (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list))
216 out-list)
217 (dolist (cell alist out-list)
218 ;; `package--sort-deps-in-alist' destructively changes alist, so
219 ;; some cells might already be empty. We check this here.
220 (when-let* ((pkg-desc (cdr cell)))
221 (setcdr cell nil)
222 (setq out-list
223 (append (package--sort-deps-in-alist pkg-desc alist)
224 out-list))))))
225
226
227;;; Installation Functions
228;; As opposed to the previous section (which listed some underlying
229;; functions necessary for installation), this one contains the actual
230;; functions that install packages. The package itself can be
231;; installed in a variety of ways (archives, buffer, file), but
232;; requirements (dependencies) are always satisfied by looking in
233;; `package-archive-contents'.
234
235(defun package-archive-base (desc)
236 "Return the package described by DESC."
237 (cdr (assoc (package-desc-archive desc) package-archives)))
238
239(defun package-desc-suffix (pkg-desc)
240 "Return file-name extension of package-desc object PKG-DESC.
241Depending on the `package-desc-kind' of PKG-DESC, this is one of:
242
243 \\='single - \".el\"
244 \\='tar - \".tar\"
245 \\='dir - \"\"
246
247Signal an error if the kind is none of the above."
248 (pcase (package-desc-kind pkg-desc)
249 ('single ".el")
250 ('tar ".tar")
251 ('dir "")
252 (kind (error "Unknown package kind: %s" kind))))
253
254(defun package-install-from-archive (pkg-desc)
255 "Download and install a package defined by PKG-DESC."
256 ;; This won't happen, unless the archive is doing something wrong.
257 (when (eq (package-desc-kind pkg-desc) 'dir)
258 (error "Can't install directory package from archive"))
259 (let* ((location (package-archive-base pkg-desc))
260 (file (concat (package-desc-full-name pkg-desc)
261 (package-desc-suffix pkg-desc))))
262 (package--with-response-buffer location :file file
263 (if (or (not (package-check-signature))
264 (member (package-desc-archive pkg-desc)
265 package-unsigned-archives))
266 ;; If we don't care about the signature, unpack and we're
267 ;; done.
268 (let ((save-silently t))
269 (package-unpack pkg-desc))
270 ;; If we care, check it and *then* write the file.
271 (let ((content (buffer-string)))
272 (package--check-signature
273 location file content nil
274 ;; This function will be called after signature checking.
275 (lambda (&optional good-sigs)
276 ;; Signature checked, unpack now.
277 (with-temp-buffer ;FIXME: Just use the previous current-buffer.
278 (set-buffer-multibyte nil)
279 (cl-assert (not (multibyte-string-p content)))
280 (insert content)
281 (let ((save-silently t))
282 (package-unpack pkg-desc)))
283 ;; Here the package has been installed successfully, mark it as
284 ;; signed if appropriate.
285 (when good-sigs
286 ;; Write out good signatures into NAME-VERSION.signed file.
287 (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
288 nil
289 (expand-file-name
290 (concat (package-desc-full-name pkg-desc) ".signed")
291 package-user-dir)
292 nil 'silent)
293 ;; Update the old pkg-desc which will be shown on the description buffer.
294 (setf (package-desc-signed pkg-desc) t)
295 ;; Update the new (activated) pkg-desc as well.
296 (when-let* ((pkg-descs (cdr (assq (package-desc-name pkg-desc)
297 package-alist))))
298 (setf (package-desc-signed (car pkg-descs)) t))))))))))
299
300;;;###autoload
301(defun package-installed-p (package &optional min-version)
302 "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed.
303If PACKAGE is a symbol, it is the package name and MIN-VERSION
304should be a version list.
305
306If PACKAGE is a `package-desc' object, MIN-VERSION is ignored."
307 (cond
308 ((package-desc-p package)
309 (let ((dir (package-desc-dir package)))
310 (and (stringp dir)
311 (file-exists-p dir))))
312 ((and (not package--initialized)
313 (null min-version)
314 package-activated-list)
315 ;; We used the quickstart: make it possible to use package-installed-p
316 ;; even before package is fully initialized.
317 (or
318 (memq package package-activated-list)
319 ;; Also check built-in packages.
320 (package-built-in-p package min-version)))
321 (t
322 (or
323 (let ((pkg-descs (cdr (assq package (package--alist)))))
324 (and pkg-descs
325 (version-list-<= min-version
326 (package-desc-version (car pkg-descs)))))
327 ;; Also check built-in packages.
328 (package-built-in-p package min-version)))))
329
330(defun package-download-transaction (packages)
331 "Download and install all the packages in PACKAGES.
332PACKAGES should be a list of `package-desc'.
333This function assumes that all package requirements in
334PACKAGES are satisfied, i.e. that PACKAGES is computed
335using `package-compute-transaction'."
336 (mapc #'package-install-from-archive packages))
337
338;;;###autoload
339(defun package-install (pkg &optional dont-select)
340 "Install the package PKG.
341
342PKG can be a `package-desc', or a symbol naming one of the available
343packages in an archive in `package-archives'.
344
345Mark the installed package as selected by adding it to
346`package-selected-packages'.
347
348When called from Lisp and optional argument DONT-SELECT is
349non-nil, install the package but do not add it to
350`package-selected-packages'.
351
352If PKG is a `package-desc' and it is already installed, don't try
353to install it but still mark it as selected.
354
355If the command is invoked with a prefix argument, it will allow
356upgrading of built-in packages, as if `package-install-upgrade-built-in'
357had been enabled."
358 (interactive
359 (progn
360 ;; Initialize the package system to get the list of package
361 ;; symbols for completion.
362 (package--archives-initialize)
363 (list (intern (completing-read
364 "Install package: "
365 (mapcan
366 (lambda (elt)
367 (and (or (and (or current-prefix-arg
368 package-install-upgrade-built-in)
369 (package--active-built-in-p (car elt)))
370 (not (package-installed-p (car elt))))
371 (list (symbol-name (car elt)))))
372 package-archive-contents)
373 nil t))
374 nil)))
375 (cl-check-type pkg (or symbol package-desc))
376 (package--archives-initialize)
377 (when (fboundp 'package-menu--post-refresh)
378 (add-hook 'post-command-hook #'package-menu--post-refresh))
379 (let ((name (if (package-desc-p pkg)
380 (package-desc-name pkg)
381 pkg)))
382 (unless (or dont-select (package--user-selected-p name))
383 (package--save-selected-packages
384 (cons name package-selected-packages)))
385 (when (and (or current-prefix-arg package-install-upgrade-built-in)
386 (package--active-built-in-p pkg))
387 (setq pkg (or (cadr (assq name package-archive-contents)) pkg)))
388 (if-let* ((transaction
389 (if (package-desc-p pkg)
390 (unless (package-installed-p pkg)
391 (package-compute-transaction (list pkg)
392 (package-desc-reqs pkg)))
393 (package-compute-transaction () (list (list pkg))))))
394 (progn
395 (package-download-transaction transaction)
396 (package--quickstart-maybe-refresh)
397 (message "Package `%s' installed." name))
398 (message "`%s' is already installed" name))))
399
400(declare-function package-vc-upgrade "package-vc" (pkg))
401
402;;;###autoload
403(defun package-upgrade (name)
404 "Upgrade package NAME if a newer version exists.
405
406NAME should be a symbol."
407 (interactive
408 (list (intern (completing-read
409 "Upgrade package: "
410 (package--upgradeable-packages t) nil t))))
411 (cl-check-type name symbol)
412 (let* ((pkg-desc (cadr (assq name package-alist)))
413 (package-install-upgrade-built-in (not pkg-desc)))
414 ;; `pkg-desc' will be nil when the package is an "active built-in".
415 (if (and pkg-desc (package-vc-p pkg-desc))
416 (package-vc-upgrade pkg-desc)
417 (when pkg-desc
418 (package-delete pkg-desc 'force 'dont-unselect))
419 (package-install name
420 ;; An active built-in has never been "selected"
421 ;; before. Mark it as installed explicitly.
422 (and pkg-desc 'dont-select)))))
423
424(defun package--upgradeable-packages (&optional include-builtins)
425 ;; Initialize the package system to get the list of package
426 ;; symbols for completion.
427 (package--archives-initialize)
428 (mapcar
429 #'car
430 (seq-filter
431 (lambda (elt)
432 (or (let ((available
433 (assq (car elt) package-archive-contents)))
434 (and available
435 (or (and
436 include-builtins
437 (not (package-desc-version (cadr elt))))
438 (version-list-<
439 (package-desc-version (cadr elt))
440 (package-desc-version (cadr available))))))
441 (package-vc-p (cadr elt))))
442 (if include-builtins
443 (append package-alist
444 (mapcan
445 (lambda (elt)
446 (when (not (assq (car elt) package-alist))
447 (list (list (car elt) (package--from-builtin elt)))))
448 package--builtins))
449 package-alist))))
450
451;;;###autoload
452(defun package-upgrade-all (&optional query)
453 "Refresh package list and upgrade all packages.
454If QUERY, ask the user before upgrading packages. When called
455interactively, QUERY is always true.
456
457Currently, packages which are part of the Emacs distribution are
458not upgraded by this command. To enable upgrading such a package
459using this command, first upgrade the package to a newer version
460from ELPA by either using `\\[package-upgrade]' or
461`\\<package-menu-mode-map>\\[package-menu-mark-install]' after `\\[list-packages]'."
462 (interactive (list (not noninteractive)))
463 (package-refresh-contents)
464 (let ((upgradeable (package--upgradeable-packages)))
465 (if (not upgradeable)
466 (message "No packages to upgrade")
467 (when (and query
468 (not (yes-or-no-p
469 (if (length= upgradeable 1)
470 "One package to upgrade. Do it? "
471 (format "%s packages to upgrade. Do it?"
472 (length upgradeable))))))
473 (user-error "Upgrade aborted"))
474 (mapc #'package-upgrade upgradeable))))
475
476(defun package--dependencies (pkg)
477 "Return a list of all transitive dependencies of PKG.
478If PKG is a package descriptor, the return value is a list of
479package descriptors. If PKG is a symbol designating a package,
480the return value is a list of symbols designating packages."
481 (when-let* ((desc (if (package-desc-p pkg) pkg
482 (cadr (assq pkg package-archive-contents)))))
483 ;; Can we have circular dependencies? Assume "nope".
484 (let ((all (named-let more ((pkg-desc desc))
485 (let (deps)
486 (dolist (req (package-desc-reqs pkg-desc))
487 (setq deps (nconc
488 (catch 'found
489 (dolist (p (apply #'append (mapcar #'cdr (package--alist))))
490 (when (and (string= (car req) (package-desc-name p))
491 (version-list-<= (cadr req) (package-desc-version p)))
492 (throw 'found (more p)))))
493 deps)))
494 (delete-dups (cons pkg-desc deps))))))
495 (remq pkg (mapcar (if (package-desc-p pkg) #'identity #'package-desc-name) all)))))
496
497(defun package-buffer-info ()
498 "Return a `package-desc' describing the package in the current buffer.
499
500If the buffer does not contain a conforming package, signal an
501error. If there is a package, narrow the buffer to the file's
502boundaries."
503 (goto-char (point-min))
504 (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
505 (error "Package lacks a file header"))
506 (let ((file-name (match-string-no-properties 1))
507 (desc (match-string-no-properties 2)))
508 (require 'lisp-mnt)
509 (let* ((version-info (lm-package-version))
510 (pkg-version (package-strip-rcs-id version-info))
511 (keywords (lm-keywords-list))
512 (website (lm-website)))
513 (unless pkg-version
514 (if version-info
515 (error "Unrecognized package version: %s" version-info)
516 (error "Package lacks a \"Version\" or \"Package-Version\" header")))
517 (package-desc-from-define
518 file-name pkg-version desc
519 (lm-package-requires)
520 :kind 'single
521 :url website
522 :keywords keywords
523 :maintainer
524 ;; For backward compatibility, use a single cons-cell if
525 ;; there's only one maintainer (the most common case).
526 (let ((maints (lm-maintainers))) (if (cdr maints) maints (car maints)))
527 :authors (lm-authors)))))
528
529(defun package-dir-info ()
530 "Find package information for a directory.
531The return result is a `package-desc'."
532 (cl-assert (derived-mode-p 'dired-mode))
533 (let* ((desc-file (package--description-file default-directory)))
534 (if (file-readable-p desc-file)
535 (with-temp-buffer
536 (insert-file-contents desc-file)
537 (package--read-pkg-desc 'dir))
538 (catch 'found
539 (let ((files (or (and (derived-mode-p 'dired-mode)
540 (dired-get-marked-files))
541 (directory-files-recursively default-directory "\\.el\\'"))))
542 ;; We sort the file names in lexicographical order, to ensure
543 ;; that we check shorter file names first (ie. those further
544 ;; up in the directory structure).
545 (dolist (file (sort files))
546 ;; The file may be a link to a nonexistent file; e.g., a
547 ;; lock file.
548 (when (file-exists-p file)
549 (with-temp-buffer
550 (insert-file-contents file)
551 ;; When we find the file with the data,
552 (when-let* ((info (ignore-errors (package-buffer-info))))
553 (setf (package-desc-kind info) 'dir)
554 (throw 'found info))))))
555 (error "No .el files with package headers in `%s'" default-directory)))))
556
557;;;###autoload
558(defun package-install-from-buffer ()
559 "Install a package from the current buffer.
560The current buffer is assumed to be a single .el or .tar file or
561a directory. These must follow the packaging guidelines (see
562info node `(elisp)Packaging').
563
564Specially, if current buffer is a directory, the -pkg.el
565description file is not mandatory, in which case the information
566is derived from the main .el file in the directory. Using Dired,
567you can restrict what files to install by marking specific files.
568
569Downloads and installs required packages as needed."
570 (interactive)
571 (let* ((pkg-desc
572 (cond
573 ((derived-mode-p 'dired-mode)
574 ;; This is the only way a package-desc object with a `dir'
575 ;; desc-kind can be created. Such packages can't be
576 ;; uploaded or installed from archives, they can only be
577 ;; installed from local buffers or directories.
578 (package-dir-info))
579 ((derived-mode-p 'tar-mode)
580 (package-tar-file-info))
581 (t
582 ;; Package headers should be parsed from decoded text
583 ;; (see Bug#48137) where possible.
584 (if (and (eq buffer-file-coding-system 'no-conversion)
585 buffer-file-name)
586 (let* ((package-buffer (current-buffer))
587 (decoding-system
588 (car (find-operation-coding-system
589 'insert-file-contents
590 (cons buffer-file-name
591 package-buffer)))))
592 (with-temp-buffer
593 (insert-buffer-substring package-buffer)
594 (decode-coding-region (point-min) (point-max)
595 decoding-system)
596 (package-buffer-info)))
597
598 (save-excursion
599 (package-buffer-info))))))
600 (name (package-desc-name pkg-desc)))
601 ;; Download and install the dependencies.
602 (let* ((requires (package-desc-reqs pkg-desc))
603 (transaction (package-compute-transaction nil requires)))
604 (package-download-transaction transaction))
605 ;; Install the package itself.
606 (package-unpack pkg-desc)
607 (unless (package--user-selected-p name)
608 (package--save-selected-packages
609 (cons name package-selected-packages)))
610 (package--quickstart-maybe-refresh)
611 pkg-desc))
612
613;;;###autoload
614(defun package-install-file (file)
615 "Install a package from FILE.
616The file can either be a tar file, an Emacs Lisp file, or a
617directory."
618 (interactive "fPackage file name: ")
619 (with-temp-buffer
620 (if (file-directory-p file)
621 (progn
622 (setq default-directory file)
623 (dired-mode))
624 (insert-file-contents-literally file)
625 (set-visited-file-name file)
626 (set-buffer-modified-p nil)
627 (when (string-match "\\.tar\\'" file) (tar-mode)))
628 (package-install-from-buffer)))
629
630
631
632;;;###autoload
633(defun package-install-selected-packages (&optional noconfirm)
634 "Ensure packages in `package-selected-packages' are installed.
635If some packages are not installed, propose to install them.
636
637If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
638argument, don't ask for confirmation to install packages."
639 (interactive "P")
640 (package--archives-initialize)
641 ;; We don't need to populate `package-selected-packages' before
642 ;; using here, because the outcome is the same either way (nothing
643 ;; gets installed).
644 (if (not package-selected-packages)
645 (message "`package-selected-packages' is empty, nothing to install")
646 (let* ((not-installed (seq-remove #'package-installed-p package-selected-packages))
647 (available (seq-filter (lambda (p) (assq p package-archive-contents)) not-installed))
648 (difference (- (length not-installed) (length available))))
649 (cond
650 (available
651 (when (or noconfirm
652 (y-or-n-p
653 (format "Packages to install: %d (%s), proceed? "
654 (length available)
655 (mapconcat #'symbol-name available " "))))
656 (mapc (lambda (p) (package-install p 'dont-select)) available)))
657 ((> difference 0)
658 (message (substitute-command-keys
659 "Packages that are not available: %d (the rest is already \
660installed), maybe you need to \\[package-refresh-contents]")
661 difference))
662 (t
663 (message "All your packages are already installed"))))))
664
665(defun package--newest-p (pkg)
666 "Return non-nil if PKG is the newest package with its name."
667 (equal (cadr (assq (package-desc-name pkg) package-alist))
668 pkg))
669
670(declare-function comp-el-to-eln-filename "comp.c")
671(defvar package-vc-repository-store)
672(defun package--delete-directory (dir)
673 "Delete PKG-DESC directory DIR recursively.
674Clean-up the corresponding .eln files if Emacs is native
675compiled."
676 (when (featurep 'native-compile)
677 (cl-loop
678 for file in (directory-files-recursively dir
679 ;; Exclude lockfiles
680 (rx bos (or (and "." (not "#")) (not ".")) (* nonl) ".el" eos))
681 do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
682 (if (file-symlink-p (directory-file-name dir))
683 (delete-file (directory-file-name dir))
684 (delete-directory dir t)))
685
686(defun package-delete (pkg-desc &optional force nosave)
687 "Delete package PKG-DESC.
688
689Argument PKG-DESC is the full description of the package, for example as
690obtained by `package-get-descriptor'. Interactively, prompt the user
691for the package name and version.
692
693When package is used elsewhere as dependency of another package,
694refuse deleting it and return an error.
695If prefix argument FORCE is non-nil, package will be deleted even
696if it is used elsewhere.
697If NOSAVE is non-nil, the package is not removed from
698`package-selected-packages'."
699 (interactive
700 (progn
701 (let* ((package-table
702 (mapcar
703 (lambda (p) (cons (package-desc-full-name p) p))
704 (delq nil
705 (mapcar (lambda (p) (unless (package-built-in-p p) p))
706 (apply #'append (mapcar #'cdr (package--alist)))))))
707 (package-name (completing-read "Delete package: "
708 (mapcar #'car package-table)
709 nil t)))
710 (list (cdr (assoc package-name package-table))
711 current-prefix-arg nil))))
712 (let* ((dir (package-desc-dir pkg-desc))
713 (name (package-desc-name pkg-desc))
714 (new-package-alist (let ((pkgs (assq name package-alist)))
715 (if (null (remove pkg-desc (cdr pkgs)))
716 (remq pkgs package-alist)
717 package-alist)))
718 pkg-used-elsewhere-by)
719 ;; If the user is trying to delete this package, they definitely
720 ;; don't want it marked as selected, so we remove it from
721 ;; `package-selected-packages' even if it can't be deleted.
722 (when (and (null nosave)
723 (package--user-selected-p name)
724 ;; Don't deselect if this is an older version of an
725 ;; upgraded package.
726 (package--newest-p pkg-desc))
727 (package--save-selected-packages (remove name package-selected-packages)))
728 (cond ((not (string-prefix-p (file-name-as-directory
729 (expand-file-name package-user-dir))
730 (expand-file-name dir)))
731 ;; Don't delete "system" packages.
732 (error "Package `%s' is a system package, not deleting"
733 (package-desc-full-name pkg-desc)))
734 ((and (null force)
735 (setq pkg-used-elsewhere-by
736 (let ((package-alist new-package-alist))
737 (package--used-elsewhere-p pkg-desc)))) ;See bug#65475
738 ;; Don't delete packages used as dependency elsewhere.
739 (error "Package `%s' is used by `%s' as dependency, not deleting"
740 (package-desc-full-name pkg-desc)
741 (package-desc-name pkg-used-elsewhere-by)))
742 (t
743 (add-hook 'post-command-hook 'package-menu--post-refresh)
744 (package--delete-directory dir)
745 ;; Remove NAME-VERSION.signed and NAME-readme.txt files.
746 ;;
747 ;; NAME-readme.txt files are no longer created, but they
748 ;; may be left around from an earlier install.
749 (dolist (suffix '(".signed" "readme.txt"))
750 (let* ((version (package-version-join (package-desc-version pkg-desc)))
751 (file (concat (if (string= suffix ".signed")
752 dir
753 (substring dir 0 (- (length version))))
754 suffix)))
755 (when (file-exists-p file)
756 (delete-file file))))
757 ;; Update package-alist.
758 (setq package-alist new-package-alist)
759 (package--quickstart-maybe-refresh)
760 (message "Package `%s' deleted."
761 (package-desc-full-name pkg-desc))))))
762
763;;;###autoload
764(defun package-reinstall (pkg)
765 "Reinstall package PKG.
766PKG should be either a symbol, the package name, or a `package-desc'
767object."
768 (interactive
769 (progn
770 (package--archives-initialize)
771 (list (intern (completing-read
772 "Reinstall package: "
773 (mapcar #'symbol-name
774 (mapcar #'car package-alist)))))))
775 (package--archives-initialize)
776 (package-delete
777 (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist)))
778 'force 'nosave)
779 (package-install pkg 'dont-select))
780
781;;;###autoload
782(defun package-autoremove (&optional noconfirm)
783 "Remove packages that are no longer needed.
784
785Packages that are no more needed by other packages in
786`package-selected-packages' and their dependencies
787will be deleted.
788
789If optional argument NOCONFIRM is non-nil, or when invoked with a prefix
790argument, don't ask for confirmation to install packages."
791 (interactive "P")
792 ;; If `package-selected-packages' is nil, it would make no sense to
793 ;; try to populate it here, because then `package-autoremove' will
794 ;; do absolutely nothing.
795 (when (or noconfirm
796 package-selected-packages
797 (yes-or-no-p
798 (format-message
799 "`package-selected-packages' is empty! Really remove ALL packages? ")))
800 (let ((removable (package--removable-packages)))
801 (if removable
802 (when (or noconfirm
803 (y-or-n-p
804 (format "Packages to delete: %d (%s), proceed? "
805 (length removable)
806 (mapconcat #'symbol-name removable " "))))
807 (mapc (lambda (p)
808 (package-delete (cadr (assq p package-alist)) t))
809 removable))
810 (message "Nothing to autoremove")))))
811
812
813;;;; Autoload
814(declare-function autoload-rubric "autoload" (file &optional type feature))
815
816(defun package-autoload-ensure-default-file (file)
817 "Make sure that the autoload file FILE exists and if not create it."
818 (declare (obsolete nil "29.1"))
819 (unless (file-exists-p file)
820 (require 'autoload)
821 (let ((coding-system-for-write 'utf-8-emacs-unix))
822 (with-suppressed-warnings ((obsolete autoload-rubric))
823 (write-region (autoload-rubric file "package" nil)
824 nil file nil 'silent))))
825 file)
826
827(defvar autoload-timestamps)
828(defvar version-control)
829
830(defun package-generate-autoloads (name pkg-dir)
831 "Generate autoloads in PKG-DIR for package named NAME."
832 (let* ((auto-name (format "%s-autoloads.el" name))
833 ;;(ignore-name (concat name "-pkg.el"))
834 (output-file (expand-file-name auto-name pkg-dir))
835 ;; We don't need 'em, and this makes the output reproducible.
836 (autoload-timestamps nil)
837 (backup-inhibited t)
838 (version-control 'never))
839 (loaddefs-generate
840 pkg-dir output-file nil
841 (prin1-to-string
842 '(add-to-list
843 'load-path
844 ;; Add the directory that will contain the autoload file to
845 ;; the load path. We don't hard-code `pkg-dir', to avoid
846 ;; issues if the package directory is moved around.
847 ;; `loaddefs-generate' has code to do this for us, but it's
848 ;; not currently exposed. (Bug#63625)
849 (or (and load-file-name
850 (directory-file-name
851 (file-name-directory load-file-name)))
852 (car load-path)))))
853 (let ((buf (find-buffer-visiting output-file)))
854 (when buf (kill-buffer buf)))
855 auto-name))
856
857(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir)
858 "Generate autoloads, description file, etc., for PKG-DESC installed at PKG-DIR."
859 (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir)
860 (let ((desc-file (expand-file-name (package--description-file pkg-dir)
861 pkg-dir)))
862 (unless (file-exists-p desc-file)
863 (package-generate-description-file pkg-desc desc-file)))
864 ;; FIXME: Create foo.info and dir file from foo.texi?
865 )
866
867(defun package-tar-file-info ()
868 "Find package information for a tar file.
869The return result is a `package-desc'."
870 (cl-assert (derived-mode-p 'tar-mode))
871 (let* ((dir-name (named-let loop
872 ((filename (tar-header-name (car tar-parse-info))))
873 (let ((dirname (file-name-directory filename)))
874 ;; The first file can be in a subdir: look for the top.
875 (if dirname (loop (directory-file-name dirname))
876 (file-name-as-directory filename)))))
877 (desc-file (package--description-file dir-name))
878 (tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
879 (unless tar-desc
880 (error "No package descriptor file found"))
881 (with-current-buffer (tar--extract tar-desc)
882 (unwind-protect
883 (or (package--read-pkg-desc 'tar)
884 (error "Can't find define-package in %s"
885 (tar-header-name tar-desc)))
886 (kill-buffer (current-buffer))))))
887
888(defun package-untar-buffer (dir)
889 "Untar the current buffer.
890This uses `tar-untar-buffer' from Tar mode. All files should
891untar into a directory named DIR; otherwise, signal an error."
892 (tar-mode)
893 ;; Make sure everything extracts into DIR.
894 (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
895 (case-fold-search (file-name-case-insensitive-p dir)))
896 (dolist (tar-data tar-parse-info)
897 (let ((name (expand-file-name (tar-header-name tar-data))))
898 (or (string-match regexp name)
899 ;; Tarballs created by some utilities don't list
900 ;; directories with a trailing slash (Bug#13136).
901 (and (string-equal (expand-file-name dir) name)
902 (eq (tar-header-link-type tar-data) 5))
903 (error "Package does not untar cleanly into directory %s/" dir)))))
904 (tar-untar-buffer))
905
906(declare-function dired-get-marked-files "dired")
907
908(defun package-unpack (pkg-desc)
909 "Install the contents of the current buffer as a package."
910 (let* ((name (package-desc-name pkg-desc))
911 (dirname (package-desc-full-name pkg-desc))
912 (pkg-dir (expand-file-name dirname package-user-dir)))
913 (pcase (package-desc-kind pkg-desc)
914 ('dir
915 (make-directory pkg-dir t)
916 (let ((file-list
917 (or (and (derived-mode-p 'dired-mode)
918 (dired-get-marked-files))
919 (directory-files-recursively default-directory "" nil))))
920 (dolist (source-file file-list)
921 (let ((target (expand-file-name
922 (file-relative-name source-file default-directory)
923 pkg-dir)))
924 (make-directory (file-name-directory target) t)
925 (copy-file source-file target t)))
926 ;; Now that the files have been installed, this package is
927 ;; indistinguishable from a `tar' or a `single'. Let's make
928 ;; things simple by ensuring we're one of them.
929 (setf (package-desc-kind pkg-desc)
930 (if (length> file-list 1) 'tar 'single))))
931 ('tar
932 (make-directory package-user-dir t)
933 (let* ((default-directory (file-name-as-directory package-user-dir)))
934 (package-untar-buffer dirname)))
935 ('single
936 (let ((el-file (expand-file-name (format "%s.el" name) pkg-dir)))
937 (make-directory pkg-dir t)
938 (package--write-file-no-coding el-file)))
939 (kind (error "Unknown package kind: %S" kind)))
940 (package--make-autoloads-and-stuff pkg-desc pkg-dir)
941 ;; Update package-alist.
942 (let ((new-desc (package-load-descriptor pkg-dir)))
943 (unless (equal (package-desc-full-name new-desc)
944 (package-desc-full-name pkg-desc))
945 (error "The retrieved package (`%s') doesn't match what the archive offered (`%s')"
946 (package-desc-full-name new-desc) (package-desc-full-name pkg-desc)))
947 ;; Activation has to be done before compilation, so that if we're
948 ;; upgrading and macros have changed we load the new definitions
949 ;; before compiling.
950 (when (package-activate-1 new-desc :reload :deps)
951 ;; FIXME: Compilation should be done as a separate, optional, step.
952 ;; E.g. for multi-package installs, we should first install all packages
953 ;; and then compile them.
954 (package--compile new-desc)
955 (when package-native-compile
956 (package--native-compile-async new-desc))
957 ;; After compilation, load again any files loaded by
958 ;; `activate-1', so that we use the byte-compiled definitions.
959 (package--reload-previously-loaded new-desc)))
960 pkg-dir))
961
962(defun package-generate-description-file (pkg-desc pkg-file)
963 "Create the foo-pkg.el file PKG-FILE for single-file package PKG-DESC."
964 (let* ((name (package-desc-name pkg-desc)))
965 (let ((print-level nil)
966 (print-quoted t)
967 (print-length nil))
968 (write-region
969 (concat
970 ";;; Generated package description from "
971 (replace-regexp-in-string "-pkg\\.el\\'" ".el"
972 (file-name-nondirectory pkg-file))
973 " -*- no-byte-compile: t -*-\n"
974 (prin1-to-string
975 (nconc
976 (list 'define-package
977 (symbol-name name)
978 (package-version-join (package-desc-version pkg-desc))
979 (package-desc-summary pkg-desc)
980 (let ((requires (package-desc-reqs pkg-desc)))
981 (list 'quote
982 ;; Turn version lists into string form.
983 (mapcar
984 (lambda (elt)
985 (list (car elt)
986 (package-version-join (cadr elt))))
987 requires))))
988 (package--alist-to-plist-args
989 (package-desc-extras pkg-desc))))
990 "\n")
991 nil pkg-file nil 'silent))))
992
993;;;###autoload
994(defun package-isolate (packages &optional temp-init)
995 "Start an uncustomized Emacs and only load a set of PACKAGES.
996Interactively, prompt for PACKAGES to load, which should be specified
997separated by commas.
998If called from Lisp, PACKAGES should be a list of packages to load.
999If TEMP-INIT is non-nil, or when invoked with a prefix argument,
1000the Emacs user directory is set to a temporary directory.
1001This command is intended for testing Emacs and/or the packages
1002in a clean environment."
1003 (interactive
1004 (cl-loop for p in (cl-loop for p in (package--alist) append (cdr p))
1005 unless (package-built-in-p p)
1006 collect (cons (package-desc-full-name p) p) into table
1007 finally return
1008 (list
1009 (cl-loop for c in
1010 (completing-read-multiple
1011 "Packages to isolate: " table
1012 nil t)
1013 collect (alist-get c table nil nil #'string=))
1014 current-prefix-arg)))
1015 (let* ((name (concat "package-isolate-"
1016 (mapconcat #'package-desc-full-name packages ",")))
1017 (all-packages (delete-consecutive-dups
1018 (sort (append packages (mapcan #'package--dependencies packages))
1019 (lambda (p0 p1)
1020 (string< (package-desc-name p0) (package-desc-name p1))))))
1021 initial-scratch-message package-load-list)
1022 (with-temp-buffer
1023 (insert ";; This is an isolated testing environment, with these packages enabled:\n\n")
1024 (dolist (package all-packages)
1025 (push (list (package-desc-name package)
1026 (package-version-join (package-desc-version package)))
1027 package-load-list)
1028 (insert ";; - " (package-desc-full-name package))
1029 (unless (memq package packages)
1030 (insert " (dependency)"))
1031 (insert "\n"))
1032 (insert "\n")
1033 (setq initial-scratch-message (buffer-string)))
1034 (apply #'start-process (concat "*" name "*") nil
1035 (list (expand-file-name invocation-name invocation-directory)
1036 "--quick" "--debug-init"
1037 "--init-directory" (if temp-init
1038 (make-temp-file name t)
1039 user-emacs-directory)
1040 (format "--eval=%S"
1041 `(progn
1042 (setq initial-scratch-message ,initial-scratch-message)
1043
1044 (require 'package)
1045 ,@(mapcar
1046 (lambda (dir)
1047 `(add-to-list 'package-directory-list ,dir))
1048 (cons package-user-dir package-directory-list))
1049 (setq package-load-list ',package-load-list)
1050 (package-activate-all)))))))
1051
1052(provide 'package-install)
1053;;; package-install.el ends here
diff --git a/lisp/package/package-menu.el b/lisp/package/package-menu.el
new file mode 100644
index 00000000000..4be14069999
--- /dev/null
+++ b/lisp/package/package-menu.el
@@ -0,0 +1,1580 @@
1;;; package-compile.el --- Byte-Compilation of Packages -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;; Code:
23
24(require 'package-core)
25(require 'package-install)
26(require 'package-vc)
27
28(require 'tabulated-list)
29(require 'browse-url)
30(require 'macroexp)
31(require 'lisp-mnt)
32
33(defgroup package-menu nil
34 "A interface for package management."
35 :group 'package
36 :version "24.1")
37
38(defcustom package-menu-async t
39 "If non-nil, package-menu will use async operations when possible.
40Currently, only the refreshing of archive contents supports
41asynchronous operations. Package transactions are still done
42synchronously."
43 :type 'boolean
44 :version "25.1")
45
46(defcustom package-menu-hide-low-priority 'archive
47 "If non-nil, hide low priority packages from the packages menu.
48A package is considered low priority if there's another version
49of it available such that:
50 (a) the archive of the other package is higher priority than
51 this one, as per `package-archive-priorities';
52 or
53 (b) they both have the same archive priority but the other
54 package has a higher version number.
55
56This variable has three possible values:
57 nil: no packages are hidden;
58 `archive': only criterion (a) is used;
59 t: both criteria are used.
60
61This variable has no effect if `package-menu--hide-packages' is
62nil, so it can be toggled with \\<package-menu-mode-map>\\[package-menu-toggle-hiding]."
63 :type '(choice (const :tag "Don't hide anything" nil)
64 (const :tag "Hide per package-archive-priorities"
65 archive)
66 (const :tag "Hide per archive and version number" t))
67 :version "25.1")
68
69(defcustom package-hidden-regexps nil
70 "List of regexps matching the name of packages to hide.
71If the name of a package matches any of these regexps it is
72omitted from the package menu. To toggle this, type \\[package-menu-toggle-hiding].
73
74Values can be interactively added to this list by typing
75\\[package-menu-hide-package] on a package."
76 :version "25.1"
77 :type '(repeat (regexp :tag "Hide packages with name matching")))
78
79(defcustom package-menu-use-current-if-no-marks t
80 "Whether \\<package-menu-mode-map>\\[package-menu-execute] in package menu operates on current package if none are marked.
81
82If non-nil, and no packages are marked for installation or
83deletion, \\<package-menu-mode-map>\\[package-menu-execute] will operate on the current package at point,
84see `package-menu-execute' for details.
85The default is t. Set to nil to get back the original behavior
86of having `package-menu-execute' signal an error when no packages
87are marked for installation or deletion."
88 :version "29.1"
89 :type 'boolean)
90
91(defcustom package-name-column-width 30
92 "Column width for the Package name in the package menu."
93 :type 'natnum
94 :version "28.1")
95
96(defcustom package-version-column-width 14
97 "Column width for the Package version in the package menu."
98 :type 'natnum
99 :version "28.1")
100
101(defcustom package-status-column-width 12
102 "Column width for the Package status in the package menu."
103 :type 'natnum
104 :version "28.1")
105
106(defcustom package-archive-column-width 8
107 "Column width for the Package archive in the package menu."
108 :type 'natnum
109 :version "28.1")
110
111(defun package-browse-url (desc &optional secondary)
112 "Open the website of the package under point in a browser.
113`browse-url' is used to determine the browser to be used. If
114SECONDARY (interactively, the prefix), use the secondary browser.
115DESC must be a `package-desc' object."
116 (interactive (list (package--query-desc)
117 current-prefix-arg)
118 package-menu-mode)
119 (unless desc
120 (user-error "No package here"))
121 (let ((url (cdr (assoc :url (package-desc-extras desc)))))
122 (unless url
123 (user-error "No website for %s" (package-desc-name desc)))
124 (if secondary
125 (funcall browse-url-secondary-browser-function url)
126 (browse-url url))))
127
128(defun package--imenu-prev-index-position-function ()
129 "Move point to previous line in package-menu buffer.
130This function is used as a value for
131`imenu-prev-index-position-function'."
132 (unless (bobp)
133 (forward-line -1)))
134
135(defun package--imenu-extract-index-name-function ()
136 "Return imenu name for line at point.
137This function is used as a value for
138`imenu-extract-index-name-function'. Point should be at the
139beginning of the line."
140 (let ((package-desc (tabulated-list-get-id)))
141 (format "%s (%s): %s"
142 (package-desc-name package-desc)
143 (package-version-join (package-desc-version package-desc))
144 (package-desc-summary package-desc))))
145
146(defun package-menu--display (remember-pos suffix)
147 "Display the Package Menu.
148If REMEMBER-POS is non-nil, keep point on the same entry.
149
150If SUFFIX is non-nil, append that to \"Package\" for the first
151column in the header line."
152 (setf (car (aref tabulated-list-format 0))
153 (if suffix
154 (concat "Package[" suffix "]")
155 "Package"))
156 (tabulated-list-init-header)
157 (tabulated-list-print remember-pos))
158
159(defun package-menu--generate (remember-pos &optional packages keywords)
160 "Populate and display the Package Menu.
161If REMEMBER-POS is non-nil, keep point on the same entry.
162PACKAGES should be t, which means to display all known packages,
163or a list of package names (symbols) to display.
164
165With KEYWORDS given, only packages with those keywords are
166shown."
167 (package-menu--refresh packages keywords)
168 (package-menu--display remember-pos
169 (when keywords
170 (let ((filters (mapconcat #'identity keywords ",")))
171 (concat "Package[" filters "]")))))
172
173(defun package-menu--print-info (pkg)
174 "Return a package entry suitable for `tabulated-list-entries'.
175PKG has the form (PKG-DESC . STATUS).
176Return (PKG-DESC [NAME VERSION STATUS DOC])."
177 (package-menu--print-info-simple (car pkg)))
178(make-obsolete 'package-menu--print-info
179 'package-menu--print-info-simple "25.1")
180
181
182;;; Package menu faces
183
184(defface package-name
185 '((t :inherit link))
186 "Face used on package names in the package menu."
187 :version "25.1")
188
189(defface package-description
190 '((t :inherit default))
191 "Face used on package description summaries in the package menu."
192 :version "25.1")
193
194;; Shame this hyphenates "built-in", when "font-lock-builtin-face" doesn't.
195(defface package-status-built-in
196 '((t :inherit font-lock-builtin-face))
197 "Face used on the status and version of built-in packages."
198 :version "25.1")
199
200(defface package-status-external
201 '((t :inherit package-status-built-in))
202 "Face used on the status and version of external packages."
203 :version "25.1")
204
205(defface package-status-available
206 '((t :inherit default))
207 "Face used on the status and version of available packages."
208 :version "25.1")
209
210(defface package-status-new
211 '((t :inherit (bold package-status-available)))
212 "Face used on the status and version of new packages."
213 :version "25.1")
214
215(defface package-status-held
216 '((t :inherit font-lock-constant-face))
217 "Face used on the status and version of held packages."
218 :version "25.1")
219
220(defface package-status-disabled
221 '((t :inherit font-lock-warning-face))
222 "Face used on the status and version of disabled packages."
223 :version "25.1")
224
225(defface package-status-installed
226 '((t :inherit font-lock-comment-face))
227 "Face used on the status and version of installed packages."
228 :version "25.1")
229
230(defface package-status-from-source
231 '((t :inherit font-lock-negation-char-face))
232 "Face used on the status and version of installed packages."
233 :version "29.1")
234
235(defface package-status-dependency
236 '((t :inherit package-status-installed))
237 "Face used on the status and version of dependency packages."
238 :version "25.1")
239
240(defface package-status-unsigned
241 '((t :inherit font-lock-warning-face))
242 "Face used on the status and version of unsigned packages."
243 :version "25.1")
244
245(defface package-status-incompat
246 '((t :inherit error))
247 "Face used on the status and version of incompat packages."
248 :version "25.1")
249
250(defface package-status-avail-obso
251 '((t :inherit package-status-incompat))
252 "Face used on the status and version of avail-obso packages."
253 :version "25.1")
254
255(defface package-mark-install-line
256 '((((class color) (background light))
257 :background "darkolivegreen1" :extend t)
258 (((class color) (background dark))
259 :background "seagreen" :extend t)
260 (t :inherit (highlight) :extend t))
261 "Face used for highlighting in package-menu packages marked to be installed."
262 :version "31.1")
263
264(defface package-mark-delete-line
265 '((((class color) (background light))
266 :background "rosybrown1" :extend t)
267 (((class color) (background dark))
268 :background "indianred4" :extend t)
269 (t :inherit (highlight) :extend t))
270 "Face used for highlighting in package-menu packages marked to be deleted."
271 :version "31.1")
272
273(defface package-mode-line-total nil
274 "Face for the total number of packages displayed on the mode line."
275 :version "31.1")
276
277(defface package-mode-line-installed '((t :inherit package-status-installed))
278 "Face for the number of installed packages displayed on the mode line."
279 :version "31.1")
280
281(defface package-mode-line-to-upgrade '((t :inherit bold))
282 "Face for the number of packages to upgrade displayed on the mode line."
283 :version "31.1")
284
285(defface package-mode-line-new '((t :inherit package-status-new))
286 "Face for the number of new packages displayed on the mode line."
287 :version "31.1")
288
289;;; Package menu printing
290
291(defun package-menu--print-info-simple (pkg)
292 "Return a package entry suitable for `tabulated-list-entries'.
293PKG is a `package-desc' object.
294Return (PKG-DESC [NAME VERSION STATUS DOC])."
295 (let* ((status (package-desc-status pkg))
296 (face (pcase status
297 ("built-in" 'package-status-built-in)
298 ("external" 'package-status-external)
299 ("available" 'package-status-available)
300 ("avail-obso" 'package-status-avail-obso)
301 ("new" 'package-status-new)
302 ("held" 'package-status-held)
303 ("disabled" 'package-status-disabled)
304 ("installed" 'package-status-installed)
305 ("source" 'package-status-from-source)
306 ("dependency" 'package-status-dependency)
307 ("unsigned" 'package-status-unsigned)
308 ("incompat" 'package-status-incompat)
309 (_ 'font-lock-warning-face)))) ; obsolete.
310 (list pkg
311 `[(,(symbol-name (package-desc-name pkg))
312 face package-name
313 font-lock-face package-name
314 follow-link t
315 package-desc ,pkg
316 action package-menu-describe-package)
317 ,(propertize
318 (if (package-vc-p pkg)
319 (package-vc-commit pkg)
320 (package-version-join
321 (package-desc-version pkg)))
322 'font-lock-face face)
323 ,(propertize status 'font-lock-face face)
324 ,(propertize (or (package-desc-archive pkg) "")
325 'font-lock-face face)
326 ,(propertize (package-desc-summary pkg)
327 'font-lock-face 'package-description)])))
328
329(defvar package-menu--old-archive-contents nil
330 "`package-archive-contents' before the latest refresh.")
331
332(defun package--ensure-package-menu-mode ()
333 "Signal a user-error if major mode is not `package-menu-mode'."
334 (unless (derived-mode-p 'package-menu-mode)
335 (user-error "The current buffer is not a Package Menu")))
336
337(defvar package-menu--new-package-list nil
338 "List of newly-available packages since `list-packages' was last called.")
339
340(defun package-menu--refresh-contents (&optional _arg _noconfirm)
341 "In Package Menu, download the Emacs Lisp package archive.
342Fetch the contents of each archive specified in
343`package-archives', and then refresh the package menu.
344
345`package-menu-mode' sets `revert-buffer-function' to this
346function. The args ARG and NOCONFIRM, passed from
347`revert-buffer', are ignored."
348 (package--ensure-package-menu-mode)
349 (setq package-menu--old-archive-contents package-archive-contents)
350 (setq package-menu--new-package-list nil)
351 (package-refresh-contents package-menu-async))
352(define-obsolete-function-alias 'package-menu-refresh 'revert-buffer "27.1")
353
354(defun package-menu--overlay-line (face)
355 "Highlight whole line with face FACE."
356 (let ((ov (make-overlay (line-beginning-position)
357 (1+ (line-end-position)))))
358 (overlay-put ov 'pkg-menu-ov t)
359 (overlay-put ov 'evaporate t)
360 (overlay-put ov 'face face)))
361
362(defun package-menu--remove-overlay ()
363 "Remove all overlays done by `package-menu--overlay-line' in current line."
364 (remove-overlays (line-beginning-position)
365 (1+ (line-end-position))
366 'pkg-menu-ov t))
367
368(defun package-menu-hide-package ()
369 "Hide in Package Menu packages that match a regexp.
370Prompt for the regexp to match against package names.
371The default regexp will hide only the package whose name is at point.
372
373The regexp is added to the list in the user option
374`package-hidden-regexps' and saved for future sessions.
375
376To unhide a package, type
377`\\[customize-variable] RET package-hidden-regexps', and then modify
378the regexp such that it no longer matches the package's name.
379
380Type \\[package-menu-toggle-hiding] to toggle package hiding."
381 (declare (interactive-only "change `package-hidden-regexps' instead."))
382 (interactive nil package-menu-mode)
383 (package--ensure-package-menu-mode)
384 (let* ((name (when (derived-mode-p 'package-menu-mode)
385 (concat "\\`" (regexp-quote (symbol-name (package-desc-name
386 (tabulated-list-get-id))))
387 "\\'")))
388 (re (read-string "Hide packages matching regexp: " name)))
389 ;; Test if it is valid.
390 (string-match re "")
391 (push re package-hidden-regexps)
392 (customize-save-variable 'package-hidden-regexps package-hidden-regexps)
393 (package-menu--post-refresh)
394 (let ((hidden
395 (cl-remove-if-not (lambda (e) (string-match re (symbol-name (car e))))
396 package-archive-contents)))
397 (message "Packages to hide: %d. Type `%s' to toggle or `%s' to customize"
398 (length hidden)
399 (substitute-command-keys "\\[package-menu-toggle-hiding]")
400 (substitute-command-keys "\\[customize-variable] RET package-hidden-regexps")))))
401
402
403(defun package-menu-describe-package (&optional button)
404 "Describe the current package.
405The current package is the package at point.
406If optional arg BUTTON is non-nil, describe its associated
407package(s); this is always nil in interactive invocations."
408 (interactive nil package-menu-mode)
409 (let ((pkg-desc (if button (button-get button 'package-desc)
410 (tabulated-list-get-id))))
411 (if pkg-desc
412 (describe-package pkg-desc)
413 (user-error "No package here"))))
414
415;; fixme numeric argument
416(defun package-menu-mark-delete (&optional _num)
417 "Mark the current package for deletion and move to the next line.
418The current package is the package at point."
419 (interactive "p" package-menu-mode)
420 (package--ensure-package-menu-mode)
421 (if (member (package-menu-get-status)
422 '("installed" "source" "dependency" "obsolete" "unsigned"))
423 (progn (package-menu--overlay-line 'package-mark-delete-line)
424 (tabulated-list-put-tag "D" t))
425 (forward-line)))
426
427(defun package-menu-mark-install (&optional _num)
428 "Mark the current package for installation and move to the next line.
429The current package is the package at point."
430 (interactive "p" package-menu-mode)
431 (package--ensure-package-menu-mode)
432 (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency"))
433 (progn (package-menu--overlay-line 'package-mark-install-line)
434 (tabulated-list-put-tag "I" t))
435 (forward-line)))
436
437(defun package-menu-mark-unmark (&optional _num)
438 "Clear any marks on the current package and move to the next line.
439The current package is the package at point."
440 (interactive "p" package-menu-mode)
441 (package--ensure-package-menu-mode)
442 (package-menu--remove-overlay)
443 (tabulated-list-put-tag " " t))
444
445(defun package-menu-backup-unmark ()
446 "Back up one line and clear any marks on that line's package."
447 (interactive nil package-menu-mode)
448 (package--ensure-package-menu-mode)
449 (forward-line -1)
450 (package-menu--remove-overlay)
451 (tabulated-list-put-tag " "))
452
453(defun package-menu-mark-obsolete-for-deletion ()
454 "Mark all obsolete packages for deletion."
455 (interactive nil package-menu-mode)
456 (package--ensure-package-menu-mode)
457 (save-excursion
458 (goto-char (point-min))
459 (while (not (eobp))
460 (if (equal (package-menu-get-status) "obsolete")
461 (progn (package-menu--overlay-line 'package-mark-delete-line)
462 (tabulated-list-put-tag "D" t))
463 (forward-line 1)))))
464
465(defvar package--quick-help-keys
466 '((("mark for installation," . 9)
467 ("mark for deletion," . 9) "unmark," ("execute marked actions" . 1))
468 ("next," "previous")
469 ("Hide-package," "(-toggle-hidden")
470 ("g-refresh-contents," "/-filter," "help")))
471
472(defun package--prettify-quick-help-key (desc)
473 "Prettify DESC to be displayed as a help menu."
474 (if (listp desc)
475 (if (listp (cdr desc))
476 (mapconcat #'package--prettify-quick-help-key desc " ")
477 (let ((place (cdr desc))
478 (out (copy-sequence (car desc))))
479 (add-text-properties place (1+ place)
480 '(face help-key-binding)
481 out)
482 out))
483 (package--prettify-quick-help-key (cons desc 0))))
484
485(defun package-menu-quick-help ()
486 "Show short help for key bindings in `package-menu-mode'.
487You can view the full list of keys with \\[describe-mode]."
488 (interactive nil package-menu-mode)
489 (package--ensure-package-menu-mode)
490 (message (mapconcat #'package--prettify-quick-help-key
491 package--quick-help-keys "\n")))
492
493(defun package-menu-get-status ()
494 "Return status description of package at point in Package Menu."
495 (package--ensure-package-menu-mode)
496 (let* ((id (tabulated-list-get-id))
497 (entry (and id (assoc id tabulated-list-entries))))
498 (if entry
499 (aref (cadr entry) 2)
500 "")))
501
502(defun package-menu--find-upgrades ()
503 "In Package Menu, return an alist of packages that can be upgraded.
504The alist has the same form as `package-alist', namely a list
505of elements of the form (PKG . DESCS), but where DESCS is the `package-desc'
506object corresponding to the newer version."
507 (let (installed available upgrades)
508 ;; Build list of installed/available packages in this buffer.
509 (dolist (entry tabulated-list-entries)
510 ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
511 (let ((pkg-desc (car entry))
512 (status (aref (cadr entry) 2)))
513 (cond ((member status '("installed" "dependency" "unsigned" "external" "built-in"))
514 (push pkg-desc installed))
515 ((member status '("available" "new"))
516 (setq available (package--append-to-alist pkg-desc available))))))
517 ;; Loop through list of installed packages, finding upgrades.
518 (dolist (pkg-desc installed)
519 (let* ((name (package-desc-name pkg-desc))
520 (avail-pkg (cadr (assq name available))))
521 (and avail-pkg
522 (version-list-< (package-desc-priority-version pkg-desc)
523 (package-desc-priority-version avail-pkg))
524 (or (not (package--active-built-in-p pkg-desc))
525 package-install-upgrade-built-in)
526 (push (cons name avail-pkg) upgrades))))
527 upgrades))
528
529(defvar package-menu--mark-upgrades-pending nil
530 "Whether mark-upgrades is waiting for a refresh to finish.")
531
532(defun package-menu--mark-upgrades-1 ()
533 "Mark all upgradable packages in the Package Menu.
534Implementation of `package-menu-mark-upgrades'."
535 (setq package-menu--mark-upgrades-pending nil)
536 (let ((upgrades (package-menu--find-upgrades)))
537 (if (null upgrades)
538 (message "No packages to upgrade")
539 (widen)
540 (save-excursion
541 (goto-char (point-min))
542 (while (not (eobp))
543 (let* ((pkg-desc (tabulated-list-get-id))
544 (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades))))
545 (cond ((null upgrade)
546 (forward-line 1))
547 ((equal pkg-desc upgrade)
548 (package-menu-mark-install))
549 (t
550 (package-menu-mark-delete))))))
551 (message "Packages marked for upgrading: %d"
552 (length upgrades)))))
553
554
555(defun package-menu-mark-upgrades ()
556 "Mark all upgradable packages in the Package Menu.
557For each installed package for which a newer version is available,
558place an (I)nstall flag on the available version and a (D)elete flag
559on the installed version. A subsequent \\[package-menu-execute] command will upgrade
560the marked packages.
561
562If there's an async refresh operation in progress, the flags will
563be placed as part of `package-menu--post-refresh' instead of
564immediately."
565 (interactive nil package-menu-mode)
566 (package--ensure-package-menu-mode)
567 (if (not package--downloads-in-progress)
568 (package-menu--mark-upgrades-1)
569 (setq package-menu--mark-upgrades-pending t)
570 (message "Waiting for refresh to finish...")))
571
572(defun package-menu--list-to-prompt (packages &optional include-dependencies)
573 "Return a string listing PACKAGES that's usable in a prompt.
574PACKAGES is a list of `package-desc' objects.
575Formats the returned string to be usable in a minibuffer
576prompt (see `package-menu--prompt-transaction-p').
577
578If INCLUDE-DEPENDENCIES, also include the number of uninstalled
579dependencies."
580 ;; The case where `package' is empty is handled in
581 ;; `package-menu--prompt-transaction-p' below.
582 (format "%d (%s)%s"
583 (length packages)
584 (mapconcat #'package-desc-full-name packages " ")
585 (let ((deps
586 (seq-remove
587 #'package-installed-p
588 (delete-dups
589 (apply
590 #'nconc
591 (mapcar (lambda (package)
592 (package--dependencies
593 (package-desc-name package)))
594 packages))))))
595 (if (and include-dependencies deps)
596 (if (length= deps 1)
597 (format " plus 1 dependency")
598 (format " plus %d dependencies" (length deps)))
599 ""))))
600
601(defun package-menu--prompt-transaction-p (delete install upgrade)
602 "Prompt the user about DELETE, INSTALL, and UPGRADE.
603DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects.
604Either may be nil, but not all."
605 (y-or-n-p
606 (concat
607 (when delete
608 (format "Packages to delete: %s. "
609 (package-menu--list-to-prompt delete)))
610 (when install
611 (format "Packages to install: %s. "
612 (package-menu--list-to-prompt install t)))
613 (when upgrade
614 (format "Packages to upgrade: %s. "
615 (package-menu--list-to-prompt upgrade)))
616 "Proceed? ")))
617
618
619(defun package-menu--partition-transaction (install delete)
620 "Return an alist describing an INSTALL DELETE transaction.
621Alist contains three entries, upgrade, delete, and install, each
622with a list of package names.
623
624The upgrade entry contains any `package-desc' objects in INSTALL
625whose name coincides with an object in DELETE. The delete and
626the install entries are the same as DELETE and INSTALL with such
627objects removed."
628 (let* ((upg (cl-intersection install delete :key #'package-desc-name))
629 (ins (cl-set-difference install upg :key #'package-desc-name))
630 (del (cl-set-difference delete upg :key #'package-desc-name)))
631 `((delete . ,del) (install . ,ins) (upgrade . ,upg))))
632
633(defvar package-menu--transaction-status nil
634 "Mode-line status of ongoing package transaction.")
635
636(defun package-menu--perform-transaction (install-list delete-list)
637 "Install packages in INSTALL-LIST and delete DELETE-LIST.
638Return nil if there were no errors; non-nil otherwise."
639 (let ((errors nil))
640 (if install-list
641 (let ((status-format (format ":Installing %%d/%d"
642 (length install-list)))
643 (i 0)
644 (package-menu--transaction-status))
645 (dolist (pkg install-list)
646 (setq package-menu--transaction-status
647 (format status-format (incf i)))
648 (force-mode-line-update)
649 (redisplay 'force)
650 ;; Don't mark as selected, `package-menu-execute' already
651 ;; does that.
652 (package-install pkg 'dont-select))))
653 (let ((package-menu--transaction-status ":Deleting"))
654 (force-mode-line-update)
655 (redisplay 'force)
656 (dolist (elt (package--sort-by-dependence delete-list))
657 (condition-case-unless-debug err
658 (let ((inhibit-message (or inhibit-message package-menu-async)))
659 (package-delete elt nil 'nosave))
660 (error
661 (push (package-desc-full-name elt) errors)
662 (message "Error trying to delete `%s': %s"
663 (package-desc-full-name elt)
664 (error-message-string err))))))
665 errors))
666
667(defun package--update-selected-packages (add remove)
668 "Update the `package-selected-packages' list according to ADD and REMOVE.
669ADD and REMOVE must be disjoint lists of package names (or
670`package-desc' objects) to be added and removed to the selected
671packages list, respectively."
672 (dolist (p add)
673 (cl-pushnew (if (package-desc-p p) (package-desc-name p) p)
674 package-selected-packages))
675 (dolist (p remove)
676 (setq package-selected-packages
677 (remove (if (package-desc-p p) (package-desc-name p) p)
678 package-selected-packages)))
679 (when (or add remove)
680 (package--save-selected-packages package-selected-packages)))
681
682(defun package-menu-execute (&optional noquery)
683 "Perform Package Menu actions on marked packages.
684Packages marked for installation are downloaded and installed,
685packages marked for deletion are removed, and packages marked for
686upgrading are downloaded and upgraded.
687
688If no packages are marked, the action taken depends on the state
689of the current package, the one at point. If it's not already
690installed, this command will install the package; if it's installed,
691the command will delete the package.
692
693Optional argument NOQUERY non-nil means do not ask the user to
694confirm the installations/deletions; this is always nil in interactive
695invocations."
696 (interactive nil package-menu-mode)
697 (package--ensure-package-menu-mode)
698 (let (install-list delete-list cmd pkg-desc)
699 (save-excursion
700 (goto-char (point-min))
701 (while (not (eobp))
702 (setq cmd (char-after))
703 (unless (eq cmd ?\s)
704 ;; This is the key PKG-DESC.
705 (setq pkg-desc (tabulated-list-get-id))
706 (cond ((eq cmd ?D)
707 (push pkg-desc delete-list))
708 ((eq cmd ?I)
709 (push pkg-desc install-list))))
710 (forward-line)))
711 ;; Nothing marked.
712 (unless (or delete-list install-list)
713 ;; Not on a package line.
714 (unless (and (tabulated-list-get-id)
715 package-menu-use-current-if-no-marks)
716 (user-error "No operations specified"))
717 (let* ((id (tabulated-list-get-id))
718 (status (package-menu-get-status)))
719 (cond
720 ((member status '("installed"))
721 (push id delete-list))
722 ((member status '("available" "avail-obso" "new" "dependency"))
723 (push id install-list))
724 (t (user-error "No default action available for status: %s"
725 status)))))
726 (let-alist (package-menu--partition-transaction install-list delete-list)
727 (when (or noquery
728 (package-menu--prompt-transaction-p .delete .install .upgrade))
729 (let ((message-template
730 (concat "[ "
731 (when .delete
732 (format "Delete %d " (length .delete)))
733 (when .install
734 (format "Install %d " (length .install)))
735 (when .upgrade
736 (format "Upgrade %d " (length .upgrade)))
737 "]")))
738 (message "Operation %s started" message-template)
739 ;; Packages being upgraded are not marked as selected.
740 (package--update-selected-packages .install .delete)
741 (unless (package-menu--perform-transaction install-list delete-list)
742 ;; If there weren't errors, output data.
743 (if-let* ((removable (package--removable-packages)))
744 (message "Operation finished. Packages that are no longer needed: %d. Type `%s' to remove them"
745 (length removable)
746 (substitute-command-keys "\\[package-autoremove]"))
747 (message "Operation %s finished" message-template))))))))
748
749(defun package-menu--version-predicate (A B)
750 "Predicate to sort \"*Packages*\" buffer by the version column.
751This is used for `tabulated-list-format' in `package-menu-mode'."
752 (let ((vA (or (ignore-error error (version-to-list (aref (cadr A) 1))) '(0)))
753 (vB (or (ignore-error error (version-to-list (aref (cadr B) 1))) '(0))))
754 (if (version-list-= vA vB)
755 (package-menu--name-predicate A B)
756 (version-list-< vA vB))))
757
758(defun package-menu--status-predicate (A B)
759 "Predicate to sort \"*Packages*\" buffer by the status column.
760This is used for `tabulated-list-format' in `package-menu-mode'."
761 (let ((sA (aref (cadr A) 2))
762 (sB (aref (cadr B) 2)))
763 (cond ((string= sA sB)
764 (package-menu--name-predicate A B))
765 ((string= sA "new") t)
766 ((string= sB "new") nil)
767 ((string-prefix-p "avail" sA)
768 (if (string-prefix-p "avail" sB)
769 (package-menu--name-predicate A B)
770 t))
771 ((string-prefix-p "avail" sB) nil)
772 ((string= sA "installed") t)
773 ((string= sB "installed") nil)
774 ((string= sA "dependency") t)
775 ((string= sB "dependency") nil)
776 ((string= sA "source") t)
777 ((string= sB "source") nil)
778 ((string= sA "unsigned") t)
779 ((string= sB "unsigned") nil)
780 ((string= sA "held") t)
781 ((string= sB "held") nil)
782 ((string= sA "external") t)
783 ((string= sB "external") nil)
784 ((string= sA "built-in") t)
785 ((string= sB "built-in") nil)
786 ((string= sA "obsolete") t)
787 ((string= sB "obsolete") nil)
788 ((string= sA "incompat") t)
789 ((string= sB "incompat") nil)
790 (t (string< sA sB)))))
791
792(defun package-menu--description-predicate (A B)
793 "Predicate to sort \"*Packages*\" buffer by the description column.
794This is used for `tabulated-list-format' in `package-menu-mode'."
795 (let ((dA (aref (cadr A) (if (cdr package-archives) 4 3)))
796 (dB (aref (cadr B) (if (cdr package-archives) 4 3))))
797 (if (string= dA dB)
798 (package-menu--name-predicate A B)
799 (string< dA dB))))
800
801(defun package-menu--name-predicate (A B)
802 "Predicate to sort \"*Packages*\" buffer by the name column.
803This is used for `tabulated-list-format' in `package-menu-mode'."
804 (string< (symbol-name (package-desc-name (car A)))
805 (symbol-name (package-desc-name (car B)))))
806
807(defun package-menu--archive-predicate (A B)
808 "Predicate to sort \"*Packages*\" buffer by the archive column.
809This is used for `tabulated-list-format' in `package-menu-mode'."
810 (let ((a (or (package-desc-archive (car A)) ""))
811 (b (or (package-desc-archive (car B)) "")))
812 (if (string= a b)
813 (package-menu--name-predicate A B)
814 (string< a b))))
815
816(defun package-menu--populate-new-package-list ()
817 "Decide which packages are new in `package-archive-contents'.
818Store this list in `package-menu--new-package-list'."
819 ;; Find which packages are new.
820 (when package-menu--old-archive-contents
821 (dolist (elt package-archive-contents)
822 (unless (assq (car elt) package-menu--old-archive-contents)
823 (push (car elt) package-menu--new-package-list)))
824 (setq package-menu--old-archive-contents nil)))
825
826(defun package-menu--find-and-notify-upgrades ()
827 "Notify the user of upgradable packages."
828 (when-let* ((upgrades (package-menu--find-upgrades)))
829 (message "Packages that can be upgraded: %d; type `%s' to mark for upgrading."
830 (length upgrades)
831 (substitute-command-keys "\\[package-menu-mark-upgrades]"))))
832
833
834(defun package-menu--post-refresh ()
835 "Revert \"*Packages*\" buffer and check for new packages and upgrades.
836Do nothing if there's no *Packages* buffer.
837
838This function is called after `package-refresh-contents' and it
839is added to `post-command-hook' by any function which alters the
840package database (`package-install' and `package-delete'). When
841run, it removes itself from `post-command-hook'."
842 (remove-hook 'post-command-hook #'package-menu--post-refresh)
843 (let ((buf (get-buffer "*Packages*")))
844 (when (buffer-live-p buf)
845 (with-current-buffer buf
846 (package-menu--populate-new-package-list)
847 (run-hooks 'tabulated-list-revert-hook)
848 (tabulated-list-print 'remember 'update)))))
849
850(defun package-menu--mark-or-notify-upgrades ()
851 "If there's a *Packages* buffer, check for upgrades and possibly mark them.
852Do nothing if there's no *Packages* buffer. If there are
853upgrades, mark them if `package-menu--mark-upgrades-pending' is
854non-nil, otherwise just notify the user that there are upgrades.
855This function is called after `package-refresh-contents'."
856 (let ((buf (get-buffer "*Packages*")))
857 (when (buffer-live-p buf)
858 (with-current-buffer buf
859 (if package-menu--mark-upgrades-pending
860 (package-menu--mark-upgrades-1)
861 (package-menu--find-and-notify-upgrades))))))
862
863;;;###autoload
864(defun list-packages (&optional no-fetch)
865 "Display a list of packages.
866This first fetches the updated list of packages before
867displaying, unless a prefix argument NO-FETCH is specified.
868The list is displayed in a buffer named `*Packages*', and
869includes the package's version, availability status, and a
870short description."
871 (interactive "P")
872 (require 'finder-inf nil t)
873 ;; Initialize the package system if necessary.
874 (unless package--initialized
875 (package-initialize t))
876 ;; Integrate the package-menu with updating the archives.
877 (add-hook 'package--post-download-archives-hook
878 #'package-menu--post-refresh)
879 (add-hook 'package--post-download-archives-hook
880 #'package-menu--mark-or-notify-upgrades 'append)
881 (add-hook 'package--post-download-archives-hook
882 #'package-menu--set-mode-line-format 'append)
883
884 ;; Generate the Package Menu.
885 (let ((buf (get-buffer-create "*Packages*")))
886 (with-current-buffer buf
887 ;; Since some packages have their descriptions include non-ASCII
888 ;; characters...
889 (setq buffer-file-coding-system 'utf-8)
890 (package-menu-mode)
891
892 ;; Fetch the remote list of packages.
893 (unless no-fetch (package-menu--refresh-contents))
894
895 ;; If we're not async, this would be redundant.
896 (when package-menu-async
897 (package-menu--generate nil t)))
898 ;; The package menu buffer has keybindings. If the user types
899 ;; `M-x list-packages', that suggests it should become current.
900 (pop-to-buffer-same-window buf)))
901
902;;;###autoload
903(defalias 'package-list-packages 'list-packages)
904
905;; Used in finder.el
906;;;###autoload
907(defun package-show-package-list (&optional packages keywords)
908 "Display PACKAGES in a *Packages* buffer.
909This is similar to `list-packages', but it does not fetch the
910updated list of packages, and it only displays packages with
911names in PACKAGES (which should be a list of symbols).
912
913When KEYWORDS are given, only packages with those KEYWORDS are
914shown."
915 (interactive)
916 (require 'finder-inf nil t)
917 (let* ((buf (get-buffer-create "*Packages*"))
918 (win (get-buffer-window buf)))
919 (with-current-buffer buf
920 (package-menu-mode)
921 (package-menu--generate nil packages keywords))
922 (if win
923 (select-window win)
924 (switch-to-buffer buf))))
925
926(defun package-menu--filter-by (predicate suffix)
927 "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header.
928PREDICATE is a function which will be called with one argument, a
929`package-desc' object, and returns t if that object should be
930listed in the Package Menu.
931
932SUFFIX is passed on to `package-menu--display' and is added to
933the header line of the first column."
934 ;; Update `tabulated-list-entries' so that it contains all
935 ;; packages before searching.
936 (package-menu--refresh t nil)
937 (let (found-entries)
938 (dolist (entry tabulated-list-entries)
939 (when (funcall predicate (car entry))
940 (push entry found-entries)))
941 (if found-entries
942 (progn
943 (setq tabulated-list-entries found-entries)
944 (package-menu--display t suffix))
945 (user-error "No packages found"))))
946
947(defun package-menu-filter-by-archive (archive)
948 "Filter the \"*Packages*\" buffer by ARCHIVE.
949Display only packages from package archive ARCHIVE.
950ARCHIVE can be the name of a single archive (a string), or
951a list of archive names. If ARCHIVE is nil or an empty
952string, show all packages.
953
954When called interactively, prompt for ARCHIVE. To specify
955several archives, type their names separated by commas."
956 (interactive (list (completing-read-multiple
957 "Filter by archive: "
958 (mapcar #'car package-archives)))
959 package-menu-mode)
960 (package--ensure-package-menu-mode)
961 (let ((archives (ensure-list archive)))
962 (package-menu--filter-by
963 (lambda (pkg-desc)
964 (let ((pkg-archive (package-desc-archive pkg-desc)))
965 (or (null archives)
966 (and pkg-archive
967 (member pkg-archive archives)))))
968 (concat "archive:" (string-join archives ",")))))
969
970(defun package-menu-filter-by-description (description)
971 "Filter the \"*Packages*\" buffer by the regexp DESCRIPTION.
972Display only packages whose description matches the regexp
973given as DESCRIPTION.
974
975When called interactively, prompt for DESCRIPTION.
976
977If DESCRIPTION is nil or the empty string, show all packages."
978 (interactive (list (read-regexp "Filter by description (regexp)"))
979 package-menu-mode)
980 (package--ensure-package-menu-mode)
981 (if (or (not description) (string-empty-p description))
982 (package-menu--generate t t)
983 (package-menu--filter-by (lambda (pkg-desc)
984 (string-match description
985 (package-desc-summary pkg-desc)))
986 (format "desc:%s" description))))
987
988(defun package--has-keyword-p (desc &optional keywords)
989 "Test if package DESC has any of the given KEYWORDS.
990When none are given, the package matches."
991 (if keywords
992 (let ((desc-keywords (and desc (package-desc--keywords desc)))
993 found)
994 (while (and (not found) keywords)
995 (let ((k (pop keywords)))
996 (setq found
997 (or (string= k (concat "arc:" (package-desc-archive desc)))
998 (string= k (concat "status:" (package-desc-status desc)))
999 (member k desc-keywords)))))
1000 found)
1001 t))
1002
1003(defun package-all-keywords ()
1004 "Collect all package keywords."
1005 (let ((key-list))
1006 (package--mapc (lambda (desc)
1007 (setq key-list (append (package-desc--keywords desc)
1008 key-list))))
1009 key-list))
1010
1011(defun package-menu-filter-by-keyword (keyword)
1012 "Filter the \"*Packages*\" buffer by KEYWORD.
1013Display only packages whose keywords match the specified KEYWORD.
1014KEYWORD can be a string or a list of strings. If KEYWORD is nil
1015or the empty string, show all packages.
1016
1017In addition to package keywords, KEYWORD can include the name(s)
1018of archive(s) and the package status, such as \"available\"
1019or \"built-in\" or \"obsolete\".
1020
1021When called interactively, prompt for KEYWORD. To specify several
1022keywords, type them separated by commas."
1023 (interactive (list (completing-read-multiple
1024 "Keywords: "
1025 (package-all-keywords)))
1026 package-menu-mode)
1027 (package--ensure-package-menu-mode)
1028 (when (stringp keyword)
1029 (setq keyword (list keyword)))
1030 (if (not keyword)
1031 (package-menu--generate t t)
1032 (package-menu--filter-by (lambda (pkg-desc)
1033 (package--has-keyword-p pkg-desc keyword))
1034 (concat "keyword:" (string-join keyword ",")))))
1035
1036(define-obsolete-function-alias
1037 'package-menu-filter #'package-menu-filter-by-keyword "27.1")
1038
1039(defun package-menu-filter-by-name-or-description (name-or-description)
1040 "Filter the \"*Packages*\" buffer by the regexp NAME-OR-DESCRIPTION.
1041Display only packages whose name or description matches the regexp
1042NAME-OR-DESCRIPTION.
1043
1044When called interactively, prompt for NAME-OR-DESCRIPTION.
1045
1046If NAME-OR-DESCRIPTION is nil or the empty string, show all
1047packages."
1048 (interactive (list (read-regexp "Filter by name or description (regexp)"))
1049 package-menu-mode)
1050 (package--ensure-package-menu-mode)
1051 (if (or (not name-or-description) (string-empty-p name-or-description))
1052 (package-menu--generate t t)
1053 (package-menu--filter-by (lambda (pkg-desc)
1054 (or (string-match name-or-description
1055 (package-desc-summary pkg-desc))
1056 (string-match name-or-description
1057 (symbol-name
1058 (package-desc-name pkg-desc)))))
1059 (format "name-or-desc:%s" name-or-description))))
1060
1061(defun package-menu-filter-by-name (name)
1062 "Filter the \"*Packages*\" buffer by the regexp NAME.
1063Display only packages whose name matches the regexp NAME.
1064
1065When called interactively, prompt for NAME.
1066
1067If NAME is nil or the empty string, show all packages."
1068 (interactive (list (read-regexp "Filter by name (regexp)"))
1069 package-menu-mode)
1070 (package--ensure-package-menu-mode)
1071 (if (or (not name) (string-empty-p name))
1072 (package-menu--generate t t)
1073 (package-menu--filter-by (lambda (pkg-desc)
1074 (string-match-p name (symbol-name
1075 (package-desc-name pkg-desc))))
1076 (format "name:%s" name))))
1077
1078(defun package-menu-filter-by-status (status)
1079 "Filter the \"*Packages*\" buffer by STATUS.
1080Display only packages with specified STATUS.
1081STATUS can be a single status, a string, or a list of strings.
1082If STATUS is nil or the empty string, show all packages.
1083
1084When called interactively, prompt for STATUS. To specify
1085several possible status values, type them separated by commas."
1086 (interactive (list (completing-read "Filter by status: "
1087 '("avail-obso"
1088 "available"
1089 "built-in"
1090 "dependency"
1091 "disabled"
1092 "external"
1093 "held"
1094 "incompat"
1095 "installed"
1096 "source"
1097 "new"
1098 "unsigned")))
1099 package-menu-mode)
1100 (package--ensure-package-menu-mode)
1101 (if (or (not status) (string-empty-p status))
1102 (package-menu--generate t t)
1103 (let ((status-list
1104 (if (listp status)
1105 status
1106 (split-string status ","))))
1107 (package-menu--filter-by
1108 (lambda (pkg-desc)
1109 (member (package-desc-status pkg-desc) status-list))
1110 (format "status:%s" (string-join status-list ","))))))
1111
1112(defun package-menu-filter-by-version (version predicate)
1113 "Filter the \"*Packages*\" buffer by VERSION and PREDICATE.
1114Display only packages whose version satisfies the condition
1115defined by VERSION and PREDICATE.
1116
1117When called interactively, prompt for one of the comparison operators
1118`<', `>' or `=', and for a version. Show only packages whose version
1119is lower (`<'), equal (`=') or higher (`>') than the specified VERSION.
1120
1121When called from Lisp, VERSION should be a version string and
1122PREDICATE should be the symbol `=', `<' or `>'.
1123
1124If VERSION is nil or the empty string, show all packages."
1125 (interactive (let ((choice (intern
1126 (char-to-string
1127 (read-char-choice
1128 "Filter by version? [Type =, <, > or q] "
1129 '(?< ?> ?= ?q))))))
1130 (if (eq choice 'q)
1131 '(quit nil)
1132 (list (read-from-minibuffer
1133 (concat "Filter by version ("
1134 (pcase choice
1135 ('= "= equal to")
1136 ('< "< less than")
1137 ('> "> greater than"))
1138 "): "))
1139 choice)))
1140 package-menu-mode)
1141 (package--ensure-package-menu-mode)
1142 (unless (equal predicate 'quit)
1143 (if (or (not version) (string-empty-p version))
1144 (package-menu--generate t t)
1145 (package-menu--filter-by
1146 (let ((fun (pcase predicate
1147 ('= #'version-list-=)
1148 ('< #'version-list-<)
1149 ('> (lambda (a b) (not (version-list-<= a b))))
1150 (_ (error "Unknown predicate: %s" predicate))))
1151 (ver (version-to-list version)))
1152 (lambda (pkg-desc)
1153 (funcall fun (package-desc-version pkg-desc) ver)))
1154 (format "versions:%s%s" predicate version)))))
1155
1156(defun package-menu-filter-marked ()
1157 "Filter \"*Packages*\" buffer by non-empty mark.
1158Show only the packages that have been marked for installation or deletion.
1159Unlike other filters, this leaves the marks intact."
1160 (interactive nil package-menu-mode)
1161 (package--ensure-package-menu-mode)
1162 (widen)
1163 (let (found-entries mark pkg-id entry marks)
1164 (save-excursion
1165 (goto-char (point-min))
1166 (while (not (eobp))
1167 (setq mark (char-after))
1168 (unless (eq mark ?\s)
1169 (setq pkg-id (tabulated-list-get-id))
1170 (setq entry (package-menu--print-info-simple pkg-id))
1171 (push entry found-entries)
1172 ;; remember the mark
1173 (push (cons pkg-id mark) marks))
1174 (forward-line))
1175 (if found-entries
1176 (progn
1177 (setq tabulated-list-entries found-entries)
1178 (package-menu--display t nil)
1179 ;; redo the marks, but we must remember the marks!!
1180 (goto-char (point-min))
1181 (while (not (eobp))
1182 (setq mark (cdr (assq (tabulated-list-get-id) marks)))
1183 (tabulated-list-put-tag (char-to-string mark) t)))
1184 (user-error "No packages found")))))
1185
1186(defun package-menu-filter-upgradable ()
1187 "Filter \"*Packages*\" buffer to show only upgradable packages."
1188 (interactive nil package-menu-mode)
1189 (let ((pkgs (mapcar #'car (package-menu--find-upgrades))))
1190 (package-menu--filter-by
1191 (lambda (pkg)
1192 (memql (package-desc-name pkg) pkgs))
1193 "upgradable")))
1194
1195(defun package-menu-clear-filter ()
1196 "Clear any filter currently applied to the \"*Packages*\" buffer."
1197 (interactive nil package-menu-mode)
1198 (package--ensure-package-menu-mode)
1199 (package-menu--generate t t))
1200
1201(defun package-list-packages-no-fetch ()
1202 "Display a list of packages.
1203Does not fetch the updated list of packages before displaying.
1204The list is displayed in a buffer named `*Packages*'."
1205 (interactive)
1206 (list-packages t))
1207
1208;;;###autoload
1209(defun package-get-version ()
1210 "Return the version number of the package in which this is used.
1211Assumes it is used from an Elisp file placed inside the top-level directory
1212of an installed ELPA package.
1213The return value is a string (or nil in case we can't find it).
1214It works in more cases if the call is in the file which contains
1215the `Version:' header."
1216 ;; In a sense, this is a lie, but it does just what we want: precomputes
1217 ;; the version at compile time and hardcodes it into the .elc file!
1218 (declare (pure t))
1219 ;; Hack alert!
1220 (let ((file (or (macroexp-file-name) buffer-file-name)))
1221 (cond
1222 ((null file) nil)
1223 ;; Packages are normally installed into directories named "<pkg>-<vers>",
1224 ;; so get the version number from there.
1225 ((string-match "/[^/]+-\\([0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\)/[^/]+\\'" file)
1226 (match-string 1 file))
1227 ;; For packages run straight from the an elpa.git clone, there's no
1228 ;; "-<vers>" in the directory name, so we have to fetch the version
1229 ;; the hard way.
1230 (t
1231 (let* ((pkgdir (file-name-directory file))
1232 (pkgname (file-name-nondirectory (directory-file-name pkgdir)))
1233 (mainfile (expand-file-name (concat pkgname ".el") pkgdir)))
1234 (unless (file-readable-p mainfile) (setq mainfile file))
1235 (when (file-readable-p mainfile)
1236 (lm-package-version mainfile)))))))
1237
1238
1239
1240;;;; Package menu mode.
1241
1242(defvar-keymap package-menu-mode-map
1243 :doc "Local keymap for `package-menu-mode' buffers."
1244 :parent tabulated-list-mode-map
1245 "C-m" #'package-menu-describe-package
1246 "u" #'package-menu-mark-unmark
1247 "DEL" #'package-menu-backup-unmark
1248 "d" #'package-menu-mark-delete
1249 "i" #'package-menu-mark-install
1250 "U" #'package-menu-mark-upgrades
1251 "r" #'revert-buffer
1252 "~" #'package-menu-mark-obsolete-for-deletion
1253 "w" #'package-browse-url
1254 "b" #'package-report-bug
1255 "x" #'package-menu-execute
1256 "h" #'package-menu-quick-help
1257 "H" #'package-menu-hide-package
1258 "?" #'package-menu-describe-package
1259 "(" #'package-menu-toggle-hiding
1260 "/ /" #'package-menu-clear-filter
1261 "/ a" #'package-menu-filter-by-archive
1262 "/ d" #'package-menu-filter-by-description
1263 "/ k" #'package-menu-filter-by-keyword
1264 "/ N" #'package-menu-filter-by-name-or-description
1265 "/ n" #'package-menu-filter-by-name
1266 "/ s" #'package-menu-filter-by-status
1267 "/ v" #'package-menu-filter-by-version
1268 "/ m" #'package-menu-filter-marked
1269 "/ u" #'package-menu-filter-upgradable)
1270
1271(easy-menu-define package-menu-mode-menu package-menu-mode-map
1272 "Menu for `package-menu-mode'."
1273 '("Package"
1274 ["Describe Package" package-menu-describe-package :help "Display information about this package"]
1275 ["Open Package Website" package-browse-url
1276 :help "Open the website of this package"]
1277 ["Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode"]
1278 "--"
1279 ["Refresh Package List" revert-buffer
1280 :help "Redownload the package archive(s)"
1281 :active (not package--downloads-in-progress)]
1282 ["Execute Marked Actions" package-menu-execute :help "Perform all the marked actions"]
1283
1284 "--"
1285 ["Mark All Available Upgrades" package-menu-mark-upgrades
1286 :help "Mark packages that have a newer version for upgrading"
1287 :active (not package--downloads-in-progress)]
1288 ["Mark All Obsolete for Deletion" package-menu-mark-obsolete-for-deletion :help "Mark all obsolete packages for deletion"]
1289 ["Mark for Install" package-menu-mark-install :help "Mark a package for installation and move to the next line"]
1290 ["Mark for Deletion" package-menu-mark-delete :help "Mark a package for deletion and move to the next line"]
1291 ["Unmark" package-menu-mark-unmark :help "Clear any marks on a package and move to the next line"]
1292
1293 "--"
1294 ("Filter Packages"
1295 ["Filter by Archive" package-menu-filter-by-archive
1296 :help
1297 "Prompt for archive(s), display only packages from those archives"]
1298 ["Filter by Description" package-menu-filter-by-description
1299 :help
1300 "Prompt for regexp, display only packages with matching description"]
1301 ["Filter by Keyword" package-menu-filter-by-keyword
1302 :help
1303 "Prompt for keyword(s), display only packages with matching keywords"]
1304 ["Filter by Name" package-menu-filter-by-name
1305 :help
1306 "Prompt for regexp, display only packages whose names match the regexp"]
1307 ["Filter by Name or Description" package-menu-filter-by-name-or-description
1308 :help
1309 "Prompt for regexp, display only packages whose name or description matches"]
1310 ["Filter by Status" package-menu-filter-by-status
1311 :help
1312 "Prompt for status(es), display only packages with those statuses"]
1313 ["Filter by Upgrades available" package-menu-filter-upgradable
1314 :help "Display only installed packages for which upgrades are available"]
1315 ["Filter by Version" package-menu-filter-by-version
1316 :help
1317 "Prompt for version and comparison operator, display only packages of matching versions"]
1318 ["Filter Marked" package-menu-filter-marked
1319 :help "Display only packages marked for installation or deletion"]
1320 ["Clear Filter" package-menu-clear-filter
1321 :help "Clear package list filtering, display the entire list again"])
1322
1323 ["Hide by Regexp" package-menu-hide-package
1324 :help "Toggle visibility of obsolete and unwanted packages"]
1325 ["Display Older Versions" package-menu-toggle-hiding
1326 :style toggle :selected (not package-menu--hide-packages)
1327 :help "Display package even if a newer version is already installed"]
1328
1329 "--"
1330 ["Quit" quit-window :help "Quit package selection"]
1331 ["Customize" (customize-group 'package)]))
1332
1333(defconst package-menu-mode-line-format
1334 '((package-menu-mode-line-info
1335 (:eval (symbol-value 'package-menu-mode-line-info)))))
1336
1337(defvar-local package-menu-mode-line-info nil
1338 "Variable which stores package-menu mode-line format.")
1339
1340(defun package-menu--set-mode-line-format ()
1341 "Display package-menu mode-line."
1342 (when-let* ((buf (get-buffer "*Packages*"))
1343 ((buffer-live-p buf)))
1344 (with-current-buffer buf
1345 (setq package-menu-mode-line-info
1346 (let ((installed 0)
1347 (new 0)
1348 (total (length package-archive-contents))
1349 (to-upgrade (length (package-menu--find-upgrades)))
1350 (total-help "Total number of packages of all package archives")
1351 (installed-help "Total number of packages installed")
1352 (upgrade-help "Total number of packages to upgrade")
1353 (new-help "Total number of packages added recently"))
1354
1355 (save-excursion
1356 (goto-char (point-min))
1357 (while (not (eobp))
1358 (let ((status (package-menu-get-status)))
1359 (cond
1360 ((member status
1361 '("installed" "dependency" "unsigned"))
1362 (setq installed (1+ installed)))
1363 ((equal status "new")
1364 (setq new (1+ new)))))
1365 (forward-line)))
1366
1367 (setq installed (number-to-string installed))
1368 (setq total (number-to-string total))
1369 (setq to-upgrade (number-to-string to-upgrade))
1370
1371 (list
1372 " ["
1373 (propertize "Total: " 'help-echo total-help)
1374 (propertize total
1375 'help-echo total-help
1376 'face 'package-mode-line-total)
1377 " / "
1378 (propertize "Installed: " 'help-echo installed-help)
1379 (propertize installed
1380 'help-echo installed-help
1381 'face 'package-mode-line-installed)
1382 " / "
1383 (propertize "To Upgrade: " 'help-echo upgrade-help)
1384 (propertize to-upgrade
1385 'help-echo upgrade-help
1386 'face 'package-mode-line-to-upgrade)
1387 (when (> new 0)
1388 (concat
1389 " / "
1390 (propertize "New: " 'help-echo new-help)
1391 (propertize (number-to-string new)
1392 'help-echo new-help
1393 'face 'package-mode-line-new)))
1394 "] "))))))
1395(defvar package-menu--tool-bar-map
1396 (let ((map (make-sparse-keymap)))
1397 (tool-bar-local-item-from-menu
1398 #'package-menu-execute "package-menu/execute"
1399 map package-menu-mode-map)
1400 (define-key-after map [separator-1] menu-bar-separator)
1401 (tool-bar-local-item-from-menu
1402 #'package-menu-mark-unmark "package-menu/unmark"
1403 map package-menu-mode-map)
1404 (tool-bar-local-item-from-menu
1405 #'package-menu-mark-install "package-menu/install"
1406 map package-menu-mode-map)
1407 (tool-bar-local-item-from-menu
1408 #'package-menu-mark-delete "package-menu/delete"
1409 map package-menu-mode-map)
1410 (tool-bar-local-item-from-menu
1411 #'package-menu-describe-package "package-menu/info"
1412 map package-menu-mode-map)
1413 (tool-bar-local-item-from-menu
1414 #'package-browse-url "package-menu/url"
1415 map package-menu-mode-map)
1416 (tool-bar-local-item
1417 "package-menu/upgrade" 'package-upgrade-all
1418 'package-upgrade-all
1419 map :help "Upgrade all the packages")
1420 (define-key-after map [separator-2] menu-bar-separator)
1421 (tool-bar-local-item
1422 "search" 'isearch-forward 'search map
1423 :help "Search" :vert-only t)
1424 (tool-bar-local-item-from-menu
1425 #'revert-buffer "refresh"
1426 map package-menu-mode-map)
1427 (tool-bar-local-item-from-menu
1428 #'quit-window "close"
1429 map package-menu-mode-map)
1430 map))
1431
1432(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
1433 "Major mode for browsing a list of packages.
1434The most useful commands here are:
1435
1436 `x': Install the package under point if it isn't already installed,
1437 and delete it if it's already installed,
1438 `i': mark a package for installation, and
1439 `d': mark a package for deletion. Use the `x' command to perform the
1440 actions on the marked files.
1441\\<package-menu-mode-map>
1442\\{package-menu-mode-map}"
1443 :interactive nil
1444 (setq mode-line-process '((package--downloads-in-progress ":Loading")
1445 (package-menu--transaction-status
1446 package-menu--transaction-status)))
1447 (setq-local mode-line-misc-info
1448 (append
1449 mode-line-misc-info
1450 package-menu-mode-line-format))
1451 (setq-local tool-bar-map package-menu--tool-bar-map)
1452 (setq tabulated-list-format
1453 `[("Package" ,package-name-column-width package-menu--name-predicate)
1454 ("Version" ,package-version-column-width package-menu--version-predicate)
1455 ("Status" ,package-status-column-width package-menu--status-predicate)
1456 ("Archive" ,package-archive-column-width package-menu--archive-predicate)
1457 ("Description" 0 package-menu--description-predicate)])
1458 (setq tabulated-list-padding 2)
1459 (setq tabulated-list-sort-key (cons "Status" nil))
1460 (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t)
1461 (tabulated-list-init-header)
1462 (setq revert-buffer-function 'package-menu--refresh-contents)
1463 (setf imenu-prev-index-position-function
1464 #'package--imenu-prev-index-position-function)
1465 (setf imenu-extract-index-name-function
1466 #'package--imenu-extract-index-name-function))
1467
1468(defvar package-menu--hide-packages t
1469 "Whether available obsolete packages should be hidden.
1470Can be toggled with \\<package-menu-mode-map> \\[package-menu-toggle-hiding].
1471Installed obsolete packages are always displayed.")
1472
1473(defun package-menu--refresh (&optional packages keywords)
1474 "Re-populate the `tabulated-list-entries'.
1475PACKAGES should be nil or t, which means to display all known packages.
1476KEYWORDS should be nil or a list of keywords."
1477 ;; Construct list of (PKG-DESC . STATUS).
1478 (unless packages (setq packages t))
1479 (let ((hidden-names (mapconcat #'identity package-hidden-regexps "\\|"))
1480 info-list)
1481 ;; Installed packages:
1482 (dolist (elt package-alist)
1483 (let ((name (car elt)))
1484 (when (or (eq packages t) (memq name packages))
1485 (dolist (pkg (cdr elt))
1486 (when (package--has-keyword-p pkg keywords)
1487 (push pkg info-list))))))
1488
1489 ;; Built-in packages:
1490 (dolist (elt package--builtins)
1491 (let ((pkg (package--from-builtin elt))
1492 (name (car elt)))
1493 (when (not (eq name 'emacs)) ; Hide the `emacs' package.
1494 (when (and (package--has-keyword-p pkg keywords)
1495 (or package-list-unversioned
1496 (package--bi-desc-version (cdr elt)))
1497 (or (eq packages t) (memq name packages)))
1498 (push pkg info-list)))))
1499
1500 ;; Available and disabled packages:
1501 (unless (equal package--old-archive-priorities package-archive-priorities)
1502 (package-read-all-archive-contents))
1503 (dolist (elt package-archive-contents)
1504 (let ((name (car elt)))
1505 ;; To be displayed it must be in PACKAGES;
1506 (when (and (or (eq packages t) (memq name packages))
1507 ;; and we must either not be hiding anything,
1508 (or (not package-menu--hide-packages)
1509 (not package-hidden-regexps)
1510 ;; or just not hiding this specific package.
1511 (not (string-match hidden-names (symbol-name name)))))
1512 ;; Hide available-obsolete or low-priority packages.
1513 (dolist (pkg (package--remove-hidden (cdr elt)))
1514 (when (package--has-keyword-p pkg keywords)
1515 (push pkg info-list))))))
1516
1517 ;; Print the result.
1518 (tabulated-list-init-header)
1519 (setq tabulated-list-entries
1520 (mapcar #'package-menu--print-info-simple info-list))))
1521
1522(defun package--remove-hidden (pkg-list)
1523 "Filter PKG-LIST according to `package-archive-priorities'.
1524PKG-LIST must be a list of `package-desc' objects, all with the
1525same name, sorted by decreasing `package-desc-priority-version'.
1526Return a list of packages tied for the highest priority according
1527to their archives."
1528 (when pkg-list
1529 ;; Variable toggled with `package-menu-toggle-hiding'.
1530 (if (not package-menu--hide-packages)
1531 pkg-list
1532 (let ((installed (cadr (assq (package-desc-name (car pkg-list))
1533 package-alist))))
1534 (when installed
1535 (setq pkg-list
1536 (let ((ins-version (package-desc-version installed)))
1537 (cl-remove-if (lambda (p) (version-list-< (package-desc-version p)
1538 ins-version))
1539 pkg-list))))
1540 (let ((filtered-by-priority
1541 (cond
1542 ((not package-menu-hide-low-priority)
1543 pkg-list)
1544 ((eq package-menu-hide-low-priority 'archive)
1545 (let (max-priority out)
1546 (while pkg-list
1547 (let ((p (pop pkg-list)))
1548 (let ((priority (package-desc-priority p)))
1549 (if (and max-priority (< priority max-priority))
1550 (setq pkg-list nil)
1551 (push p out)
1552 (setq max-priority priority)))))
1553 (nreverse out)))
1554 (pkg-list
1555 (list (car pkg-list))))))
1556 (if (not installed)
1557 filtered-by-priority
1558 (let ((ins-version (package-desc-version installed)))
1559 (cl-remove-if (lambda (p) (or (version-list-= (package-desc-version p)
1560 ins-version)
1561 (package-vc-p installed)))
1562 filtered-by-priority))))))))
1563
1564(defun package-menu-toggle-hiding ()
1565 "In Package Menu, toggle visibility of obsolete available packages.
1566
1567Also hide packages whose name matches a regexp in user option
1568`package-hidden-regexps' (a list). To add regexps to this list,
1569use `package-menu-hide-package'."
1570 (interactive nil package-menu-mode)
1571 (package--ensure-package-menu-mode)
1572 (setq package-menu--hide-packages
1573 (not package-menu--hide-packages))
1574 (if package-menu--hide-packages
1575 (message "Hiding obsolete or unwanted packages")
1576 (message "Displaying all packages"))
1577 (revert-buffer nil 'no-confirm))
1578
1579(provide 'package-menu)
1580;;; package-menu.el ends here
diff --git a/lisp/package/package-misc.el b/lisp/package/package-misc.el
new file mode 100644
index 00000000000..0432ab06f83
--- /dev/null
+++ b/lisp/package/package-misc.el
@@ -0,0 +1,129 @@
1;;; package-misc.el --- Miscellaneous Packaging Functionality -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;;; Code:
23
24(require 'package-core)
25
26(require 'macroexp)
27
28(defun package--print-email-button (recipient)
29 "Insert a button whose action will send an email to RECIPIENT.
30NAME should have the form (FULLNAME . EMAIL) where FULLNAME is
31either a full name or nil, and EMAIL is a valid email address."
32 (when (car recipient)
33 (insert (car recipient)))
34 (when (and (car recipient) (cdr recipient))
35 (insert " "))
36 (when (cdr recipient)
37 (insert "<")
38 (insert-text-button (cdr recipient)
39 'follow-link t
40 'action (lambda (_)
41 (compose-mail
42 (format "%s <%s>" (car recipient) (cdr recipient)))))
43 (insert ">"))
44 (insert "\n"))
45
46(declare-function ietf-drums-parse-address "ietf-drums"
47 (string &optional decode))
48
49(defun package-maintainers (pkg-desc &optional no-error)
50 "Return an email address for the maintainers of PKG-DESC.
51The email address may contain commas, if there are multiple
52maintainers. If no maintainers are found, an error will be
53signaled. If the optional argument NO-ERROR is non-nil no error
54will be signaled in that case."
55 (unless (package-desc-p pkg-desc)
56 (error "Invalid package description: %S" pkg-desc))
57 (let* ((name (package-desc-name pkg-desc))
58 (extras (package-desc-extras pkg-desc))
59 (maint (alist-get :maintainer extras)))
60 (unless (listp (cdr maint))
61 (setq maint (list maint)))
62 (cond
63 ((and (null maint) (null no-error))
64 (user-error "Package `%s' has no explicit maintainer" name))
65 ((and (not (progn
66 (require 'ietf-drums)
67 (ietf-drums-parse-address (cdar maint))))
68 (null no-error))
69 (user-error "Package `%s' has no maintainer address" name))
70 (t
71 (with-temp-buffer
72 (mapc #'package--print-email-button maint)
73 (replace-regexp-in-string
74 "\n" ", " (string-trim
75 (buffer-substring-no-properties
76 (point-min) (point-max)))))))))
77
78;;;###autoload
79(defun package-report-bug (desc)
80 "Prepare a message to send to the maintainers of a package.
81DESC must be a `package-desc' object.
82
83Of interest to package maintainers: By default, the command will use
84`reporter-submit-bug-report' to generate a message buffer. If your
85package has specific needs, you can set the symbol property
86`package-report-bug-function' of the symbol designating your package
87name.
88"
89 (interactive (list (package--query-desc package-alist))
90 package-menu-mode)
91 (let ((maint (package-maintainers desc))
92 (name (symbol-name (package-desc-name desc)))
93 (pkgdir (package-desc-dir desc))
94 vars)
95 (when pkgdir
96 (dolist-with-progress-reporter (group custom-current-group-alist)
97 "Scanning for modified user options..."
98 (when (and (car group)
99 (file-in-directory-p (car group) pkgdir))
100 (dolist (ent (get (cdr group) 'custom-group))
101 (when (and (custom-variable-p (car ent))
102 (boundp (car ent))
103 (not (eq (custom--standard-value (car ent))
104 (default-toplevel-value (car ent)))))
105 (push (car ent) vars))))))
106 (dlet ((reporter-prompt-for-summary-p t))
107 (funcall (or (get name 'package-report-bug-function)
108 #'reporter-submit-bug-report)
109 maint name vars))))
110
111;;;; Inferring package from current buffer
112(defun package-read-from-string (str)
113 "Read a Lisp expression from STR.
114Signal an error if the entire string was not used."
115 (pcase-let ((`(,expr . ,offset) (read-from-string str)))
116 (condition-case ()
117 ;; The call to `ignore' suppresses a compiler warning.
118 (progn (ignore (read-from-string str offset))
119 (error "Can't read whole string"))
120 (end-of-file expr))))
121
122
123(defun package--alist-to-plist-args (alist)
124 (mapcar #'macroexp-quote
125 (apply #'nconc
126 (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))))
127
128(provide 'package-misc)
129;;; package-misc.el ends here
diff --git a/lisp/package/package-quickstart.el b/lisp/package/package-quickstart.el
new file mode 100644
index 00000000000..39e71c6533c
--- /dev/null
+++ b/lisp/package/package-quickstart.el
@@ -0,0 +1,151 @@
1;;; package-quickstart.el --- Accelerating Package Startup -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 Philip Kaludercic
4
5;; Author: Philip Kaludercic <philipk@posteo.net>
6
7;; This program is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program. If not, see <https://www.gnu.org/licenses/>.
19
20;;; Commentary:
21
22;; Activating packages via `package-initialize' is costly: for N installed
23;; packages, it needs to read all N <pkg>-pkg.el files first to decide
24;; which packages to activate, and then again N <pkg>-autoloads.el files.
25;; To speed this up, we precompute a mega-autoloads file which is the
26;; concatenation of all those <pkg>-autoloads.el, so we can activate
27;; all packages by loading this one file (and hence without initializing
28;; package.el).
29
30;; Other than speeding things up, this also offers a bootstrap feature:
31;; it lets us activate packages according to `package-load-list' and
32;; `package-user-dir' even before those vars are set.
33
34;;; Code:
35
36(require 'package-core)
37
38(defcustom package-quickstart nil
39 "Precompute activation actions to speed up startup.
40This requires the use of `package-quickstart-refresh' every time the
41activations need to be changed, such as when `package-load-list' is modified."
42 :type 'boolean
43 :version "27.1"
44 :group 'package)
45
46;;;###autoload
47(defcustom package-quickstart-file
48 (locate-user-emacs-file "package-quickstart.el")
49 "Location of the file used to speed up activation of packages at startup."
50 :type 'file
51 :group 'applications
52 :initialize #'custom-initialize-delay
53 :version "27.1")
54
55(defun package--quickstart-maybe-refresh ()
56 (if package-quickstart
57 ;; FIXME: Delay refresh in case we're installing/deleting
58 ;; several packages!
59 (package-quickstart-refresh)
60 (delete-file (concat package-quickstart-file "c"))
61 (delete-file package-quickstart-file)))
62
63(defvar package--quickstart-dir nil
64 "Set by `package-quickstart-file' to the directory containing it.")
65
66(defun package--quickstart-rel (file)
67 "Return an expr depending on `package--quickstart-dir' which evaluates to FILE.
68
69If FILE is in `package--quickstart-dir', returns an expression that is
70relative to that directory, so if that directory is moved we can still
71find FILE."
72 (if (file-in-directory-p file package--quickstart-dir)
73 `(file-name-concat package--quickstart-dir ,(file-relative-name file package--quickstart-dir))
74 file))
75
76(defun package-quickstart-refresh ()
77 "(Re)Generate the `package-quickstart-file'."
78 (interactive)
79 (package-initialize 'no-activate)
80 (require 'info)
81 (let ((package--quickstart-pkgs ())
82 ;; Pretend we haven't activated anything yet!
83 (package-activated-list ())
84 ;; Make sure we can load this file without load-source-file-function.
85 (coding-system-for-write 'emacs-internal)
86 ;; Ensure that `pp' and `prin1-to-string' calls further down
87 ;; aren't truncated.
88 (print-length nil)
89 (print-level nil)
90 (Info-directory-list '(""))
91 (package--quickstart-dir nil))
92 (dolist (elt package-alist)
93 (condition-case err
94 (package-activate (car elt))
95 ;; Don't let failure of activation of a package arbitrarily stop
96 ;; activation of further packages.
97 (error (message "%s" (error-message-string err)))))
98 (setq package--quickstart-pkgs (nreverse package--quickstart-pkgs))
99 (with-temp-file package-quickstart-file
100 (emacs-lisp-mode) ;For `syntax-ppss'.
101 (insert ";;; Quickstart file to activate all packages at startup -*- lexical-binding:t -*-\n")
102 (insert ";; ¡¡ This file is autogenerated by `package-quickstart-refresh', DO NOT EDIT !!\n\n")
103 (setq package--quickstart-dir
104 (file-name-directory (expand-file-name package-quickstart-file)))
105 (pp '(setq package--quickstart-dir
106 (file-name-directory (expand-file-name load-file-name)))
107 (current-buffer))
108 (dolist (pkg package--quickstart-pkgs)
109 (let* ((file
110 ;; Prefer uncompiled files (and don't accept .so files).
111 (let ((load-suffixes '(".el" ".elc")))
112 (locate-library (package--autoloads-file-name pkg))))
113 (pfile (prin1-to-string (package--quickstart-rel file))))
114 (insert "(let* ((load-file-name " pfile ")\
115\(load-true-file-name load-file-name))\n")
116 (insert-file-contents file)
117 ;; Fixup the special #$ reader form and throw away comments.
118 (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)
119 (unless (ppss-string-terminator (save-match-data (syntax-ppss)))
120 (replace-match (if (match-end 1) "" pfile) t t)))
121 (unless (bolp) (insert "\n"))
122 (insert ")\n")))
123 (pp `(defvar package-activated-list) (current-buffer))
124 (pp `(setq package-activated-list
125 (delete-dups
126 (append ',(mapcar #'package-desc-name package--quickstart-pkgs)
127 package-activated-list)))
128 (current-buffer))
129 (let ((info-dirs
130 (mapcar #'package--quickstart-rel (butlast Info-directory-list))))
131 (when info-dirs
132 (pp `(progn (require 'info)
133 (info-initialize)
134 (setq Info-directory-list
135 (append (list . ,info-dirs) Info-directory-list)))
136 (current-buffer))))
137 ;; Use `\s' instead of a space character, so this code chunk is not
138 ;; mistaken for an actual file-local section of package.el.
139 (insert "
140;; Local\sVariables:
141;; version-control: never
142;; no-update-autoloads: t
143;; byte-compile-warnings: (not make-local)
144;; End:
145"))
146 ;; FIXME: Do it asynchronously in an Emacs subprocess, and
147 ;; don't show the byte-compiler warnings.
148 (byte-compile-file package-quickstart-file)))
149
150(provide 'package-quickstart)
151;;; package-quickstart.el ends here
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/package/package-vc.el
index 7433fce2d89..d40c7efb670 100644
--- a/lisp/emacs-lisp/package-vc.el
+++ b/lisp/package/package-vc.el
@@ -48,7 +48,9 @@
48(eval-when-compile (require 'rx)) 48(eval-when-compile (require 'rx))
49(eval-when-compile (require 'map)) 49(eval-when-compile (require 'map))
50(eval-when-compile (require 'cl-lib)) 50(eval-when-compile (require 'cl-lib))
51(require 'package) 51(require 'package-elpa)
52(require 'package-misc)
53(require 'package-install)
52(require 'lisp-mnt) 54(require 'lisp-mnt)
53(require 'vc) 55(require 'vc)
54(require 'seq) 56(require 'seq)
@@ -485,12 +487,12 @@ documentation and marking the package as installed."
485 (with-temp-buffer 487 (with-temp-buffer
486 (insert-file-contents file) 488 (insert-file-contents file)
487 (when-let* ((require-lines (lm-header-multiline "package-requires"))) 489 (when-let* ((require-lines (lm-header-multiline "package-requires")))
488 (thread-last 490 (setq deps
489 (mapconcat #'identity require-lines " ") 491 (nconc deps
490 package-read-from-string 492 (lm--prepare-package-dependencies
491 lm--prepare-package-dependencies 493 (package-read-from-string
492 (nconc deps) 494 (mapconcat (function identity)
493 (setq deps)))))) 495 require-lines " ")))))))))
494 (dolist (dep deps) 496 (dolist (dep deps)
495 (cl-callf version-to-list (cadr dep))) 497 (cl-callf version-to-list (cadr dep)))
496 (setf (package-desc-reqs pkg-desc) deps) 498 (setf (package-desc-reqs pkg-desc) deps)
@@ -546,7 +548,14 @@ documentation and marking the package as installed."
546 ;; FIXME: Compilation should be done as a separate, optional, step. 548 ;; FIXME: Compilation should be done as a separate, optional, step.
547 ;; E.g. for multi-package installs, we should first install all packages 549 ;; E.g. for multi-package installs, we should first install all packages
548 ;; and then compile them. 550 ;; and then compile them.
549 (package--compile new-desc) 551 (package--compile
552 (if lisp-dir
553 ;; In case we are installing a package from a local
554 ;; checkout, we want to compile the checkout, not the
555 ;; redirection!
556 (package-desc-create :dir lisp-dir)
557 new-desc))
558
550 (when package-native-compile 559 (when package-native-compile
551 (package--native-compile-async new-desc)) 560 (package--native-compile-async new-desc))
552 ;; After compilation, load again any files loaded by 561 ;; After compilation, load again any files loaded by
@@ -933,7 +942,7 @@ interactively), DIR must be an absolute file name."
933 (package-vc--archives-initialize) 942 (package-vc--archives-initialize)
934 (let* ((dir (if interactive dir (expand-file-name dir))) ;avoid double expansion 943 (let* ((dir (if interactive dir (expand-file-name dir))) ;avoid double expansion
935 (name (or name (file-name-base (directory-file-name dir)))) 944 (name (or name (file-name-base (directory-file-name dir))))
936 (pkg-dir (file-name-concat package-user-dir name)) 945 (pkg-dir (expand-file-name name package-user-dir))
937 (package-vc-selected-packages 946 (package-vc-selected-packages
938 (cons (list name :lisp-dir dir) 947 (cons (list name :lisp-dir dir)
939 package-vc-selected-packages))) 948 package-vc-selected-packages)))
diff --git a/lisp/package/package.el b/lisp/package/package.el
new file mode 100644
index 00000000000..5705a01c7da
--- /dev/null
+++ b/lisp/package/package.el
@@ -0,0 +1,151 @@
1;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
2
3;; Copyright (C) 2007-2025 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-install)
147(require 'package-menu)
148(require 'package-describe)
149
150(provide 'package)
151;;; package.el ends here
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-12 04:28:51 +0000