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)
If VERSION is nil, the package is not loaded (it is \"disabled\")."
:type '(repeat symbol)
:risky t
- :group 'package
:version "24.1")
(defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/"))
: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-mode-map> \\[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.
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
;; 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")
(defcustom package-user-dir (locate-user-emacs-file "elpa")
packages in `package-directory-list'."
:type 'directory
:risky t
- :group 'package
:version "24.1")
(defcustom package-directory-list
contrast, `package-user-dir' contains packages for personal use."
:type '(repeat directory)
:risky t
- :group 'package
:version "24.1")
(defvar epg-gpg-program)
(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
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")
+
\f
;;; `package-desc' object definition
;; This is the struct used internally to represent packages.
(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))
(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)
)
;;;; Compilation
+(defvar warning-minimum-level)
(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))
+ (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)
deps))))
(declare-function lm-header "lisp-mnt" (header))
-(declare-function lm-homepage "lisp-mnt" ())
+(declare-function lm-homepage "lisp-mnt" (&optional file))
(defun package-buffer-info ()
"Return a `package-desc' describing the package in the current buffer.
(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-status "epg" (signature) t)
(declare-function epg-signature-to-string "epg" (signature))
(defun package--display-verify-error (context sig-file)
otherwise propagate the error. For description of the other
arguments see `package--with-work-buffer'."
(declare (indent 3) (debug t))
- `(if (or (not ,async)
- (not (string-match-p "\\`https?:" ,location)))
- (package--with-work-buffer ,location ,file ,@body)
- (url-retrieve (concat ,location ,file)
- (lambda (status)
- (if (eq (car status) :error)
- (if (functionp ,async)
- (funcall ,async)
- (signal (cdar status) (cddr status)))
- (goto-char (point-min))
- (unless (search-forward "\n\n" nil 'noerror)
- (error "Invalid url response"))
- (delete-region (point-min) (point))
- ,@body)
- (kill-buffer (current-buffer)))
- nil
- 'silent)))
+ (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.
(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))
(let ((filename (expand-file-name file package-user-dir)))
(when (file-exists-p filename)
(with-temp-buffer
- (insert-file-contents-literally filename)
+ (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"
;; available on disk.
(defvar package--initialized nil)
+(defvar package--init-file-ensured nil
+ "Whether we know the init file has package-initialize.")
+
;;;###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 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
(remove entry package--downloads-in-progress))
;; If this was the last download, run the hook.
(unless package--downloads-in-progress
- (package--build-compatibility-table)
(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")
;; 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)
perform the downloads asynchronously."
;; The downloaded archive contents will be read as part of
;; `package--update-downloads-in-progress'.
- (setq package--downloads-in-progress package-archives)
+ (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" async)
+ (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))))))
Optional argument ASYNC specifies whether to perform the
downloads in the background."
(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)))
+ data-directory))
+ (inhibit-message async))
(when (and package-check-signature (file-exists-p default-keyring))
(condition-case-unless-debug error
(progn
unless (memq name dep-list)
collect name)))
+(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--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))))
+ (package--save-selected-packages (package--find-non-dependencies)))
(memq pkg package-selected-packages))
(defun package--get-deps (pkg &optional only)
unless (memq p needed)
collect p)))
-(defun package--used-elsewhere-p (pkg-desc &optional pkg-list)
+(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.
+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)))
- (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))))))
+ (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.
(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-desc-suffix pkg-desc))))
(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)))))
+ (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-installed-p (package &optional min-version)
"Return true if PACKAGE, of MIN-VERSION or newer, is installed.
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.
(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))))))
+ (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.
;; 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
(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)
;; 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)))
;; 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.
(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)))
(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 ")
(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
(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))))
(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
map)
"Local keymap for `package-menu-mode' buffers.")
-(defvar-local package-menu--new-package-list nil
+(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>
\\{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)
((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-mode-map> \\[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'.
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.
"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))
"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)
(`"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.
(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.
(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)))
(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")
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))
+ (cons (package-desc-priority pkg-desc)
(package-desc-version pkg-desc)))
(defun package-menu--find-upgrades ()
(length upgrades)
(if (= (length upgrades) 1) "" "s")))))
+(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.
Packages marked for installation are downloaded and installed;
((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)))
(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)
((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)
(string< (or (package-desc-archive (car A)) "")
(or (package-desc-archive (car B)) "")))
-(defvar-local package-menu--old-archive-contents nil
- "`package-archive-contents' before the latest refresh.")
-
(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'."
(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' is done.
-It goes in `package--post-download-archives-hook', so that it
-works with async refresh as well."
+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)
(revert-buffer nil 'noconfirm))))
(package-menu--find-and-notify-upgrades))
-(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
- :group 'package)
-
;;;###autoload
(defun list-packages (&optional no-fetch)
"Display a list of packages.
(add-hook 'package--post-download-archives-hook
#'package-menu--post-refresh)
- (unless no-fetch
- (setq package-menu--old-archive-contents package-archive-contents)
- (setq package-menu--new-package-list nil)
- ;; Fetch the remote list of packages.
- (package-refresh-contents package-menu-async))
-
;; Generate the Package Menu.
(let ((buf (get-buffer-create "*Packages*")))
(with-current-buffer buf
(package-menu-mode)
- (package-menu--generate nil t))
+
+ ;; Fetch the remote list of packages.
+ (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)))
(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.