diff options
Diffstat (limited to 'lisp/emacs-lisp/package.el')
| -rw-r--r-- | lisp/emacs-lisp/package.el | 646 |
1 files changed, 416 insertions, 230 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2fb54f0d944..6fecd9a837d 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -185,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) @@ -203,7 +202,6 @@ 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") (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) @@ -222,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-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. @@ -235,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 @@ -263,7 +284,6 @@ 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") (defcustom package-user-dir (locate-user-emacs-file "elpa") @@ -273,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 @@ -291,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) @@ -309,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 @@ -325,14 +341,21 @@ 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. @@ -467,6 +490,10 @@ This is, approximately, the inverse of `version-to-list'. (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)) @@ -560,9 +587,10 @@ updates `package-alist'." (dolist (dir (cons package-user-dir package-directory-list)) (when (file-directory-p dir) (dolist (subdir (directory-files dir)) - (let ((pkg-dir (expand-file-name subdir dir))) - (when (file-directory-p pkg-dir) - (package-load-descriptor pkg-dir))))))) + (unless (equal subdir "..") + (let ((pkg-dir (expand-file-name subdir dir))) + (when (file-directory-p pkg-dir) + (package-load-descriptor pkg-dir)))))))) (defun define-package (_name-string _version-string &optional _docstring _requirements @@ -867,7 +895,7 @@ untar into a directory named DIR; otherwise, signal an error." ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) ;; Silence `autoload-generate-file-autoloads'. - (noninteractive package--silence) + (noninteractive inhibit-message) (backup-inhibited t) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) @@ -887,10 +915,13 @@ untar into a directory named DIR; otherwise, signal an error." ) ;;;; 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) @@ -928,7 +959,7 @@ is wrapped around any parts requiring it." 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. @@ -1050,7 +1081,7 @@ The return result is a `package-desc'." (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) @@ -1107,7 +1138,8 @@ arguments see `package--with-work-buffer'." (signal (cdar status) (cddr status))) (goto-char (point-min)) (unless (search-forward "\n\n" nil 'noerror) - (error "Invalid url response")) + (error "Invalid url response in buffer %s" + (current-buffer))) (delete-region (point-min) (point)) ,@body) (kill-buffer (current-buffer))) @@ -1283,7 +1315,8 @@ 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 ((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" @@ -1315,6 +1348,9 @@ If successful, set `package-archive-contents'." ;; 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. @@ -1324,7 +1360,11 @@ If `user-init-file' does not mention `(package-initialize)', add it to the file." (interactive) (setq package-alist nil) - (package--ensure-init-file) + (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 @@ -1347,16 +1387,6 @@ it to the file." (declare-function epg-configuration "epg-config" ()) (declare-function epg-import-keys-from-file "epg" (context keys)) -(defvar package--silence nil) - -(defun package--message (format &rest args) - "Like `message', except sometimes don't print to minibuffer. -If the variable `package--silence' is non-nil, the message is not -displayed on the minibuffer." - (apply #'message format args) - (when package--silence - (message nil))) - ;;;###autoload (defun package-import-keyring (&optional file) "Import keys from FILE." @@ -1367,9 +1397,9 @@ displayed on the minibuffer." (with-file-modes 448 (make-directory homedir t)) (setf (epg-context-home-directory context) homedir) - (package--message "Importing %s..." (file-name-nondirectory file)) + (message "Importing %s..." (file-name-nondirectory file)) (epg-import-keys-from-file context file) - (package--message "Importing %s...done" (file-name-nondirectory file)))) + (message "Importing %s...done" (file-name-nondirectory file)))) (defvar package--post-download-archives-hook nil "Hook run after the archive contents are downloaded. @@ -1435,9 +1465,9 @@ 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'. - (setq package--downloads-in-progress - (append package-archives - package--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 @@ -1457,19 +1487,18 @@ and make them available for download. 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)) - (package--silence async)) + (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))) + (error (message "Cannot import default keyring: %S" (cdr error)))))) + (package--download-and-read-archives async)) ;;; Dependency Management @@ -1511,7 +1540,7 @@ SEEN is used internally to detect infinite recursion." ;; we re-add it (along with its dependencies) at an earlier place ;; below (bug#16994). (if (memq already seen) ;Avoid inf-loop on dependency cycles. - (package--message "Dependency cycle going through %S" + (message "Dependency cycle going through %S" (package-desc-full-name already)) (setq packages (delq already packages)) (setq already nil)) @@ -1577,7 +1606,7 @@ Used to populate `package-selected-packages'." (defun package--save-selected-packages (value) "Set and save `package-selected-packages' to VALUE." - (let ((save-silently package--silence)) + (let ((save-silently inhibit-message)) (customize-save-variable 'package-selected-packages (setq package-selected-packages value)))) @@ -1619,21 +1648,25 @@ These are packages which are neither contained in 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. @@ -1681,30 +1714,26 @@ if all the in-between dependencies are also in PACKAGE-LIST." "Return the archive containing the package NAME." (cdr (assoc (package-desc-archive desc) package-archives))) -(defun package-install-from-archive (pkg-desc &optional async callback) - "Download and install a tar package. -If ASYNC is non-nil, perform the download asynchronously. -If CALLBACK is non-nil, call it with no arguments once the -operation is done." +(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-async location file async + (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. - (progn (let ((save-silently async)) - (package-unpack pkg-desc)) - (funcall callback)) + (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 async + 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)) @@ -1714,7 +1743,7 @@ operation is done." (package-desc-name pkg-desc))) ;; Signature checked, unpack now. (with-temp-buffer (insert content) - (let ((save-silently async)) + (let ((save-silently t)) (package-unpack pkg-desc))) ;; Here the package has been installed successfully, mark it as ;; signed if appropriate. @@ -1730,9 +1759,7 @@ operation is done." (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))) - (when (functionp callback) - (funcall callback))))))))) + (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. @@ -1753,30 +1780,24 @@ If PACKAGE is a package-desc object, MIN-VERSION is ignored." ;; Also check built-in packages. (package-built-in-p package min-version)))) -(defun package-download-transaction (packages &optional async callback) +(defun package-download-transaction (packages) "Download and install all the packages in PACKAGES. PACKAGES should be a list of package-desc. -If ASYNC is non-nil, perform the downloads asynchronously. -If CALLBACK is non-nil, call it with no arguments once the -entire operation is done. - This function assumes that all package requirements in PACKAGES are satisfied, i.e. that PACKAGES is computed using `package-compute-transaction'." - (cond - (packages (package-install-from-archive - (car packages) - async - (lambda () - (package-download-transaction (cdr packages)) - (when (functionp callback) - (funcall callback))))) - (callback (funcall callback)))) + (mapc #'package-install-from-archive packages)) (defun package--ensure-init-file () - "Ensure that the user's init file calls `package-initialize'." + "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 user-init-file + (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 @@ -1786,6 +1807,7 @@ using `package-compute-transaction'." (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)) @@ -1798,7 +1820,11 @@ using `package-compute-transaction'." (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" @@ -1809,19 +1835,17 @@ using `package-compute-transaction'." (let ((file-precious-flag t)) (save-buffer)) (unless buffer - (kill-buffer (current-buffer)))))))))) + (kill-buffer (current-buffer))))))))) + (setq package--init-file-ensured t)) ;;;###autoload -(defun package-install (pkg &optional dont-select async callback) +(defun package-install (pkg &optional dont-select) "Install the package PKG. PKG can be a package-desc or the package name of one the available packages in an archive in `package-archives'. Interactively, prompt for its name. If called interactively or if DONT-SELECT nil, add PKG to `package-selected-packages'. -If ASYNC is non-nil, perform the downloads asynchronously. -If CALLBACK is non-nil, call it with no arguments once the -entire operation is done. If PKG is a package-desc and it is already installed, don't try to install it but still mark it as selected." @@ -1854,8 +1878,8 @@ to install it but still mark it as selected." (package-compute-transaction (list pkg) (package-desc-reqs pkg))) (package-compute-transaction () (list (list pkg)))))) - (package-download-transaction transaction async callback) - (package--message "`%s' is already installed" (package-desc-full-name 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. @@ -1923,7 +1947,7 @@ The file can either be a tar file or an Emacs Lisp file." (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) @@ -1985,7 +2009,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. @@ -1997,7 +2021,7 @@ If NOSAVE is non-nil, the package is not removed from (delete pkg-desc pkgs) (unless (cdr pkgs) (setq package-alist (delq pkgs package-alist)))) - (package--message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) + (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))))) ;;;###autoload (defun package-reinstall (pkg) @@ -2085,6 +2109,7 @@ will be deleted." (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))) @@ -2113,20 +2138,27 @@ will be deleted." "Installed" (capitalize status)) ;FIXME: Why comment-face? 'font-lock-face 'font-lock-comment-face)) - (insert " in `") + (insert " in ‘") ;; Todo: Add button for uninstalling. (help-insert-xref-button (abbreviate-file-name (file-name-as-directory pkg-dir)) 'help-package-def pkg-dir) (if (and (package-built-in-p name) (not (package-built-in-p name version))) - (insert "',\n shadowing a " + (insert "’,\n shadowing a " (propertize "built-in package" 'font-lock-face 'font-lock-builtin-face)) - (insert "'")) + (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 ") @@ -2170,6 +2202,19 @@ will be deleted." (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 @@ -2257,6 +2302,14 @@ will be deleted." (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)))) @@ -2290,6 +2343,7 @@ will be deleted." (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 @@ -2347,12 +2401,17 @@ will be deleted." (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")) + (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) @@ -2426,28 +2485,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-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'. @@ -2455,47 +2570,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. @@ -2534,12 +2648,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)) @@ -2567,11 +2683,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) @@ -2580,21 +2705,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. @@ -2629,7 +2756,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))) @@ -2657,7 +2784,7 @@ If optional arg BUTTON is non-nil, describe its associated package." (defvar package--quick-help-keys '(("install," "delete," "unmark," ("execute" . 1)) ("next," "previous") - ("refresh-contents," "g-redisplay," "filter," "help"))) + ("refresh-contents," "g-redisplay," "filter," "(-toggle-obsolete" "help"))) (defun package--prettify-quick-help-key (desc) "Prettify DESC to be displayed as a help menu." @@ -2685,7 +2812,7 @@ The full list of keys can be viewed with \\[describe-mode]." (defun package-menu-get-status () (let* ((id (tabulated-list-get-id)) - (entry (and id (assq id tabulated-list-entries)))) + (entry (and id (assoc id tabulated-list-entries)))) (if entry (aref (cadr entry) 2) ""))) @@ -2705,8 +2832,7 @@ defaults to 0." 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 () @@ -2730,15 +2856,15 @@ consideration." (push (cons name avail-pkg) upgrades)))) upgrades)) -(defun package-menu-mark-upgrades () +(defvar package-menu--mark-upgrades-pending nil + "Whether mark-upgrades is waiting for a refresh to finish.") + +(defun package-menu--mark-upgrades-1 () "Mark all upgradable packages in the Package Menu. -For each installed package with a newer version available, place -an (I)nstall flag on the available version and a (D)elete flag on -the installed version. A subsequent \\[package-menu-execute] -call will upgrade the package." - (interactive) +Implementation of `package-menu-mark-upgrades'." (unless (derived-mode-p 'package-menu-mode) (error "The current buffer is not a Package Menu")) + (setq package-menu--mark-upgrades-pending nil) (let ((upgrades (package-menu--find-upgrades))) (if (null upgrades) (message "No packages to upgrade.") @@ -2755,8 +2881,24 @@ call will upgrade the package." (t (package-menu-mark-delete)))))) (message "%d package%s marked for upgrading." - (length upgrades) - (if (= (length upgrades) 1) "" "s"))))) + (length upgrades) + (if (= (length upgrades) 1) "" "s"))))) + +(defun package-menu-mark-upgrades () + "Mark all upgradable packages in the Package Menu. +For each installed package with a newer version available, place +an (I)nstall flag on the available version and a (D)elete flag on +the installed version. A subsequent \\[package-menu-execute] +call will upgrade the package. + +If there's an async refresh operation in progress, the flags will +be placed as part of `package-menu--post-refresh' instead of +immediately." + (interactive) + (if (not package--downloads-in-progress) + (package-menu--mark-upgrades-1) + (setq package-menu--mark-upgrades-pending t) + (message "Waiting for refresh to finish..."))) (defun package-menu--list-to-prompt (packages) "Return a string listing PACKAGES that's usable in a prompt. @@ -2775,57 +2917,77 @@ prompt (see `package-menu--prompt-transaction-p')." (t (format "package `%s'" (package-desc-full-name (car packages)))))) -(defun package-menu--prompt-transaction-p (install delete) - "Prompt the user about installing INSTALL and deleting DELETE. -INSTALL and DELETE are lists of `package-desc'. Either may be -nil, but not both." +(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))) - (y-or-n-p - (concat - (when del "Delete ") - (package-menu--list-to-prompt del) - (when (and del ins) - (if upg "; " "; and ")) - (when ins "Install ") - (package-menu--list-to-prompt ins) - (when (and upg (or ins del)) "; and ") - (when upg "Upgrade ") - (package-menu--list-to-prompt upg) - "? ")))) - -(defun package-menu--perform-transaction (install-list delete-list &optional async) - "Install packages in INSTALL-LIST and delete DELETE-LIST. -If ASYNC is non-nil, perform the installation downloads -asynchronously." - ;; While there are packages to install, call `package-install' on - ;; the next one and defer deletion to the callback function. + `((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* ((pkg (car install-list)) - (rest (cdr install-list)) - ;; Don't mark as selected if it's a new version of an - ;; installed package. - (dont-mark (and (not (package-installed-p pkg)) - (package-installed-p - (package-desc-name pkg))))) - (package-install - pkg dont-mark async - (lambda () (package-menu--perform-transaction rest delete-list async)))) + (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--silence async)) + (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 - (package-delete elt) - (error (message (cadr err))))) - (when package-selected-packages - (when-let ((removable (package--removable-packages))) - (package--message "These %d packages are no longer needed, type `M-x package-autoremove' to remove them (%s)" - (length removable) - (mapconcat #'symbol-name removable ", "))))) - (message "Transaction done") - (package-menu--post-refresh))) + (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. @@ -2850,12 +3012,30 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (forward-line))) (unless (or delete-list install-list) (user-error "No operations specified")) - (when (or noquery - (package-menu--prompt-transaction-p install-list delete-list)) - (message "Transaction started") - ;; This calls `package-menu--generate' after everything's done. - (package-menu--perform-transaction - install-list delete-list package-menu-async)))) + (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))) @@ -2871,8 +3051,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) @@ -2881,6 +3064,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) @@ -2904,9 +3089,6 @@ 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)) ""))) -(defvar 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'." @@ -2934,15 +3116,11 @@ after `package-menu--perform-transaction'." (let ((buf (get-buffer "*Packages*"))) (when (buffer-live-p buf) (with-current-buffer 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. -This includes refreshing archive contents as well as installing -packages." - :type 'boolean - :group 'package) + (run-hooks 'tabulated-list-revert-hook) + (tabulated-list-print 'remember 'update) + (if package-menu--mark-upgrades-pending + (package-menu--mark-upgrades-1) + (package-menu--find-and-notify-upgrades)))))) ;;;###autoload (defun list-packages (&optional no-fetch) @@ -3002,9 +3180,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. |