X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/36a50f38fbbcf5cc0cafc44af9d1bfcd6c13fc25..919281ddb2eec5b5503c246dfad902d44aa25644:/lisp/emacs-lisp/package.el diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 885fb00ce7..b96518df50 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -173,6 +173,8 @@ :group 'applications :version "24.1") + +;;; Customization options ;;;###autoload (defcustom package-enable-at-startup t "Whether to activate installed packages when Emacs starts. @@ -183,7 +185,6 @@ and before `after-init-hook'. Activation is not done if Even if the value is nil, you can type \\[package-initialize] to activate the package system at any time." :type 'boolean - :group 'package :version "24.1") (defcustom package-load-list '(all) @@ -201,15 +202,8 @@ If VERSION is a string, only that version is ever loaded. If VERSION is nil, the package is not loaded (it is \"disabled\")." :type '(repeat symbol) :risky t - :group 'package :version "24.1") -(defvar Info-directory-list) -(declare-function info-initialize "info" ()) -(declare-function url-http-file-exists-p "url-http" (url)) -(declare-function lm-header "lisp-mnt" (header)) -(declare-function lm-commentary "lisp-mnt" (&optional file)) - (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. The default value points to the GNU Emacs package repository. @@ -226,9 +220,31 @@ a package can run arbitrary code." :type '(alist :key-type (string :tag "Archive name") :value-type (string :tag "URL or directory name")) :risky t - :group 'package :version "24.1") +(defcustom package-menu-hide-low-priority 'archive + "If non-nil, hide low priority packages from the packages menu. +A package is considered low priority if there's another version +of it available such that: + (a) the archive of the other package is higher priority than + this one, as per `package-archive-priorities'; + or + (b) they both have the same archive priority but the other + package has a higher version number. + +This variable has three possible values: + nil: no packages are hidden; + archive: only criteria (a) is used; + t: both criteria are used. + +This variable has no effect if `package-menu--hide-obsolete' is +nil, so it can be toggled with \\ \\[package-menu-hide-obsolete]." + :type '(choice (const :tag "Don't hide anything" nil) + (const :tag "Hide per package-archive-priorities" + archive) + (const :tag "Hide per archive and version number" t)) + :version "25.1") + (defcustom package-archive-priorities nil "An alist of priorities for packages. @@ -239,11 +255,12 @@ number from the archive with the highest priority is selected. When higher versions are available from archives with lower priorities, the user has to select those manually. -Archives not in this list have the priority 0." +Archives not in this list have the priority 0. + +See also `package-menu-hide-low-priority'." :type '(alist :key-type (string :tag "Archive name") :value-type (integer :tag "Priority (default is 0)")) :risky t - :group 'package :version "25.1") (defcustom package-pinned-packages nil @@ -267,20 +284,8 @@ the package will be unavailable." ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue ;; if PACKAGE has a known vulnerability that is fixed in newer versions. :risky t - :group 'package :version "24.4") -(defconst package-archive-version 1 - "Version number of the package archive understood by this file. -Lower version numbers than this will probably be understood as well.") - -;; We don't prime the cache since it tends to get out of date. -(defvar package-archive-contents nil - "Cache of the contents of the Emacs Lisp Package Archive. -This is an alist mapping package names (symbols) to -non-empty lists of `package-desc' structures.") -(put 'package-archive-contents 'risky-local-variable t) - (defcustom package-user-dir (locate-user-emacs-file "elpa") "Directory containing the user's Emacs Lisp packages. The directory name should be absolute. @@ -288,7 +293,6 @@ Apart from this directory, Emacs also looks for system-wide packages in `package-directory-list'." :type 'directory :risky t - :group 'package :version "24.1") (defcustom package-directory-list @@ -306,7 +310,6 @@ These directories contain packages intended for system-wide; in contrast, `package-user-dir' contains packages for personal use." :type '(repeat directory) :risky t - :group 'package :version "24.1") (defvar epg-gpg-program) @@ -324,14 +327,12 @@ contents of the archive." (const allow-unsigned :tag "Allow unsigned") (const t :tag "Check always")) :risky t - :group 'package :version "24.4") (defcustom package-unsigned-archives nil "List of archives where we do not check for package signatures." :type '(repeat (string :tag "Archive name")) :risky t - :group 'package :version "24.4") (defcustom package-selected-packages nil @@ -340,14 +341,29 @@ This variable is fed automatically by Emacs when installing a new package. This variable is used by `package-autoremove' to decide which packages are no longer needed. You can use it to (re)install packages on other machines -by running `package-user-selected-packages-install'. +by running `package-install-selected-packages'. To check if a package is contained in this list here, use `package--user-selected-p', as it may populate the variable with a sane initial value." - :group 'package :type '(repeat symbol)) +(defcustom package-menu-async t + "If non-nil, package-menu will use async operations when possible. +Currently, only the refreshing of archive contents supports +asynchronous operations. Package transactions are still done +synchronously." + :type 'boolean + :version "25.1") + + +;;; `package-desc' object definition +;; This is the struct used internally to represent packages. +;; Functions that deal with packages should generally take this object +;; as an argument. In some situations (e.g. commands that query the +;; user) it makes sense to take the package name as a symbol instead, +;; but keep in mind there could be multiple `package-desc's with the +;; same name. (defvar package--default-summary "No description available.") (cl-defstruct (package-desc @@ -419,7 +435,43 @@ Slots: extras signed) +(defun package--from-builtin (bi-desc) + (package-desc-create :name (pop bi-desc) + :version (package--bi-desc-version bi-desc) + :summary (package--bi-desc-summary bi-desc) + :dir 'builtin)) + ;; Pseudo fields. +(defun package-version-join (vlist) + "Return the version string corresponding to the list VLIST. +This is, approximately, the inverse of `version-to-list'. +\(Actually, it returns only one of the possible inverses, since +`version-to-list' is a many-to-one operation.)" + (if (null vlist) + "" + (let ((str-list (list "." (int-to-string (car vlist))))) + (dolist (num (cdr vlist)) + (cond + ((>= num 0) + (push (int-to-string num) str-list) + (push "." str-list)) + ((< num -4) + (error "Invalid version list `%s'" vlist)) + (t + ;; pre, or beta, or alpha + (cond ((equal "." (car str-list)) + (pop str-list)) + ((not (string-match "[0-9]+" (car str-list))) + (error "Invalid version list `%s'" vlist))) + (push (cond ((= num -1) "pre") + ((= num -2) "beta") + ((= num -3) "alpha") + ((= num -4) "snapshot")) + str-list)))) + (if (equal "." (car str-list)) + (pop str-list)) + (apply 'concat (nreverse str-list))))) + (defun package-desc-full-name (pkg-desc) (format "%s-%s" (package-desc-name pkg-desc) @@ -438,6 +490,10 @@ Slots: (nth 1 keywords) keywords))) +(defun package-desc-priority (p) + "Return the priority of the archive of package-desc object P." + (package-archive-priority (package-desc-archive p))) + ;; Package descriptor format used in finder-inf.el and package--builtins. (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) @@ -446,6 +502,13 @@ Slots: reqs summary) + +;;; Installed packages +;; The following variables store information about packages present in +;; the system. The most important of these is `package-alist'. The +;; command `package-initialize' is also closely related to this +;; section, but it is left for a later section because it also affects +;; other stuff. (defvar package--builtins nil "Alist of built-in packages. The actual value is initialized by loading the library @@ -467,53 +530,33 @@ called via `package-initialize'. To change which packages are loaded and/or activated, customize `package-load-list'.") (put 'package-alist 'risky-local-variable t) -(defvar package--compatibility-table nil - "Hash table connecting package names to their compatibility. -Each key is a symbol, the name of a package. - -The value is either nil, representing an incompatible package, or -a version list, representing the highest compatible version of -that package which is available. - -A package is considered incompatible if it requires an Emacs -version higher than the one being used. To check for package -\(in)compatibility, don't read this table directly, use -`package--incompatible-p' which also checks dependencies.") - (defvar package-activated-list nil ;; FIXME: This should implicitly include all builtin packages. "List of the names of currently activated packages.") (put 'package-activated-list 'risky-local-variable t) -(defun package-version-join (vlist) - "Return the version string corresponding to the list VLIST. -This is, approximately, the inverse of `version-to-list'. -\(Actually, it returns only one of the possible inverses, since -`version-to-list' is a many-to-one operation.)" - (if (null vlist) - "" - (let ((str-list (list "." (int-to-string (car vlist))))) - (dolist (num (cdr vlist)) - (cond - ((>= num 0) - (push (int-to-string num) str-list) - (push "." str-list)) - ((< num -4) - (error "Invalid version list `%s'" vlist)) - (t - ;; pre, or beta, or alpha - (cond ((equal "." (car str-list)) - (pop str-list)) - ((not (string-match "[0-9]+" (car str-list))) - (error "Invalid version list `%s'" vlist))) - (push (cond ((= num -1) "pre") - ((= num -2) "beta") - ((= num -3) "alpha") - ((= num -4) "snapshot")) - str-list)))) - (if (equal "." (car str-list)) - (pop str-list)) - (apply 'concat (nreverse str-list))))) +;;;; Populating `package-alist'. +;; The following functions are called on each installed package by +;; `package-load-all-descriptors', which ultimately populates the +;; `package-alist' variable. +(defun package-process-define-package (exp) + (when (eq (car-safe exp) 'define-package) + (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) + (name (package-desc-name new-pkg-desc)) + (version (package-desc-version new-pkg-desc)) + (old-pkgs (assq name package-alist))) + (if (null old-pkgs) + ;; If there's no old package, just add this to `package-alist'. + (push (list name new-pkg-desc) package-alist) + ;; If there is, insert the new package at the right place in the list. + (while + (if (and (cdr old-pkgs) + (version-list-< version + (package-desc-version (cadr old-pkgs)))) + (setq old-pkgs (cdr old-pkgs)) + (push new-pkg-desc (cdr old-pkgs)) + nil))) + new-pkg-desc))) (defun package-load-descriptor (pkg-dir) "Load the description file in directory PKG-DIR." @@ -524,8 +567,9 @@ This is, approximately, the inverse of `version-to-list'. (with-temp-buffer (insert-file-contents pkg-file) (goto-char (point-min)) - (let ((pkg-desc (package-process-define-package - (read (current-buffer)) pkg-file))) + (let ((pkg-desc (or (package-process-define-package + (read (current-buffer))) + (error "Can't find define-package in %s" pkg-file)))) (setf (package-desc-dir pkg-desc) pkg-dir) (if (file-exists-p signed-file) (setf (package-desc-signed pkg-desc) t)) @@ -547,6 +591,24 @@ updates `package-alist'." (when (file-directory-p pkg-dir) (package-load-descriptor pkg-dir))))))) +(defun define-package (_name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) + "Define a new package. +NAME-STRING is the name of the package, as a string. +VERSION-STRING is the version of the package, as a string. +DOCSTRING is a short description of the package, a string. +REQUIREMENTS is a list of dependencies on other packages. + Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), + where OTHER-VERSION is a string. + +EXTRA-PROPERTIES is currently unused." + ;; FIXME: Placeholder! Should we keep it? + (error "Don't call me!")) + + +;;; Package activation +;; Section for functions used by `package-activate', which see. (defun package-disabled-p (pkg-name version) "Return whether PKG-NAME at VERSION can be activated. The decision is made according to `package-load-list'. @@ -562,6 +624,23 @@ Return the max version (as a string) if the package is held at a lower version." force)) (t (error "Invalid element in `package-load-list'"))))) +(defun package-built-in-p (package &optional min-version) + "Return true if PACKAGE is built-in to Emacs. +Optional arg MIN-VERSION, if non-nil, should be a version list +specifying the minimum acceptable version." + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) + +(defvar Info-directory-list) +(declare-function info-initialize "info" ()) + (defun package-activate-1 (pkg-desc &optional reload) "Activate package given by PKG-DESC, even if it was already active. If RELOAD is non-nil, also `load' any files inside the package which @@ -606,6 +685,7 @@ correspond to previously loaded files (those returned by t)) (declare-function find-library-name "find-func" (library)) + (defun package--list-loaded-files (dir) "Recursively list all files in DIR which correspond to loaded features. Returns the `file-name-sans-extension' of each file, relative to @@ -640,33 +720,14 @@ DIR, sorted by most recently loaded last." ;; Sort the files by ascending HISTORY-POSITION. (lambda (x y) (< (cdr x) (cdr y)))))))) -(defun package-built-in-p (package &optional min-version) - "Return true if PACKAGE is built-in to Emacs. -Optional arg MIN-VERSION, if non-nil, should be a version list -specifying the minimum acceptable version." - (if (package-desc-p package) ;; was built-in and then was converted - (eq 'builtin (package-desc-dir package)) - (let ((bi (assq package package--builtin-versions))) - (cond - (bi (version-list-<= min-version (cdr bi))) - ((remove 0 min-version) nil) - (t - (require 'finder-inf nil t) ; For `package--builtins'. - (assq package package--builtins)))))) - -(defun package--from-builtin (bi-desc) - (package-desc-create :name (pop bi-desc) - :version (package--bi-desc-version bi-desc) - :summary (package--bi-desc-summary bi-desc) - :dir 'builtin)) - -;; This function goes ahead and activates a newer version of a package -;; if an older one was already activated. This is not ideal; we'd at -;; least need to check to see if the package has actually been loaded, -;; and not merely activated. +;;;; `package-activate' +;; This function activates a newer version of a package if an older +;; one was already activated. It also loads a features of this +;; package which were already loaded. (defun package-activate (package &optional force) "Activate package PACKAGE. -If FORCE is true, (re-)activate it if it's already activated." +If FORCE is true, (re-)activate it if it's already activated. +Newer versions are always activated, regardless of FORCE." (let ((pkg-descs (cdr (assq package package-alist)))) ;; Check if PACKAGE is available in `package-alist'. (while @@ -698,76 +759,14 @@ Required package `%s-%s' is unavailable" ;; If all goes well, activate the package itself. (package-activate-1 pkg-vec force))))))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &rest _extra-properties) - "Define a new package. -NAME-STRING is the name of the package, as a string. -VERSION-STRING is the version of the package, as a string. -DOCSTRING is a short description of the package, a string. -REQUIREMENTS is a list of dependencies on other packages. - Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION), - where OTHER-VERSION is a string. - -EXTRA-PROPERTIES is currently unused." - ;; FIXME: Placeholder! Should we keep it? - (error "Don't call me!")) - -(defun package-process-define-package (exp origin) - (unless (eq (car-safe exp) 'define-package) - (error "Can't find define-package in %s" origin)) - (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp))) - (name (package-desc-name new-pkg-desc)) - (version (package-desc-version new-pkg-desc)) - (old-pkgs (assq name package-alist))) - (if (null old-pkgs) - ;; If there's no old package, just add this to `package-alist'. - (push (list name new-pkg-desc) package-alist) - ;; If there is, insert the new package at the right place in the list. - (while - (if (and (cdr old-pkgs) - (version-list-< version - (package-desc-version (cadr old-pkgs)))) - (setq old-pkgs (cdr old-pkgs)) - (push new-pkg-desc (cdr old-pkgs)) - nil))) - new-pkg-desc)) - -;; From Emacs 22, but changed so it adds to load-path. -(defun package-autoload-ensure-default-file (file) - "Make sure that the autoload file FILE exists and if not create it." - (unless (file-exists-p file) - (write-region - (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\n" - ";;\n" - ";;; Code:\n" - "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" - " \n;; Local Variables:\n" - ";; version-control: never\n" - ";; no-byte-compile: t\n" - ";; no-update-autoloads: t\n" - ";; End:\n" - ";;; " (file-name-nondirectory file) - " ends here\n") - nil file nil 'silent)) - file) - -(defvar generated-autoload-file) -(defvar version-control) - -(defun package-generate-autoloads (name pkg-dir) - (let* ((auto-name (format "%s-autoloads.el" name)) - ;;(ignore-name (concat name "-pkg.el")) - (generated-autoload-file (expand-file-name auto-name pkg-dir)) - (backup-inhibited t) - (version-control 'never)) - (package-autoload-ensure-default-file generated-autoload-file) - (update-directory-autoloads pkg-dir) - (let ((buf (find-buffer-visiting generated-autoload-file))) - (when buf (kill-buffer buf))) - auto-name)) + +;;; Installation -- Local operations +;; This section contains a variety of features regarding installing a +;; package to/from disk. This includes autoload generation, +;; unpacking, compiling, as well as defining a package from the +;; current buffer. +;;;; Unpacking (defvar tar-parse-info) (declare-function tar-untar-buffer "tar-mode" ()) (declare-function tar-header-name "tar-mode" (tar-header) t) @@ -792,34 +791,6 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-generate-description-file (pkg-desc pkg-file) - "Create the foo-pkg.el file for single-file packages." - (let* ((name (package-desc-name pkg-desc))) - (let ((print-level nil) - (print-quoted t) - (print-length nil)) - (write-region - (concat - ";;; -*- no-byte-compile: t -*-\n" - (prin1-to-string - (nconc - (list 'define-package - (symbol-name name) - (package-version-join (package-desc-version pkg-desc)) - (package-desc-summary pkg-desc) - (let ((requires (package-desc-reqs pkg-desc))) - (list 'quote - ;; Turn version lists into string form. - (mapcar - (lambda (elt) - (list (car elt) - (package-version-join (cadr elt)))) - requires)))) - (package--alist-to-plist-args - (package-desc-extras pkg-desc)))) - "\n") - nil pkg-file nil 'silent)))) - (defun package--alist-to-plist-args (alist) (mapcar 'macroexp-quote (apply #'nconc @@ -866,26 +837,265 @@ untar into a directory named DIR; otherwise, signal an error." (package-activate name 'force) pkg-dir)) -(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) - "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." - (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) - (let ((desc-file (expand-file-name (package--description-file pkg-dir) - pkg-dir))) - (unless (file-exists-p desc-file) - (package-generate-description-file pkg-desc desc-file))) - ;; FIXME: Create foo.info and dir file from foo.texi? - ) - -(defun package--compile (pkg-desc) - "Byte-compile installed package PKG-DESC." - (package-activate-1 pkg-desc) - (byte-recompile-directory (package-desc-dir pkg-desc) 0 t)) - -(defun package--write-file-no-coding (file-name) - (let ((buffer-file-coding-system 'no-conversion)) - (write-region (point-min) (point-max) file-name nil 'silent))) - -(defmacro package--with-work-buffer (location file &rest body) +(defun package-generate-description-file (pkg-desc pkg-file) + "Create the foo-pkg.el file for single-file packages." + (let* ((name (package-desc-name pkg-desc))) + (let ((print-level nil) + (print-quoted t) + (print-length nil)) + (write-region + (concat + ";;; -*- no-byte-compile: t -*-\n" + (prin1-to-string + (nconc + (list 'define-package + (symbol-name name) + (package-version-join (package-desc-version pkg-desc)) + (package-desc-summary pkg-desc) + (let ((requires (package-desc-reqs pkg-desc))) + (list 'quote + ;; Turn version lists into string form. + (mapcar + (lambda (elt) + (list (car elt) + (package-version-join (cadr elt)))) + requires)))) + (package--alist-to-plist-args + (package-desc-extras pkg-desc)))) + "\n") + nil pkg-file nil 'silent)))) + +;;;; Autoload +;; From Emacs 22, but changed so it adds to load-path. +(defun package-autoload-ensure-default-file (file) + "Make sure that the autoload file FILE exists and if not create it." + (unless (file-exists-p file) + (write-region + (concat ";;; " (file-name-nondirectory file) + " --- automatically extracted autoloads\n" + ";;\n" + ";;; Code:\n" + "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n" + " \n;; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" + ";; no-update-autoloads: t\n" + ";; End:\n" + ";;; " (file-name-nondirectory file) + " ends here\n") + nil file nil 'silent)) + file) + +(defvar generated-autoload-file) +(defvar version-control) + +(defun package-generate-autoloads (name pkg-dir) + (let* ((auto-name (format "%s-autoloads.el" name)) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) + ;; Silence `autoload-generate-file-autoloads'. + (noninteractive inhibit-message) + (backup-inhibited t) + (version-control 'never)) + (package-autoload-ensure-default-file generated-autoload-file) + (update-directory-autoloads pkg-dir) + (let ((buf (find-buffer-visiting generated-autoload-file))) + (when buf (kill-buffer buf))) + auto-name)) + +(defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) + "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." + (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) + (let ((desc-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) + (unless (file-exists-p desc-file) + (package-generate-description-file pkg-desc desc-file))) + ;; FIXME: Create foo.info and dir file from foo.texi? + ) + +;;;; Compilation +(defvar warning-minimum-level) +(defun package--compile (pkg-desc) + "Byte-compile installed package PKG-DESC." + (let ((warning-minimum-level :error) + (save-silently inhibit-message)) + (package-activate-1 pkg-desc) + (byte-recompile-directory (package-desc-dir pkg-desc) 0 t))) + +;;;; Inferring package from current buffer +(defun package-read-from-string (str) + "Read a Lisp expression from STR. +Signal an error if the entire string was not used." + (let* ((read-data (read-from-string str)) + (more-left + (condition-case nil + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string + (substring str (cdr read-data)))) + t) + (end-of-file nil)))) + (if more-left + (error "Can't read whole string") + (car read-data)))) + +(defun package--prepare-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + +(declare-function lm-header "lisp-mnt" (header)) +(declare-function lm-homepage "lisp-mnt" (&optional file)) + +(defun package-buffer-info () + "Return a `package-desc' describing the package in the current buffer. + +If the buffer does not contain a conforming package, signal an +error. If there is a package, narrow the buffer to the file's +boundaries." + (goto-char (point-min)) + (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) + (error "Package lacks a file header")) + (let ((file-name (match-string-no-properties 1)) + (desc (match-string-no-properties 2)) + (start (line-beginning-position))) + (unless (search-forward (concat ";;; " file-name ".el ends here")) + (error "Package lacks a terminating comment")) + ;; Try to include a trailing newline. + (forward-line) + (narrow-to-region start (point)) + (require 'lisp-mnt) + ;; Use some headers we've invented to drive the process. + (let* ((requires-str (lm-header "package-requires")) + ;; Prefer Package-Version; if defined, the package author + ;; probably wants us to use it. Otherwise try Version. + (pkg-version + (or (package-strip-rcs-id (lm-header "package-version")) + (package-strip-rcs-id (lm-header "version")))) + (homepage (lm-homepage))) + (unless pkg-version + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) + (package-desc-from-define + file-name pkg-version desc + (if requires-str + (package--prepare-dependencies + (package-read-from-string requires-str))) + :kind 'single + :url homepage)))) + +(defun package--read-pkg-desc (kind) + "Read a `define-package' form in current buffer. +Return the pkg-desc, with desc-kind set to KIND." + (goto-char (point-min)) + (unwind-protect + (let* ((pkg-def-parsed (read (current-buffer))) + (pkg-desc + (when (eq (car pkg-def-parsed) 'define-package) + (apply #'package-desc-from-define + (append (cdr pkg-def-parsed)))))) + (when pkg-desc + (setf (package-desc-kind pkg-desc) kind) + pkg-desc)))) + +(declare-function tar-get-file-descriptor "tar-mode" (file)) +(declare-function tar--extract "tar-mode" (descriptor)) + +(defun package-tar-file-info () + "Find package information for a tar file. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'tar-mode)) + (let* ((dir-name (file-name-directory + (tar-header-name (car tar-parse-info)))) + (desc-file (package--description-file dir-name)) + (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) + (unless tar-desc + (error "No package descriptor file found")) + (with-current-buffer (tar--extract tar-desc) + (unwind-protect + (or (package--read-pkg-desc 'tar) + (error "Can't find define-package in %s" + (tar-header-name tar-desc))) + (kill-buffer (current-buffer)))))) + +(defun package-dir-info () + "Find package information for a directory. +The return result is a `package-desc'." + (cl-assert (derived-mode-p 'dired-mode)) + (let* ((desc-file (package--description-file default-directory))) + (if (file-readable-p desc-file) + (with-temp-buffer + (insert-file-contents desc-file) + (package--read-pkg-desc 'dir)) + (let ((files (directory-files default-directory t "\\.el\\'" t)) + info) + (while files + (with-temp-buffer + (insert-file-contents (pop files)) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))) + ;; and return the info. + info)))) + + +;;; Communicating with Archives +;; Set of low-level functions for communicating with archives and +;; signature checking. +(defun package--write-file-no-coding (file-name) + (let ((buffer-file-coding-system 'no-conversion)) + (write-region (point-min) (point-max) file-name nil 'silent))) + +(declare-function url-http-file-exists-p "url-http" (url)) + +(defun package--archive-file-exists-p (location file) + (let ((http (string-match "\\`https?:" location))) + (if http + (progn + (require 'url-http) + (url-http-file-exists-p (concat location file))) + (file-exists-p (expand-file-name file location))))) + +(declare-function epg-make-context "epg" + (&optional protocol armor textmode include-certs + cipher-algorithm + digest-algorithm + compress-algorithm)) +(declare-function epg-verify-string "epg" (context signature + &optional signed-text)) +(declare-function epg-context-result-for "epg" (context name)) +(declare-function epg-signature-status "epg" (signature) t) +(declare-function epg-signature-to-string "epg" (signature)) + +(defun package--display-verify-error (context sig-file) + (unless (equal (epg-context-error-output context) "") + (with-output-to-temp-buffer "*Error*" + (with-current-buffer standard-output + (if (epg-context-result-for context 'verify) + (insert (format "Failed to verify signature %s:\n" sig-file) + (mapconcat #'epg-signature-to-string + (epg-context-result-for context 'verify) + "\n")) + (insert (format "Error while verifying signature %s:\n" sig-file))) + (insert "\nCommand output:\n" (epg-context-error-output context)))))) + +(defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. LOCATION is the base location of a package archive, and should be one of the URLs (or file names) specified in `package-archives'. @@ -900,132 +1110,401 @@ buffer is killed afterwards. Return the last value in BODY." (url-insert-file-contents (concat ,location ,file)) (unless (file-name-absolute-p ,location) (error "Archive location %s is not an absolute file name" - ,location)) + ,location)) (insert-file-contents (expand-file-name ,file ,location))) ,@body)) -(defun package--archive-file-exists-p (location file) - (let ((http (string-match "\\`https?:" location))) - (if http - (progn - (require 'url-http) - (url-http-file-exists-p (concat location file))) - (file-exists-p (expand-file-name file location))))) +(defmacro package--with-work-buffer-async (location file async &rest body) + "Run BODY in a buffer containing the contents of FILE at LOCATION. +If ASYNC is non-nil, and if it is possible, run BODY +asynchronously. If an error is encountered and ASYNC is a +function, call it with no arguments (instead of executing BODY), +otherwise propagate the error. For description of the other +arguments see `package--with-work-buffer'." + (declare (indent 3) (debug t)) + (macroexp-let2* macroexp-copyable-p + ((async-1 async) + (file-1 file) + (location-1 location)) + `(if (or (not ,async-1) + (not (string-match-p "\\`https?:" ,location-1))) + (package--with-work-buffer ,location-1 ,file-1 ,@body) + (url-retrieve (concat ,location-1 ,file-1) + (lambda (status) + (if (eq (car status) :error) + (if (functionp ,async-1) + (funcall ,async-1) + (signal (cdar status) (cddr status))) + (goto-char (point-min)) + (unless (search-forward "\n\n" nil 'noerror) + (error "Invalid url response in buffer %s" + (current-buffer))) + (delete-region (point-min) (point)) + ,@body) + (kill-buffer (current-buffer))) + nil + 'silent)))) + +(defun package--check-signature-content (content string &optional sig-file) + "Check signature CONTENT against STRING. +SIG-FILE is the name of the signature file, used when signaling +errors." + (let* ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (setf (epg-context-home-directory context) homedir) + (condition-case error + (epg-verify-string context content string) + (error (package--display-verify-error context sig-file) + (signal (car error) (cdr error)))) + (let (good-signatures had-fatal-error) + ;; The .sig file may contain multiple signatures. Success if one + ;; of the signatures is good. + (dolist (sig (epg-context-result-for context 'verify)) + (if (eq (epg-signature-status sig) 'good) + (push sig good-signatures) + ;; If package-check-signature is allow-unsigned, don't + ;; signal error when we can't verify signature because of + ;; missing public key. Other errors are still treated as + ;; fatal (bug#17625). + (unless (and (eq package-check-signature 'allow-unsigned) + (eq (epg-signature-status sig) 'no-pubkey)) + (setq had-fatal-error t)))) + (when (and (null good-signatures) had-fatal-error) + (package--display-verify-error context sig-file) + (error "Failed to verify signature %s" sig-file)) + good-signatures))) + +(defun package--check-signature (location file &optional string async callback) + "Check signature of the current buffer. +Download the signature file from LOCATION by appending \".sig\" +to FILE. +GnuPG keyring is located under \"gnupg\" in `package-user-dir'. +STRING is the string to verify, it defaults to `buffer-string'. +If ASYNC is non-nil, the download of the signature file is +done asynchronously. + +If the signature is verified and CALLBACK was provided, CALLBACK +is `funcall'ed with the list of good signatures as argument (the +list can be empty). If the signatures file is not found, +CALLBACK is called with no arguments." + (let ((sig-file (concat file ".sig")) + (string (or string (buffer-string)))) + (condition-case nil + (package--with-work-buffer-async + location sig-file (when async (or callback t)) + (let ((sig (package--check-signature-content + (buffer-string) string sig-file))) + (when callback (funcall callback sig)) + sig)) + (file-error (funcall callback))))) + + +;;; Packages on Archives +;; The following variables store information about packages available +;; from archives. The most important of these is +;; `package-archive-contents' which is initially populated by the +;; function `package-read-all-archive-contents' from a cache on disk. +;; The `package-initialize' command is also closely related to this +;; section, but it has its own section. +(defconst package-archive-version 1 + "Version number of the package archive understood by this file. +Lower version numbers than this will probably be understood as well.") + +;; We don't prime the cache since it tends to get out of date. +(defvar package-archive-contents nil + "Cache of the contents of the Emacs Lisp Package Archive. +This is an alist mapping package names (symbols) to +non-empty lists of `package-desc' structures.") +(put 'package-archive-contents 'risky-local-variable t) + +(defvar package--compatibility-table nil + "Hash table connecting package names to their compatibility. +Each key is a symbol, the name of a package. + +The value is either nil, representing an incompatible package, or +a version list, representing the highest compatible version of +that package which is available. + +A package is considered incompatible if it requires an Emacs +version higher than the one being used. To check for package +\(in)compatibility, don't read this table directly, use +`package--incompatible-p' which also checks dependencies.") + +(defun package--build-compatibility-table () + "Build `package--compatibility-table' with `package--mapc'." + ;; Initialize the list of built-ins. + (require 'finder-inf nil t) + ;; Build compat table. + (setq package--compatibility-table (make-hash-table :test 'eq)) + (package--mapc #'package--add-to-compatibility-table)) + +(defun package--add-to-compatibility-table (pkg) + "If PKG is compatible (without dependencies), add to the compatibility table. +PKG is a package-desc object. +Only adds if its version is higher than what's already stored in +the table." + (unless (package--incompatible-p pkg 'shallow) + (let* ((name (package-desc-name pkg)) + (version (or (package-desc-version pkg) '(0))) + (table-version (gethash name package--compatibility-table))) + (when (or (not table-version) + (version-list-< table-version version)) + (puthash name version package--compatibility-table))))) + +;; Package descriptor objects used inside the "archive-contents" file. +;; Changing this defstruct implies changing the format of the +;; "archive-contents" files. +(cl-defstruct (package--ac-desc + (:constructor package-make-ac-desc (version reqs summary kind extras)) + (:copier nil) + (:type vector)) + version reqs summary kind extras) + +(defun package--append-to-alist (pkg-desc alist) + "Append an entry for PKG-DESC to the start of ALIST and return it. +This entry takes the form (`package-desc-name' PKG-DESC). + +If ALIST already has an entry with this name, destructively add +PKG-DESC to the cdr of this entry instead, sorted by version +number." + (let* ((name (package-desc-name pkg-desc)) + (priority-version (package-desc-priority-version pkg-desc)) + (existing-packages (assq name alist))) + (if (not existing-packages) + (cons (list name pkg-desc) + alist) + (while (if (and (cdr existing-packages) + (version-list-< priority-version + (package-desc-priority-version + (cadr existing-packages)))) + (setq existing-packages (cdr existing-packages)) + (push pkg-desc (cdr existing-packages)) + nil)) + alist))) + +(defun package--add-to-archive-contents (package archive) + "Add the PACKAGE from the given ARCHIVE if necessary. +PACKAGE should have the form (NAME . PACKAGE--AC-DESC). +Also, add the originating archive to the `package-desc' structure." + (let* ((name (car package)) + (version (package--ac-desc-version (cdr package))) + (pkg-desc + (package-desc-create + :name name + :version version + :reqs (package--ac-desc-reqs (cdr package)) + :summary (package--ac-desc-summary (cdr package)) + :kind (package--ac-desc-kind (cdr package)) + :archive archive + :extras (and (> (length (cdr package)) 4) + ;; Older archive-contents files have only 4 + ;; elements here. + (package--ac-desc-extras (cdr package))))) + (pinned-to-archive (assoc name package-pinned-packages))) + ;; Skip entirely if pinned to another archive. + (when (not (and pinned-to-archive + (not (equal (cdr pinned-to-archive) archive)))) + (setq package-archive-contents + (package--append-to-alist pkg-desc package-archive-contents))))) + +(defun package--read-archive-file (file) + "Re-read archive file FILE, if it exists. +Will return the data from the file, or nil if the file does not exist. +Will throw an error if the archive version is too new." + (let ((filename (expand-file-name file package-user-dir))) + (when (file-exists-p filename) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + (insert-file-contents filename)) + (let ((contents (read (current-buffer)))) + (if (> (car contents) package-archive-version) + (error "Package archive version %d is higher than %d" + (car contents) package-archive-version)) + (cdr contents)))))) + +(defun package-read-archive-contents (archive) + "Re-read archive contents for ARCHIVE. +If successful, set the variable `package-archive-contents'. +If the archive version is too new, signal an error." + ;; Version 1 of 'archive-contents' is identical to our internal + ;; representation. + (let* ((contents-file (format "archives/%s/archive-contents" archive)) + (contents (package--read-archive-file contents-file))) + (when contents + (dolist (package contents) + (package--add-to-archive-contents package archive))))) + +(defun package-read-all-archive-contents () + "Re-read `archive-contents', if it exists. +If successful, set `package-archive-contents'." + (setq package-archive-contents nil) + (dolist (archive package-archives) + (package-read-archive-contents (car archive)))) -(declare-function epg-make-context "epg" - (&optional protocol armor textmode include-certs - cipher-algorithm - digest-algorithm - compress-algorithm)) -(declare-function epg-verify-string "epg" (context signature - &optional signed-text)) -(declare-function epg-context-result-for "epg" (context name)) -(declare-function epg-signature-status "epg" (signature)) -(declare-function epg-signature-to-string "epg" (signature)) +;;;; Package Initialize +;; A bit of a milestone. This brings together some of the above +;; sections and populates all relevant lists of packages from contents +;; available on disk. +(defvar package--initialized nil) -(defun package--display-verify-error (context sig-file) - (unless (equal (epg-context-error-output context) "") - (with-output-to-temp-buffer "*Error*" - (with-current-buffer standard-output - (if (epg-context-result-for context 'verify) - (insert (format "Failed to verify signature %s:\n" sig-file) - (mapconcat #'epg-signature-to-string - (epg-context-result-for context 'verify) - "\n")) - (insert (format "Error while verifying signature %s:\n" sig-file))) - (insert "\nCommand output:\n" (epg-context-error-output context)))))) +(defvar package--init-file-ensured nil + "Whether we know the init file has package-initialize.") -(defun package--check-signature (location file) - "Check signature of the current buffer. -GnuPG keyring is located under \"gnupg\" in `package-user-dir'." - (let* ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir)) - (sig-file (concat file ".sig")) - (sig-content (package--with-work-buffer location sig-file - (buffer-string)))) - (setf (epg-context-home-directory context) homedir) - (condition-case error - (epg-verify-string context sig-content (buffer-string)) - (error - (package--display-verify-error context sig-file) - (signal (car error) (cdr error)))) - (let (good-signatures had-fatal-error) - ;; The .sig file may contain multiple signatures. Success if one - ;; of the signatures is good. - (dolist (sig (epg-context-result-for context 'verify)) - (if (eq (epg-signature-status sig) 'good) - (push sig good-signatures) - ;; If package-check-signature is allow-unsigned, don't - ;; signal error when we can't verify signature because of - ;; missing public key. Other errors are still treated as - ;; fatal (bug#17625). - (unless (and (eq package-check-signature 'allow-unsigned) - (eq (epg-signature-status sig) 'no-pubkey)) - (setq had-fatal-error t)))) - (when (and (null good-signatures) had-fatal-error) - (package--display-verify-error context sig-file) - (error "Failed to verify signature %s" sig-file)) - good-signatures))) +;;;###autoload +(defun package-initialize (&optional no-activate) + "Load Emacs Lisp packages, and activate them. +The variable `package-load-list' controls which packages to load. +If optional arg NO-ACTIVATE is non-nil, don't activate packages. +If `user-init-file' does not mention `(package-initialize)', add +it to the file." + (interactive) + (setq package-alist nil) + (if (equal user-init-file load-file-name) + ;; If `package-initialize' is being called as part of loading + ;; the init file, it's obvious we don't need to ensure-init. + (setq package--init-file-ensured t) + (package--ensure-init-file)) + (package-load-all-descriptors) + (package-read-all-archive-contents) + (unless no-activate + (dolist (elt package-alist) + (package-activate (car elt)))) + (setq package--initialized t) + ;; This uses `package--mapc' so it must be called after + ;; `package--initialized' is t. + (package--build-compatibility-table)) -(defun package-install-from-archive (pkg-desc) - "Download and install a tar package." - ;; This won't happen, unless the archive is doing something wrong. - (when (eq (package-desc-kind pkg-desc) 'dir) - (error "Can't install directory package from archive")) - (let* ((location (package-archive-base pkg-desc)) - (file (concat (package-desc-full-name pkg-desc) - (package-desc-suffix pkg-desc))) - (sig-file (concat file ".sig")) - good-signatures pkg-descs) - (package--with-work-buffer location file - (if (and package-check-signature - (not (member (package-desc-archive pkg-desc) - package-unsigned-archives))) - (if (package--archive-file-exists-p location sig-file) - (setq good-signatures (package--check-signature location file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned package: `%s'" - (package-desc-name pkg-desc))))) - (package-unpack pkg-desc)) - ;; Here the package has been installed successfully, mark it as - ;; signed if appropriate. - (when good-signatures - ;; Write out good signatures into NAME-VERSION.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name - (concat (package-desc-full-name pkg-desc) - ".signed") - package-user-dir) - nil 'silent) - ;; Update the old pkg-desc which will be shown on the description buffer. - (setf (package-desc-signed pkg-desc) t) - ;; Update the new (activated) pkg-desc as well. - (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist))) - (if pkg-descs - (setf (package-desc-signed (car pkg-descs)) t))))) + +;;;; Populating `package-archive-contents' from archives +;; This subsection populates the variables listed above from the +;; actual archives, instead of from a local cache. +(defvar package--downloads-in-progress nil + "List of in-progress asynchronous downloads.") -(defvar package--initialized nil) +(declare-function epg-check-configuration "epg-config" + (config &optional minimum-version)) +(declare-function epg-configuration "epg-config" ()) +(declare-function epg-import-keys-from-file "epg" (context keys)) -(defun package-installed-p (package &optional min-version) - "Return true if PACKAGE, of MIN-VERSION or newer, is installed. -If PACKAGE is a symbol, it is the package name and MIN-VERSION -should be a version list. +;;;###autoload +(defun package-import-keyring (&optional file) + "Import keys from FILE." + (interactive "fFile: ") + (setq file (expand-file-name file)) + (let ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir))) + (with-file-modes 448 + (make-directory homedir t)) + (setf (epg-context-home-directory context) homedir) + (message "Importing %s..." (file-name-nondirectory file)) + (epg-import-keys-from-file context file) + (message "Importing %s...done" (file-name-nondirectory file)))) -If PACKAGE is a package-desc object, MIN-VERSION is ignored." - (unless package--initialized (error "package.el is not yet initialized!")) - (if (package-desc-p package) - (let ((dir (package-desc-dir package))) - (and (stringp dir) - (file-exists-p dir))) - (or - (let ((pkg-descs (cdr (assq package package-alist)))) - (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) - ;; Also check built-in packages. - (package-built-in-p package min-version)))) +(defvar package--post-download-archives-hook nil + "Hook run after the archive contents are downloaded. +Don't run this hook directly. It is meant to be run as part of +`package--update-downloads-in-progress'.") +(put 'package--post-download-archives-hook 'risky-local-variable t) + +(defun package--update-downloads-in-progress (entry) + "Remove ENTRY from `package--downloads-in-progress'. +Once it's empty, run `package--post-download-archives-hook'." + ;; Keep track of the downloading progress. + (setq package--downloads-in-progress + (remove entry package--downloads-in-progress)) + ;; If this was the last download, run the hook. + (unless package--downloads-in-progress + (package-read-all-archive-contents) + (package--build-compatibility-table) + ;; We message before running the hook, so the hook can give + ;; messages as well. + (message "Package refresh done") + (run-hooks 'package--post-download-archives-hook))) + +(defun package--download-one-archive (archive file &optional async) + "Retrieve an archive file FILE from ARCHIVE, and cache it. +ARCHIVE should be a cons cell of the form (NAME . LOCATION), +similar to an entry in `package-alist'. Save the cached copy to +\"archives/NAME/FILE\" in `package-user-dir'." + (package--with-work-buffer-async (cdr archive) file async + (let* ((location (cdr archive)) + (name (car archive)) + (content (buffer-string)) + (dir (expand-file-name (format "archives/%s" name) package-user-dir)) + (local-file (expand-file-name file dir))) + (when (listp (read-from-string content)) + (make-directory dir t) + (if (or (not package-check-signature) + (member archive package-unsigned-archives)) + ;; If we don't care about the signature, save the file and + ;; we're done. + (progn (write-region content nil local-file nil 'silent) + (package--update-downloads-in-progress archive)) + ;; If we care, check it (perhaps async) and *then* write the file. + (package--check-signature + location file content async + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (package--update-downloads-in-progress archive) + (error "Unsigned archive `%s'" name)) + ;; Write out the archives file. + (write-region content nil local-file nil 'silent) + ;; Write out good signatures into archive-contents.signed file. + (when good-sigs + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil (concat local-file ".signed") nil 'silent)) + (package--update-downloads-in-progress archive)))))))) + +(defun package--download-and-read-archives (&optional async) + "Download descriptions of all `package-archives' and read them. +This populates `package-archive-contents'. If ASYNC is non-nil, +perform the downloads asynchronously." + ;; The downloaded archive contents will be read as part of + ;; `package--update-downloads-in-progress'. + (dolist (archive package-archives) + (cl-pushnew archive package--downloads-in-progress + :test #'equal)) + (dolist (archive package-archives) + (condition-case-unless-debug nil + (package--download-one-archive + archive "archive-contents" + ;; Called if the async download fails + (when async + (lambda () (package--update-downloads-in-progress archive)))) + (error (message "Failed to download `%s' archive." + (car archive)))))) + +;;;###autoload +(defun package-refresh-contents (&optional async) + "Download descriptions of all configured ELPA packages. +For each archive configured in the variable `package-archives', +inform Emacs about the latest versions of all packages it offers, +and make them available for download. +Optional argument ASYNC specifies whether to perform the +downloads in the background." + (interactive) + (unless (file-exists-p package-user-dir) + (make-directory package-user-dir t)) + (let ((default-keyring (expand-file-name "package-keyring.gpg" + data-directory)) + (inhibit-message async)) + (when (and package-check-signature (file-exists-p default-keyring)) + (condition-case-unless-debug error + (progn + (epg-check-configuration (epg-configuration)) + (package-import-keyring default-keyring)) + (error (message "Cannot import default keyring: %S" (cdr error)))))) + (package--download-and-read-archives async)) + +;;; Dependency Management +;; Calculating the full transaction necessary for an installation, +;; keeping track of which packages were installed strictly as +;; dependencies, and determining which packages cannot be removed +;; because they are dependencies. (defun package-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. PACKAGES should be a list of `package-desc'. @@ -1109,120 +1588,196 @@ but version %s required" (cons found seen)))))))) packages) -(defun package-read-from-string (str) - "Read a Lisp expression from STR. -Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) +(defun package--find-non-dependencies () + "Return a list of installed packages which are not dependencies. +Finds all packages in `package-alist' which are not dependencies +of any other packages. +Used to populate `package-selected-packages'." + (let ((dep-list + (delete-dups + (apply #'append + (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) + package-alist))))) + (cl-loop for p in package-alist + for name = (car p) + unless (memq name dep-list) + collect name))) -(defun package--read-archive-file (file) - "Re-read archive file FILE, if it exists. -Will return the data from the file, or nil if the file does not exist. -Will throw an error if the archive version is too new." - (let ((filename (expand-file-name file package-user-dir))) - (when (file-exists-p filename) - (with-temp-buffer - (insert-file-contents-literally filename) - (let ((contents (read (current-buffer)))) - (if (> (car contents) package-archive-version) - (error "Package archive version %d is higher than %d" - (car contents) package-archive-version)) - (cdr contents)))))) +(defun package--save-selected-packages (value) + "Set and save `package-selected-packages' to VALUE." + (let ((save-silently inhibit-message)) + (customize-save-variable + 'package-selected-packages + (setq package-selected-packages value)))) -(defun package-read-all-archive-contents () - "Re-read `archive-contents', if it exists. -If successful, set `package-archive-contents'." - (setq package-archive-contents nil) - (dolist (archive package-archives) - (package-read-archive-contents (car archive)))) +(defun package--user-selected-p (pkg) + "Return non-nil if PKG is a package was installed by the user. +PKG is a package name. +This looks into `package-selected-packages', populating it first +if it is still empty." + (unless (consp package-selected-packages) + (package--save-selected-packages (package--find-non-dependencies))) + (memq pkg package-selected-packages)) -(defun package-read-archive-contents (archive) - "Re-read archive contents for ARCHIVE. -If successful, set the variable `package-archive-contents'. -If the archive version is too new, signal an error." - ;; Version 1 of 'archive-contents' is identical to our internal - ;; representation. - (let* ((contents-file (format "archives/%s/archive-contents" archive)) - (contents (package--read-archive-file contents-file))) - (when contents - (dolist (package contents) - (package--add-to-archive-contents package archive))))) +(defun package--get-deps (pkg &optional only) + (let* ((pkg-desc (cadr (assq pkg package-alist))) + (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) + for name = (car p) + when (assq name package-alist) + collect name)) + (indirect-deps (unless (eq only 'direct) + (delete-dups + (cl-loop for p in direct-deps + append (package--get-deps p)))))) + (cl-case only + (direct direct-deps) + (separate (list direct-deps indirect-deps)) + (indirect indirect-deps) + (t (delete-dups (append direct-deps indirect-deps)))))) -;; Package descriptor objects used inside the "archive-contents" file. -;; Changing this defstruct implies changing the format of the -;; "archive-contents" files. -(cl-defstruct (package--ac-desc - (:constructor package-make-ac-desc (version reqs summary kind extras)) - (:copier nil) - (:type vector)) - version reqs summary kind extras) +(defun package--removable-packages () + "Return a list of names of packages no longer needed. +These are packages which are neither contained in +`package-selected-packages' nor a dependency of one that is." + (let ((needed (cl-loop for p in package-selected-packages + if (assq p package-alist) + ;; `p' and its dependencies are needed. + append (cons p (package--get-deps p))))) + (cl-loop for p in (mapcar #'car package-alist) + unless (memq p needed) + collect p))) + +(defun package--used-elsewhere-p (pkg-desc &optional pkg-list all) + "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. +Return the first package found in PKG-LIST of which PKG is a +dependency. If ALL is non-nil, return all such packages instead. + +When not specified, PKG-LIST defaults to `package-alist' +with PKG-DESC entry removed." + (unless (string= (package-desc-status pkg-desc) "obsolete") + (let* ((pkg (package-desc-name pkg-desc)) + (alist (or pkg-list + (remove (assq pkg package-alist) + package-alist)))) + (if all + (cl-loop for p in alist + if (assq pkg (package-desc-reqs (cadr p))) + collect (cadr p)) + (cl-loop for p in alist thereis + (and (assq pkg (package-desc-reqs (cadr p))) + (cadr p))))))) + +(defun package--sort-deps-in-alist (package only) + "Return a list of dependencies for PACKAGE sorted by dependency. +PACKAGE is included as the first element of the returned list. +ONLY is an alist associating package names to package objects. +Only these packages will be in the return value an their cdrs are +destructively set to nil in ONLY." + (let ((out)) + (dolist (dep (package-desc-reqs package)) + (when-let ((cell (assq (car dep) only)) + (dep-package (cdr-safe cell))) + (setcdr cell nil) + (setq out (append (package--sort-deps-in-alist dep-package only) + out)))) + (cons package out))) + +(defun package--sort-by-dependence (package-list) + "Return PACKAGE-LIST sorted by dependence. +That is, any element of the returned list is guaranteed to not +directly depend on any elements that come before it. -(defun package--add-to-archive-contents (package archive) - "Add the PACKAGE from the given ARCHIVE if necessary. -PACKAGE should have the form (NAME . PACKAGE--AC-DESC). -Also, add the originating archive to the `package-desc' structure." - (let* ((name (car package)) - (version (package--ac-desc-version (cdr package))) - (pkg-desc - (package-desc-create - :name name - :version version - :reqs (package--ac-desc-reqs (cdr package)) - :summary (package--ac-desc-summary (cdr package)) - :kind (package--ac-desc-kind (cdr package)) - :archive archive - :extras (and (> (length (cdr package)) 4) - ;; Older archive-contents files have only 4 - ;; elements here. - (package--ac-desc-extras (cdr package))))) - (pinned-to-archive (assoc name package-pinned-packages))) - ;; Skip entirely if pinned to another archive. - (when (not (and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive)))) - (setq package-archive-contents - (package--append-to-alist pkg-desc package-archive-contents))))) +PACKAGE-LIST is a list of package-desc objects. +Indirect dependencies are guaranteed to be returned in order only +if all the in-between dependencies are also in PACKAGE-LIST." + (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) + out-list) + (dolist (cell alist out-list) + ;; `package--sort-deps-in-alist' destructively changes alist, so + ;; some cells might already be empty. We check this here. + (when-let ((pkg-desc (cdr cell))) + (setcdr cell nil) + (setq out-list + (append (package--sort-deps-in-alist pkg-desc alist) + out-list)))))) -(defun package--append-to-alist (pkg-desc alist) - "Append an entry for PKG-DESC to the start of ALIST and return it. -This entry takes the form (`package-desc-name' PKG-DESC). + +;;; Installation Functions +;; As opposed to the previous section (which listed some underlying +;; functions necessary for installation), this one contains the actual +;; functions that install packages. The package itself can be +;; installed in a variety of ways (archives, buffer, file), but +;; requirements (dependencies) are always satisfied by looking in +;; `package-archive-contents'. +(defun package-archive-base (desc) + "Return the archive containing the package NAME." + (cdr (assoc (package-desc-archive desc) package-archives))) -If ALIST already has an entry with this name, destructively add -PKG-DESC to the cdr of this entry instead, sorted by version -number." - (let* ((name (package-desc-name pkg-desc)) - (priority-version (package-desc-priority-version pkg-desc)) - (existing-packages (assq name alist))) - (if (not existing-packages) - (cons (list name pkg-desc) - alist) - (while (if (and (cdr existing-packages) - (version-list-< priority-version - (package-desc-priority-version - (cadr existing-packages)))) - (setq existing-packages (cdr existing-packages)) - (push pkg-desc (cdr existing-packages)) - nil)) - alist))) +(defun package-install-from-archive (pkg-desc) + "Download and install a tar package." + ;; This won't happen, unless the archive is doing something wrong. + (when (eq (package-desc-kind pkg-desc) 'dir) + (error "Can't install directory package from archive")) + (let* ((location (package-archive-base pkg-desc)) + (file (concat (package-desc-full-name pkg-desc) + (package-desc-suffix pkg-desc)))) + (package--with-work-buffer location file + (if (or (not package-check-signature) + (member (package-desc-archive pkg-desc) + package-unsigned-archives)) + ;; If we don't care about the signature, unpack and we're + ;; done. + (let ((save-silently t)) + (package-unpack pkg-desc)) + ;; If we care, check it and *then* write the file. + (let ((content (buffer-string))) + (package--check-signature + location file content nil + ;; This function will be called after signature checking. + (lambda (&optional good-sigs) + (unless (or good-sigs (eq package-check-signature 'allow-unsigned)) + ;; Even if the sig fails, this download is done, so + ;; remove it from the in-progress list. + (error "Unsigned package: `%s'" + (package-desc-name pkg-desc))) + ;; Signature checked, unpack now. + (with-temp-buffer (insert content) + (let ((save-silently t)) + (package-unpack pkg-desc))) + ;; Here the package has been installed successfully, mark it as + ;; signed if appropriate. + (when good-sigs + ;; Write out good signatures into NAME-VERSION.signed file. + (write-region (mapconcat #'epg-signature-to-string good-sigs "\n") + nil + (expand-file-name + (concat (package-desc-full-name pkg-desc) ".signed") + package-user-dir) + nil 'silent) + ;; Update the old pkg-desc which will be shown on the description buffer. + (setf (package-desc-signed pkg-desc) t) + ;; Update the new (activated) pkg-desc as well. + (when-let ((pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))) + (setf (package-desc-signed (car pkg-descs)) t)))))))))) -(defun package--user-selected-p (pkg) - "Return non-nil if PKG is a package was installed by the user. -PKG is a package name. -This looks into `package-selected-packages', populating it first -if it is still empty." - (unless (consp package-selected-packages) - (customize-save-variable - 'package-selected-packages - (setq package-selected-packages (package--find-non-dependencies)))) - (memq pkg package-selected-packages)) +(defun package-installed-p (package &optional min-version) + "Return true if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a package-desc object, MIN-VERSION is ignored." + (unless package--initialized (error "package.el is not yet initialized!")) + (if (package-desc-p package) + (let ((dir (package-desc-dir package))) + (and (stringp dir) + (file-exists-p dir))) + (or + (let ((pkg-descs (cdr (assq package package-alist)))) + (and pkg-descs + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) + ;; Also check built-in packages. + (package-built-in-p package min-version)))) (defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -1232,6 +1787,56 @@ PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) +(defun package--ensure-init-file () + "Ensure that the user's init file has `package-initialize'. +`package-initialize' doesn't have to be called, as long as it is +present somewhere in the file, even as a comment. If it is not, +add a call to it along with some explanatory comments." + ;; Don't mess with the init-file from "emacs -Q". + (when (and (stringp user-init-file) + (not package--init-file-ensured) + (file-readable-p user-init-file) + (file-writable-p user-init-file)) + (let* ((buffer (find-buffer-visiting user-init-file)) + (contains-init + (if buffer + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (search-forward "(package-initialize)" nil 'noerror)))) + ;; Don't visit the file if we don't have to. + (with-temp-buffer + (insert-file-contents user-init-file) + (goto-char (point-min)) + (search-forward "(package-initialize)" nil 'noerror))))) + (unless contains-init + (with-current-buffer (or buffer + (let ((delay-mode-hooks t)) + (find-file-noselect user-init-file))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (and (looking-at-p "[[:blank:]]*\\(;\\|$\\)") + (not (eobp))) + (forward-line 1)) + (insert + "\n" + ";; Added by Package.el. This must come before configurations of\n" + ";; installed packages. Don't delete this line. If you don't want it,\n" + ";; just comment it out by adding a semicolon to the start of the line.\n" + ";; You may delete these explanatory comments.\n" + "(package-initialize)\n") + (unless (looking-at-p "$") + (insert "\n")) + (let ((file-precious-flag t)) + (save-buffer)) + (unless buffer + (kill-buffer (current-buffer))))))))) + (setq package--init-file-ensured t)) + ;;;###autoload (defun package-install (pkg &optional dont-select) "Install the package PKG. @@ -1264,31 +1869,16 @@ to install it but still mark it as selected." (package-desc-name pkg) pkg))) (unless (or dont-select (package--user-selected-p name)) - (customize-save-variable 'package-selected-packages - (cons name package-selected-packages)))) - (if (package-desc-p pkg) - (if (package-installed-p pkg) - (message "`%s' is already installed" (package-desc-full-name pkg)) - (package-download-transaction - (package-compute-transaction (list pkg) - (package-desc-reqs pkg)))) - (package-download-transaction - (package-compute-transaction () - (list (list pkg)))))) - -;;;###autoload -(defun package-reinstall (pkg) - "Reinstall package PKG. -PKG should be either a symbol, the package name, or a package-desc -object." - (interactive (list (intern (completing-read - "Reinstall package: " - (mapcar #'symbol-name - (mapcar #'car package-alist)))))) - (package-delete - (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) - 'force 'nosave) - (package-install pkg 'dont-select)) + (package--save-selected-packages + (cons name package-selected-packages)))) + (if-let ((transaction + (if (package-desc-p pkg) + (unless (package-installed-p pkg) + (package-compute-transaction (list pkg) + (package-desc-reqs pkg))) + (package-compute-transaction () (list (list pkg)))))) + (package-download-transaction transaction) + (message "`%s' is already installed" (package-desc-full-name pkg)))) (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. @@ -1304,120 +1894,6 @@ Otherwise return nil." (declare-function lm-homepage "lisp-mnt" (&optional file)) -(defun package--prepare-dependencies (deps) - "Turn DEPS into an acceptable list of dependencies. - -Any parts missing a version string get a default version string -of \"0\" (meaning any version) and an appropriate level of lists -is wrapped around any parts requiring it." - (cond - ((not (listp deps)) - (error "Invalid requirement specifier: %S" deps)) - (t (mapcar (lambda (dep) - (cond - ((symbolp dep) `(,dep "0")) - ((stringp dep) - (error "Invalid requirement specifier: %S" dep)) - ((and (listp dep) (null (cdr dep))) - (list (car dep) "0")) - (t dep))) - deps)))) - -(defun package-buffer-info () - "Return a `package-desc' describing the package in the current buffer. - -If the buffer does not contain a conforming package, signal an -error. If there is a package, narrow the buffer to the file's -boundaries." - (goto-char (point-min)) - (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t) - (error "Package lacks a file header")) - (let ((file-name (match-string-no-properties 1)) - (desc (match-string-no-properties 2)) - (start (line-beginning-position))) - (unless (search-forward (concat ";;; " file-name ".el ends here")) - (error "Package lacks a terminating comment")) - ;; Try to include a trailing newline. - (forward-line) - (narrow-to-region start (point)) - (require 'lisp-mnt) - ;; Use some headers we've invented to drive the process. - (let* ((requires-str (lm-header "package-requires")) - ;; Prefer Package-Version; if defined, the package author - ;; probably wants us to use it. Otherwise try Version. - (pkg-version - (or (package-strip-rcs-id (lm-header "package-version")) - (package-strip-rcs-id (lm-header "version")))) - (homepage (lm-homepage))) - (unless pkg-version - (error - "Package lacks a \"Version\" or \"Package-Version\" header")) - (package-desc-from-define - file-name pkg-version desc - (if requires-str - (package--prepare-dependencies - (package-read-from-string requires-str))) - :kind 'single - :url homepage)))) - -(declare-function tar-get-file-descriptor "tar-mode" (file)) -(declare-function tar--extract "tar-mode" (descriptor)) - -(defun package-tar-file-info () - "Find package information for a tar file. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'tar-mode)) - (let* ((dir-name (file-name-directory - (tar-header-name (car tar-parse-info)))) - (desc-file (package--description-file dir-name)) - (tar-desc (tar-get-file-descriptor (concat dir-name desc-file)))) - (unless tar-desc - (error "No package descriptor file found")) - (with-current-buffer (tar--extract tar-desc) - (unwind-protect - (or (package--read-pkg-desc 'tar) - (error "Can't find define-package in %s" - (tar-header-name tar-desc))) - (kill-buffer (current-buffer)))))) - -(defun package-dir-info () - "Find package information for a directory. -The return result is a `package-desc'." - (cl-assert (derived-mode-p 'dired-mode)) - (let* ((desc-file (package--description-file default-directory))) - (if (file-readable-p desc-file) - (with-temp-buffer - (insert-file-contents desc-file) - (package--read-pkg-desc 'dir)) - (let ((files (directory-files default-directory t "\\.el\\'" t)) - info) - (while files - (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) - ;; and return the info. - info)))) - -(defun package--read-pkg-desc (kind) - "Read a `define-package' form in current buffer. -Return the pkg-desc, with desc-kind set to KIND." - (goto-char (point-min)) - (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (when (eq (car pkg-def-parsed) 'define-package) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (when pkg-desc - (setf (package-desc-kind pkg-desc) kind) - pkg-desc)))) - - ;;;###autoload (defun package-install-from-buffer () "Install a package from the current buffer. @@ -1451,42 +1927,26 @@ Downloads and installs required packages as needed." ;; Install the package itself. (package-unpack pkg-desc) (unless (package--user-selected-p name) - (customize-save-variable 'package-selected-packages - (cons name package-selected-packages))) + (package--save-selected-packages + (cons name package-selected-packages))) pkg-desc)) -;;;###autoload -(defun package-install-file (file) - "Install a package from a file. -The file can either be a tar file or an Emacs Lisp file." - (interactive "fPackage file name: ") - (with-temp-buffer - (if (file-directory-p file) - (progn - (setq default-directory file) - (dired-mode)) - (insert-file-contents-literally file) - (when (string-match "\\.tar\\'" file) (tar-mode))) - (package-install-from-buffer))) - -(defun package--get-deps (pkg &optional only) - (let* ((pkg-desc (cadr (assq pkg package-alist))) - (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc) - for name = (car p) - when (assq name package-alist) - collect name)) - (indirect-deps (unless (eq only 'direct) - (delete-dups - (cl-loop for p in direct-deps - append (package--get-deps p)))))) - (cl-case only - (direct direct-deps) - (separate (list direct-deps indirect-deps)) - (indirect indirect-deps) - (t (delete-dups (append direct-deps indirect-deps)))))) +;;;###autoload +(defun package-install-file (file) + "Install a package from a file. +The file can either be a tar file or an Emacs Lisp file." + (interactive "fPackage file name: ") + (with-temp-buffer + (if (file-directory-p file) + (progn + (setq default-directory file) + (dired-mode)) + (insert-file-contents-literally file) + (when (string-match "\\.tar\\'" file) (tar-mode))) + (package-install-from-buffer))) ;;;###autoload -(defun package-install-user-selected-packages () +(defun package-install-selected-packages () "Ensure packages in `package-selected-packages' are installed. If some packages are not installed propose to install them." (interactive) @@ -1507,22 +1967,8 @@ If some packages are not installed propose to install them." (mapc #'package-install lst)) (message "All your packages are already installed"))))) -(defun package--used-elsewhere-p (pkg-desc &optional pkg-list) - "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST. -Return the first package found in PKG-LIST of which PKG is a -dependency. - -When not specified, PKG-LIST defaults to `package-alist' -with PKG-DESC entry removed." - (unless (string= (package-desc-status pkg-desc) "obsolete") - (let ((pkg (package-desc-name pkg-desc))) - (cl-loop with alist = (or pkg-list - (remove (assq pkg package-alist) - package-alist)) - for p in alist thereis - (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p)))) - (car p)))))) - + +;;; Package Deletion (defun package--newest-p (pkg) "Return t if PKG is the newest package with its name." (equal (cadr (assq (package-desc-name pkg) package-alist)) @@ -1549,8 +1995,7 @@ If NOSAVE is non-nil, the package is not removed from ;; Don't deselect if this is an older version of an ;; upgraded package. (package--newest-p pkg-desc)) - (customize-save-variable - 'package-selected-packages (remove name package-selected-packages))) + (package--save-selected-packages (remove name package-selected-packages))) (cond ((not (string-prefix-p (file-name-as-directory (expand-file-name package-user-dir)) (expand-file-name dir))) @@ -1563,7 +2008,7 @@ If NOSAVE is non-nil, the package is not removed from ;; Don't delete packages used as dependency elsewhere. (error "Package `%s' is used by `%s' as dependency, not deleting" (package-desc-full-name pkg-desc) - pkg-used-elsewhere-by)) + (package-desc-name pkg-used-elsewhere-by))) (t (delete-directory dir t t) ;; Remove NAME-VERSION.signed file. @@ -1577,17 +2022,19 @@ If NOSAVE is non-nil, the package is not removed from (setq package-alist (delq pkgs package-alist)))) (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) -(defun package--removable-packages () - "Return a list of names of packages no longer needed. -These are packages which are neither contained in -`package-selected-packages' nor a dependency of one that is." - (let ((needed (cl-loop for p in package-selected-packages - if (assq p package-alist) - ;; `p' and its dependencies are needed. - append (cons p (package--get-deps p))))) - (cl-loop for p in (mapcar #'car package-alist) - unless (memq p needed) - collect p))) +;;;###autoload +(defun package-reinstall (pkg) + "Reinstall package PKG. +PKG should be either a symbol, the package name, or a package-desc +object." + (interactive (list (intern (completing-read + "Reinstall package: " + (mapcar #'symbol-name + (mapcar #'car package-alist)))))) + (package-delete + (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist))) + 'force 'nosave) + (package-install pkg 'dont-select)) ;;;###autoload (defun package-autoremove () @@ -1614,155 +2061,6 @@ will be deleted." removable)) (message "Nothing to autoremove"))))) -(defun package-archive-base (desc) - "Return the archive containing the package NAME." - (cdr (assoc (package-desc-archive desc) package-archives))) - -(defun package-archive-priority (archive) - "Return the priority of ARCHIVE. - -The archive priorities are specified in -`package-archive-priorities'. If not given there, the priority -defaults to 0." - (or (cdr (assoc archive package-archive-priorities)) - 0)) - -(defun package-desc-priority-version (pkg-desc) - "Return the version PKG-DESC with the archive priority prepended. - -This allows for easy comparison of package versions from -different archives if archive priorities are meant to be taken in -consideration." - (cons (package-archive-priority - (package-desc-archive pkg-desc)) - (package-desc-version pkg-desc))) - -(defun package--download-one-archive (archive file) - "Retrieve an archive file FILE from ARCHIVE, and cache it. -ARCHIVE should be a cons cell of the form (NAME . LOCATION), -similar to an entry in `package-alist'. Save the cached copy to -\"archives/NAME/archive-contents\" in `package-user-dir'." - (let ((dir (expand-file-name (format "archives/%s" (car archive)) - package-user-dir)) - (sig-file (concat file ".sig")) - good-signatures) - (package--with-work-buffer (cdr archive) file - ;; Check signature of archive-contents, if desired. - (if (and package-check-signature - (not (member archive package-unsigned-archives))) - (if (package--archive-file-exists-p (cdr archive) sig-file) - (setq good-signatures (package--check-signature (cdr archive) - file)) - (unless (eq package-check-signature 'allow-unsigned) - (error "Unsigned archive `%s'" - (car archive))))) - ;; Read the retrieved buffer to make sure it is valid (e.g. it - ;; may fetch a URL redirect page). - (when (listp (read (current-buffer))) - (make-directory dir t) - (write-region nil nil (expand-file-name file dir) nil 'silent))) - (when good-signatures - ;; Write out good signatures into archive-contents.signed file. - (write-region (mapconcat #'epg-signature-to-string good-signatures "\n") - nil - (expand-file-name (concat file ".signed") dir) - nil 'silent)))) - -(declare-function epg-check-configuration "epg-config" - (config &optional minimum-version)) -(declare-function epg-configuration "epg-config" ()) -(declare-function epg-import-keys-from-file "epg" (context keys)) - -;;;###autoload -(defun package-import-keyring (&optional file) - "Import keys from FILE." - (interactive "fFile: ") - (setq file (expand-file-name file)) - (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - (with-file-modes 448 - (make-directory homedir t)) - (setf (epg-context-home-directory context) homedir) - (message "Importing %s..." (file-name-nondirectory file)) - (epg-import-keys-from-file context file) - (message "Importing %s...done" (file-name-nondirectory file)))) - -(defun package--build-compatibility-table () - "Build `package--compatibility-table' with `package--mapc'." - ;; Build compat table. - (setq package--compatibility-table (make-hash-table :test 'eq)) - (package--mapc #'package--add-to-compatibility-table)) - -;;;###autoload -(defun package-refresh-contents () - "Download the ELPA archive description if needed. -This informs Emacs about the latest versions of all packages, and -makes them available for download." - (interactive) - ;; FIXME: Do it asynchronously. - (unless (file-exists-p package-user-dir) - (make-directory package-user-dir t)) - (let ((default-keyring (expand-file-name "package-keyring.gpg" - data-directory))) - (when (and package-check-signature (file-exists-p default-keyring)) - (condition-case-unless-debug error - (progn - (epg-check-configuration (epg-configuration)) - (package-import-keyring default-keyring)) - (error (message "Cannot import default keyring: %S" (cdr error)))))) - (dolist (archive package-archives) - (condition-case-unless-debug nil - (package--download-one-archive archive "archive-contents") - (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents) - (package--build-compatibility-table)) - -(defun package--find-non-dependencies () - "Return a list of installed packages which are not dependencies. -Finds all packages in `package-alist' which are not dependencies -of any other packages. -Used to populate `package-selected-packages'." - (let ((dep-list - (delete-dups - (apply #'append - (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) - package-alist))))) - (cl-loop for p in package-alist - for name = (car p) - unless (memq name dep-list) - collect name))) - -;;;###autoload -(defun package-initialize (&optional no-activate) - "Load Emacs Lisp packages, and activate them. -The variable `package-load-list' controls which packages to load. -If optional arg NO-ACTIVATE is non-nil, don't activate packages." - (interactive) - (setq package-alist nil) - (package-load-all-descriptors) - (package-read-all-archive-contents) - (unless no-activate - (dolist (elt package-alist) - (package-activate (car elt)))) - (setq package--initialized t) - ;; This uses `package--mapc' so it must be called after - ;; `package--initialized' is t. - (package--build-compatibility-table)) - -(defun package--add-to-compatibility-table (pkg) - "If PKG is compatible (without dependencies), add to the compatibility table. -PKG is a package-desc object. -Only adds if its version is higher than what's already stored in -the table." - (unless (package--incompatible-p pkg 'shallow) - (let* ((name (package-desc-name pkg)) - (version (or (package-desc-version pkg) '(0))) - (table-version (gethash name package--compatibility-table))) - (when (or (not table-version) - (version-list-< table-version version)) - (puthash name version package--compatibility-table))))) - ;;;; Package description buffer. @@ -1796,6 +2094,8 @@ the table." (with-current-buffer standard-output (describe-package-1 package))))) +(declare-function lm-commentary "lisp-mnt" (&optional file)) + (defun describe-package-1 (pkg) (require 'lisp-mnt) (let* ((desc (or @@ -1808,6 +2108,7 @@ the table." (name (if desc (package-desc-name desc) pkg)) (pkg-dir (if desc (package-desc-dir desc))) (reqs (if desc (package-desc-reqs desc))) + (required-by (if desc (package--used-elsewhere-p desc nil 'all))) (version (if desc (package-desc-version desc))) (archive (if desc (package-desc-archive desc))) (extras (and desc (package-desc-extras desc))) @@ -1849,7 +2150,14 @@ the table." (insert "'")) (if signed (insert ".") - (insert " (unsigned)."))) + (insert " (unsigned).")) + (when (and (package-desc-p desc) + (not required-by) + (package-installed-p desc)) + (insert " ") + (package-make-button "Delete" + 'action #'package-delete-button-action + 'package-desc desc))) (incompatible-reason (insert (propertize "Incompatible" 'face font-lock-warning-face) " because it depends on ") @@ -1893,6 +2201,19 @@ the table." (help-insert-xref-button text 'help-package name) (insert reason))) (insert "\n"))) + (when required-by + (insert (propertize "Required by" 'font-lock-face 'bold) ": ") + (let ((first t)) + (dolist (pkg required-by) + (let ((text (package-desc-full-name pkg))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package + (package-desc-name pkg)))) + (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) ": " (if desc (package-desc-summary desc)) "\n") (when homepage @@ -1980,6 +2301,14 @@ the table." (revert-buffer nil t) (goto-char (point-min))))) +(defun package-delete-button-action (button) + (let ((pkg-desc (button-get button 'package-desc))) + (when (y-or-n-p (format "Delete package `%s'? " + (package-desc-full-name pkg-desc))) + (package-delete pkg-desc) + (revert-buffer nil t) + (goto-char (point-min))))) + (defun package-keyword-button-action (button) (let ((pkg-keyword (button-get button 'package-keyword))) (package-show-package-list t (list pkg-keyword)))) @@ -2013,6 +2342,7 @@ the table." (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "?" 'package-menu-describe-package) + (define-key map "(" #'package-menu-hide-obsolete) (define-key map [menu-bar package-menu] (cons "Package" menu-map)) (define-key menu-map [mq] '(menu-item "Quit" quit-window @@ -2070,11 +2400,17 @@ the table." (defvar package-menu--new-package-list nil "List of newly-available packages since `list-packages' was last called.") +(defvar package-menu--transaction-status nil + "Mode-line status of ongoing package transaction.") + (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" "Major mode for browsing a list of packages. Letters do not insert themselves; instead, they are commands. \\ \\{package-menu-mode-map}" + (setq mode-line-process '((package--downloads-in-progress ":Loading") + (package-menu--transaction-status + package-menu--transaction-status))) (setq tabulated-list-format `[("Package" 18 package-menu--name-predicate) ("Version" 13 nil) @@ -2148,28 +2484,84 @@ of these dependencies, similar to the list returned by ((version-list-= version hv) "held") ((version-list-< version hv) "obsolete") (t "disabled")))) - ((package-built-in-p name version) "obsolete") - ((package--incompatible-p pkg-desc) "incompat") (dir ;One of the installed packages. (cond - ((not (file-exists-p (package-desc-dir pkg-desc))) "deleted") + ((not (file-exists-p dir)) "deleted") + ;; Not inside `package-user-dir'. + ((not (file-in-directory-p dir package-user-dir)) "external") ((eq pkg-desc (cadr (assq name package-alist))) (if (not signed) "unsigned" (if (package--user-selected-p name) "installed" "dependency"))) (t "obsolete"))) + ((package--incompatible-p pkg-desc) "incompat") (t (let* ((ins (cadr (assq name package-alist))) (ins-v (if ins (package-desc-version ins)))) (cond - ((or (null ins) (version-list-< ins-v version)) + ;; Installed obsolete packages are handled in the `dir' + ;; clause above. Here we handle available obsolete, which + ;; are displayed depending on `package-menu--hide-obsolete'. + ((and ins (version-list-<= version ins-v)) "avail-obso") + (t (if (memq name package-menu--new-package-list) - "new" "available")) - ((version-list-< version ins-v) "obsolete") - ((version-list-= version ins-v) - (if (not signed) "unsigned" - (if (package--user-selected-p name) - "installed" "dependency"))))))))) + "new" "available")))))))) + +(defvar package-menu--hide-obsolete t + "Whether available obsolete packages should be hidden. +Can be toggled with \\ \\[package-menu-hide-obsolete]. +Installed obsolete packages are always displayed.") + +(defun package-menu-hide-obsolete () + "Toggle visibility of obsolete available packages." + (interactive) + (unless (derived-mode-p 'package-menu-mode) + (user-error "The current buffer is not a Package Menu")) + (setq package-menu--hide-obsolete + (not package-menu--hide-obsolete)) + (message "%s available-obsolete packages" (if package-menu--hide-obsolete + "Hiding" "Displaying")) + (revert-buffer nil 'no-confirm)) + +(defun package--remove-hidden (pkg-list) + "Filter PKG-LIST according to `package-archive-priorities'. +PKG-LIST must be a list of package-desc objects, all with the +same name, sorted by decreasing `package-desc-priority-version'. +Return a list of packages tied for the highest priority according +to their archives." + (when pkg-list + ;; Variable toggled with `package-menu-hide-obsolete'. + (if (not package-menu--hide-obsolete) + pkg-list + (let ((installed (cadr (assq (package-desc-name (car pkg-list)) + package-alist)))) + (when installed + (setq pkg-list + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-< (package-desc-version p) + ins-version)) + pkg-list)))) + (let ((filtered-by-priority + (cond + ((not package-menu-hide-low-priority) + pkg-list) + ((eq package-menu-hide-low-priority 'archive) + (let* ((max-priority most-negative-fixnum) + (out)) + (while pkg-list + (let ((p (pop pkg-list))) + (if (>= (package-desc-priority p) max-priority) + (push p out) + (setq pkg-list nil)))) + (nreverse out))) + (pkg-list + (list (car pkg-list)))))) + (if (not installed) + filtered-by-priority + (let ((ins-version (package-desc-version installed))) + (cl-remove-if (lambda (p) (version-list-= (package-desc-version p) + ins-version)) + filtered-by-priority)))))))) (defun package-menu--refresh (&optional packages keywords) "Re-populate the `tabulated-list-entries'. @@ -2177,47 +2569,46 @@ PACKAGES should be nil or t, which means to display all known packages. KEYWORDS should be nil or a list of keywords." ;; Construct list of (PKG-DESC . STATUS). (unless packages (setq packages t)) - (let (info-list name) + (let (info-list) ;; Installed packages: (dolist (elt package-alist) - (setq name (car elt)) - (when (or (eq packages t) (memq name packages)) - (dolist (pkg (cdr elt)) - (when (package--has-keyword-p pkg keywords) - (package--push pkg (package-desc-status pkg) info-list))))) + (let ((name (car elt))) + (when (or (eq packages t) (memq name packages)) + (dolist (pkg (cdr elt)) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) ;; Built-in packages: (dolist (elt package--builtins) - (setq name (car elt)) - (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. - (package--has-keyword-p (package--from-builtin elt) keywords) - (or package-list-unversioned - (package--bi-desc-version (cdr elt))) - (or (eq packages t) (memq name packages))) - (package--push (package--from-builtin elt) "built-in" info-list))) + (let ((pkg (package--from-builtin elt)) + (name (car elt))) + (when (not (eq name 'emacs)) ; Hide the `emacs' package. + (when (and (package--has-keyword-p pkg keywords) + (or package-list-unversioned + (package--bi-desc-version (cdr elt))) + (or (eq packages t) (memq name packages))) + (push pkg info-list))))) ;; Available and disabled packages: (dolist (elt package-archive-contents) - (setq name (car elt)) - (when (or (eq packages t) (memq name packages)) - (dolist (pkg (cdr elt)) - ;; Hide obsolete packages. - (when (and (not (package-installed-p (package-desc-name pkg) - (package-desc-version pkg))) - (package--has-keyword-p pkg keywords)) - (package--push pkg (package-desc-status pkg) info-list))))) + (let ((name (car elt))) + (when (or (eq packages t) (memq name packages)) + ;; Hide available-obsolete or low-priority packages. + (dolist (pkg (package--remove-hidden (cdr elt))) + (when (package--has-keyword-p pkg keywords) + (push pkg info-list)))))) ;; Print the result. (setq tabulated-list-entries - (mapcar #'package-menu--print-info info-list)))) + (mapcar #'package-menu--print-info-simple info-list)))) (defun package-all-keywords () "Collect all package keywords" - (let (keywords) + (let ((key-list)) (package--mapc (lambda (desc) - (let* ((desc-keywords (and desc (package-desc--keywords desc)))) - (setq keywords (append keywords desc-keywords))))) - keywords)) + (setq key-list (append (package-desc--keywords desc) + key-list)))) + key-list)) (defun package--mapc (function &optional packages) "Call FUNCTION for all known PACKAGES. @@ -2256,12 +2647,14 @@ Built-in packages are converted with `package--from-builtin'." "Test if package DESC has any of the given KEYWORDS. When none are given, the package matches." (if keywords - (let* ((desc-keywords (and desc (package-desc--keywords desc))) - found) - (dolist (k keywords) - (when (and (not found) - (member k desc-keywords)) - (setq found t))) + (let ((desc-keywords (and desc (package-desc--keywords desc))) + found) + (while (and (not found) keywords) + (let ((k (pop keywords))) + (setq found + (or (string= k (concat "arc:" (package-desc-archive desc))) + (string= k (concat "status:" (package-desc-status desc))) + (member k desc-keywords))))) found) t)) @@ -2289,11 +2682,20 @@ shown." "Return a package entry suitable for `tabulated-list-entries'. PKG has the form (PKG-DESC . STATUS). Return (PKG-DESC [NAME VERSION STATUS DOC])." - (let* ((pkg-desc (car pkg)) - (status (cdr pkg)) + (package-menu--print-info-simple (car pkg))) +(make-obsolete 'package-menu--print-info + 'package-menu--print-info-simple "25.1") + +(defun package-menu--print-info-simple (pkg) + "Return a package entry suitable for `tabulated-list-entries'. +PKG is a package-desc object. +Return (PKG-DESC [NAME VERSION STATUS DOC])." + (let* ((status (package-desc-status pkg)) (face (pcase status (`"built-in" 'font-lock-builtin-face) + (`"external" 'font-lock-builtin-face) (`"available" 'default) + (`"avail-obso" 'font-lock-comment-face) (`"new" 'bold) (`"held" 'font-lock-constant-face) (`"disabled" 'font-lock-warning-face) @@ -2302,21 +2704,23 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"unsigned" 'font-lock-warning-face) (`"incompat" 'font-lock-comment-face) (_ 'font-lock-warning-face)))) ; obsolete. - (list pkg-desc - `[,(list (symbol-name (package-desc-name pkg-desc)) - 'face 'link - 'follow-link t - 'package-desc pkg-desc - 'action 'package-menu-describe-package) + (list pkg + `[(,(symbol-name (package-desc-name pkg)) + face link + follow-link t + package-desc ,pkg + action package-menu-describe-package) ,(propertize (package-version-join - (package-desc-version pkg-desc)) + (package-desc-version pkg)) 'font-lock-face face) ,(propertize status 'font-lock-face face) ,@(if (cdr package-archives) - (list (propertize (or (package-desc-archive pkg-desc) "") + (list (propertize (or (package-desc-archive pkg) "") 'font-lock-face face))) - ,(propertize (package-desc-summary pkg-desc) - 'font-lock-face face)]))) + ,(package-desc-summary pkg)]))) + +(defvar package-menu--old-archive-contents nil + "`package-archive-contents' before the latest refresh.") (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -2325,8 +2729,9 @@ This fetches the contents of each archive specified in (interactive) (unless (derived-mode-p 'package-menu-mode) (user-error "The current buffer is not a Package Menu")) - (package-refresh-contents) - (package-menu--generate t t)) + (setq package-menu--old-archive-contents package-archive-contents) + (setq package-menu--new-package-list nil) + (package-refresh-contents package-menu-async)) (defun package-menu-describe-package (&optional button) "Describe the current package. @@ -2350,7 +2755,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-mark-install (&optional _num) "Mark a package for installation and move to the next line." (interactive "p") - (if (member (package-menu-get-status) '("available" "new" "dependency")) + (if (member (package-menu-get-status) '("available" "avail-obso" "new" "dependency")) (tabulated-list-put-tag "I" t) (forward-line))) @@ -2375,10 +2780,31 @@ If optional arg BUTTON is non-nil, describe its associated package." (tabulated-list-put-tag "D" t) (forward-line 1))))) +(defvar package--quick-help-keys + '(("install," "delete," "unmark," ("execute" . 1)) + ("next," "previous") + ("refresh-contents," "g-redisplay," "filter," "(-toggle-obsolete" "help"))) + +(defun package--prettify-quick-help-key (desc) + "Prettify DESC to be displayed as a help menu." + (if (listp desc) + (if (listp (cdr desc)) + (mapconcat #'package--prettify-quick-help-key desc " ") + (let ((place (cdr desc)) + (out (car desc))) + ;; (setq out (propertize out 'face 'paradox-comment-face)) + (add-text-properties place (1+ place) + '(face (bold font-lock-function-name-face)) + out) + out)) + (package--prettify-quick-help-key (cons desc 0)))) + (defun package-menu-quick-help () - "Show short key binding help for package-menu-mode." + "Show short key binding help for `package-menu-mode'. +The full list of keys can be viewed with \\[describe-mode]." (interactive) - (message "n-ext, i-nstall, d-elete, u-nmark, x-ecute, r-efresh, h-elp")) + (message (mapconcat #'package--prettify-quick-help-key + package--quick-help-keys "\n"))) (define-obsolete-function-alias 'package-menu-view-commentary 'package-menu-describe-package "24.1") @@ -2390,6 +2816,24 @@ If optional arg BUTTON is non-nil, describe its associated package." (aref (cadr entry) 2) ""))) +(defun package-archive-priority (archive) + "Return the priority of ARCHIVE. + +The archive priorities are specified in +`package-archive-priorities'. If not given there, the priority +defaults to 0." + (or (cdr (assoc archive package-archive-priorities)) + 0)) + +(defun package-desc-priority-version (pkg-desc) + "Return the version PKG-DESC with the archive priority prepended. + +This allows for easy comparison of package versions from +different archives if archive priorities are meant to be taken in +consideration." + (cons (package-desc-priority pkg-desc) + (package-desc-version pkg-desc))) + (defun package-menu--find-upgrades () (let (installed available upgrades) ;; Build list of installed/available packages in this buffer. @@ -2439,39 +2883,94 @@ call will upgrade the package." (length upgrades) (if (= (length upgrades) 1) "" "s"))))) -(defun package--sort-deps-in-alist (package only) - "Return a list of dependencies for PACKAGE sorted by dependency. -PACKAGE is included as the first element of the returned list. -ONLY is an alist associating package names to package objects. -Only these packages will be in the return value an their cdrs are -destructively set to nil in ONLY." - (let ((out)) - (dolist (dep (package-desc-reqs package)) - (when-let ((cell (assq (car dep) only)) - (dep-package (cdr-safe cell))) - (setcdr cell nil) - (setq out (append (package--sort-deps-in-alist dep-package only) - out)))) - (cons package out))) - -(defun package--sort-by-dependence (package-list) - "Return PACKAGE-LIST sorted by dependence. -That is, any element of the returned list is guaranteed to not -directly depend on any elements that come before it. - -PACKAGE-LIST is a list of package-desc objects. -Indirect dependencies are guaranteed to be returned in order only -if all the in-between dependencies are also in PACKAGE-LIST." - (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p)) package-list)) - out-list) - (dolist (cell alist out-list) - ;; `package--sort-deps-in-alist' destructively changes alist, so - ;; some cells might already be empty. We check this here. - (when-let ((pkg-desc (cdr cell))) - (setcdr cell nil) - (setq out-list - (append (package--sort-deps-in-alist pkg-desc alist) - out-list)))))) +(defun package-menu--list-to-prompt (packages) + "Return a string listing PACKAGES that's usable in a prompt. +PACKAGES is a list of `package-desc' objects. +Formats the returned string to be usable in a minibuffer +prompt (see `package-menu--prompt-transaction-p')." + (cond + ;; None + ((not packages) "") + ;; More than 1 + ((cdr packages) + (format "these %d packages (%s)" + (length packages) + (mapconcat #'package-desc-full-name packages ", "))) + ;; Exactly 1 + (t (format "package `%s'" + (package-desc-full-name (car packages)))))) + +(defun package-menu--prompt-transaction-p (delete install upgrade) + "Prompt the user about DELETE, INSTALL, and UPGRADE. +DELETE, INSTALL, and UPGRADE are lists of `package-desc' objects. +Either may be nil, but not all." + (y-or-n-p + (concat + (when delete "Delete ") + (package-menu--list-to-prompt delete) + (when (and delete install) + (if upgrade "; " "; and ")) + (when install "Install ") + (package-menu--list-to-prompt install) + (when (and upgrade (or install delete)) "; and ") + (when upgrade "Upgrade ") + (package-menu--list-to-prompt upgrade) + "? "))) + +(defun package-menu--partition-transaction (install delete) + "Return an alist describing an INSTALL DELETE transaction. +Alist contains three entries, upgrade, delete, and install, each +with a list of package names. + +The upgrade entry contains any `package-desc' objects in INSTALL +whose name coincides with an object in DELETE. The delete and +the install entries are the same as DELETE and INSTALL with such +objects removed." + (let* ((upg (cl-intersection install delete :key #'package-desc-name)) + (ins (cl-set-difference install upg :key #'package-desc-name)) + (del (cl-set-difference delete upg :key #'package-desc-name))) + `((delete . ,del) (install . ,ins) (upgrade . ,upg)))) + +(defun package-menu--perform-transaction (install-list delete-list) + "Install packages in INSTALL-LIST and delete DELETE-LIST." + (if install-list + (let ((status-format (format ":Installing %%d/%d" + (length install-list))) + (i 0) + (package-menu--transaction-status)) + (dolist (pkg install-list) + (setq package-menu--transaction-status + (format status-format (cl-incf i))) + (force-mode-line-update) + (redisplay 'force) + ;; Don't mark as selected, `package-menu-execute' already + ;; does that. + (package-install pkg 'dont-select))) + ;; Once there are no more packages to install, proceed to + ;; deletion. + (let ((package-menu--transaction-status ":Deleting")) + (force-mode-line-update) + (redisplay 'force) + (dolist (elt (package--sort-by-dependence delete-list)) + (condition-case-unless-debug err + (let ((inhibit-message t)) + (package-delete elt nil 'nosave)) + (error (message (cadr err)))))))) + +(defun package--update-selected-packages (add remove) + "Update the `package-selected-packages' list according to ADD and REMOVE. +ADD and REMOVE must be disjoint lists of package names (or +`package-desc' objects) to be added and removed to the selected +packages list, respectively." + (dolist (p add) + (cl-pushnew (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages)) + (dolist (p remove) + (setq package-selected-packages + (remove (if (package-desc-p p) (package-desc-name p) p) + package-selected-packages))) + (when (or add remove) + (package--save-selected-packages package-selected-packages))) (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. @@ -2494,54 +2993,32 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((eq cmd ?I) (push pkg-desc install-list)))) (forward-line))) - (when install-list - (if (or - noquery - (yes-or-no-p - (if (= (length install-list) 1) - (format "Install package `%s'? " - (package-desc-full-name (car install-list))) - (format "Install these %d packages (%s)? " - (length install-list) - (mapconcat #'package-desc-full-name - install-list ", "))))) - (mapc (lambda (p) - ;; Don't mark as selected if it's a new version of - ;; an installed package. - (package-install p (and (not (package-installed-p p)) - (package-installed-p - (package-desc-name p))))) - install-list))) - ;; Delete packages, prompting if necessary. - (when delete-list - (if (or - noquery - (yes-or-no-p - (if (= (length delete-list) 1) - (format "Delete package `%s'? " - (package-desc-full-name (car delete-list))) - (format "Delete these %d packages (%s)? " - (length delete-list) - (mapconcat #'package-desc-full-name - delete-list ", "))))) - (dolist (elt (package--sort-by-dependence delete-list)) - (condition-case-unless-debug err - (package-delete elt) - (error (message (cadr err))))) - (error "Aborted"))) - (if (not (or delete-list install-list)) - (message "No operations specified.") - (when package-selected-packages - (let ((removable (package--removable-packages))) - (when (and removable - (y-or-n-p - (format "These %d packages are no longer needed, delete them (%s)? " - (length removable) - (mapconcat #'symbol-name removable ", ")))) - ;; We know these are removable, so we can use force instead of sorting them. - (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) 'force 'nosave)) - removable)))) - (package-menu--generate t t)))) + (unless (or delete-list install-list) + (user-error "No operations specified")) + (let-alist (package-menu--partition-transaction install-list delete-list) + (when (or noquery + (package-menu--prompt-transaction-p .delete .install .upgrade)) + (let ((message-template + (concat "Package menu: Operation %s [" + (when .delete (format "Delet__ %s" (length .delete))) + (when (and .delete .install) "; ") + (when .install (format "Install__ %s" (length .install))) + (when (and .upgrade (or .install .delete)) "; ") + (when .upgrade (format "Upgrad__ %s" (length .upgrade))) + "]"))) + (message (replace-regexp-in-string "__" "ing" message-template) "started") + ;; Packages being upgraded are not marked as selected. + (package--update-selected-packages .install .delete) + (package-menu--perform-transaction install-list delete-list) + (when package-selected-packages + (if-let ((removable (package--removable-packages))) + (message "Package menu: Operation finished. %d packages %s" + (length removable) + "are no longer needed, type `M-x package-autoremove' to remove them") + (message (replace-regexp-in-string "__" "ed" message-template) + "finished")))) + ;; This calls `package-menu--generate'. + (package-menu--post-refresh))))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) @@ -2557,8 +3034,11 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (package-menu--name-predicate A B)) ((string= sA "new") t) ((string= sB "new") nil) - ((string= sA "available") t) - ((string= sB "available") nil) + ((string-prefix-p "avail" sA) + (if (string-prefix-p "avail" sB) + (package-menu--name-predicate A B) + t)) + ((string-prefix-p "avail" sB) nil) ((string= sA "installed") t) ((string= sB "installed") nil) ((string= sA "dependency") t) @@ -2567,6 +3047,8 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((string= sB "unsigned") nil) ((string= sA "held") t) ((string= sB "held") nil) + ((string= sA "external") t) + ((string= sB "external") nil) ((string= sA "built-in") t) ((string= sB "built-in") nil) ((string= sA "obsolete") t) @@ -2590,6 +3072,36 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< (or (package-desc-archive (car A)) "") (or (package-desc-archive (car B)) ""))) +(defun package-menu--populate-new-package-list () + "Decide which packages are new in `package-archives-contents'. +Store this list in `package-menu--new-package-list'." + ;; Find which packages are new. + (when package-menu--old-archive-contents + (dolist (elt package-archive-contents) + (unless (assq (car elt) package-menu--old-archive-contents) + (push (car elt) package-menu--new-package-list))) + (setq package-menu--old-archive-contents nil))) + +(defun package-menu--find-and-notify-upgrades () + "Notify the user of upgradable packages." + (when-let ((upgrades (package-menu--find-upgrades))) + (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." + (length upgrades) + (if (= (length upgrades) 1) "" "s") + (substitute-command-keys "\\[package-menu-mark-upgrades]") + (if (= (length upgrades) 1) "it" "them")))) + +(defun package-menu--post-refresh () + "Check for new packages, revert the *Packages* buffer, and check for upgrades. +This function is called after `package-refresh-contents' and +after `package-menu--perform-transaction'." + (package-menu--populate-new-package-list) + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (with-current-buffer buf + (revert-buffer nil 'noconfirm)))) + (package-menu--find-and-notify-upgrades)) + ;;;###autoload (defun list-packages (&optional no-fetch) "Display a list of packages. @@ -2601,36 +3113,24 @@ The list is displayed in a buffer named `*Packages*'." ;; Initialize the package system if necessary. (unless package--initialized (package-initialize t)) - (let (old-archives new-packages) - (unless no-fetch - ;; Read the locally-cached archive-contents. - (package-read-all-archive-contents) - (setq old-archives package-archive-contents) + ;; Integrate the package-menu with updating the archives. + (add-hook 'package--post-download-archives-hook + #'package-menu--post-refresh) + + ;; Generate the Package Menu. + (let ((buf (get-buffer-create "*Packages*"))) + (with-current-buffer buf + (package-menu-mode) + ;; Fetch the remote list of packages. - (package-refresh-contents) - ;; Find which packages are new. - (dolist (elt package-archive-contents) - (unless (assq (car elt) old-archives) - (push (car elt) new-packages)))) - - ;; Generate the Package Menu. - (let ((buf (get-buffer-create "*Packages*"))) - (with-current-buffer buf - (package-menu-mode) - (set (make-local-variable 'package-menu--new-package-list) - new-packages) - (package-menu--generate nil t)) - ;; The package menu buffer has keybindings. If the user types - ;; `M-x list-packages', that suggests it should become current. - (switch-to-buffer buf)) - - (let ((upgrades (package-menu--find-upgrades))) - (if upgrades - (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s") - (substitute-command-keys "\\[package-menu-mark-upgrades]") - (if (= (length upgrades) 1) "it" "them")))))) + (unless no-fetch (package-menu-refresh)) + + ;; If we're not async, this would be redundant. + (when package-menu-async + (package-menu--generate nil t))) + ;; The package menu buffer has keybindings. If the user types + ;; `M-x list-packages', that suggests it should become current. + (switch-to-buffer buf))) ;;;###autoload (defalias 'package-list-packages 'list-packages) @@ -2660,9 +3160,17 @@ shown." (defun package-menu-filter (keyword) "Filter the *Packages* buffer. Show only those items that relate to the specified KEYWORD. +KEYWORD can be a string or a list of strings. If it is a list, a +package will be displayed if it matches any of the keywords. +Interactively, it is a list of strings separated by commas. + To restore the full package list, type `q'." - (interactive (list (completing-read "Keyword: " (package-all-keywords)))) - (package-show-package-list t (list keyword))) + (interactive + (list (completing-read-multiple + "Keywords (comma separated): " (package-all-keywords)))) + (package-show-package-list t (if (stringp keyword) + (list keyword) + keyword))) (defun package-list-packages-no-fetch () "Display a list of packages.