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