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