diff options
Diffstat (limited to 'lisp/emacs-lisp/package.el')
| -rw-r--r-- | lisp/emacs-lisp/package.el | 1383 |
1 files changed, 951 insertions, 432 deletions
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 5203e74dc64..885fb00ce75 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -161,9 +161,12 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'epg)) ;For setf accessors. (require 'tabulated-list) +(require 'macroexp) (defgroup package nil "Manager for Emacs Lisp packages." @@ -226,6 +229,23 @@ a package can run arbitrary code." :group 'package :version "24.1") +(defcustom package-archive-priorities nil + "An alist of priorities for packages. + +Each element has the form (ARCHIVE-ID . PRIORITY). + +When installing packages, the package with the highest version +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." + :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 "An alist of packages that are pinned to specific archives. This can be useful if you have multiple package archives enabled, @@ -276,8 +296,8 @@ packages in `package-directory-list'." (let (result) (dolist (f load-path) (and (stringp f) - (equal (file-name-nondirectory f) "site-lisp") - (push (expand-file-name "elpa" f) result))) + (equal (file-name-nondirectory f) "site-lisp") + (push (expand-file-name "elpa" f) result))) (nreverse result)) "List of additional directories containing Emacs Lisp packages. Each directory name should be absolute. @@ -289,6 +309,8 @@ contrast, `package-user-dir' contains packages for personal use." :group 'package :version "24.1") +(defvar epg-gpg-program) + (defcustom package-check-signature (if (progn (require 'epg-config) (executable-find epg-gpg-program)) 'allow-unsigned) @@ -299,8 +321,8 @@ it is unsigned. This also applies to the \"archive-contents\" file that lists the contents of the archive." :type '(choice (const nil :tag "Never") - (const allow-unsigned :tag "Allow unsigned") - (const t :tag "Check always")) + (const allow-unsigned :tag "Allow unsigned") + (const t :tag "Check always")) :risky t :group 'package :version "24.4") @@ -312,6 +334,20 @@ contents of the archive." :group 'package :version "24.4") +(defcustom package-selected-packages nil + "Store here packages installed explicitly by user. +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'. + +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)) + (defvar package--default-summary "No description available.") (cl-defstruct (package-desc @@ -355,20 +391,20 @@ Slots: `version' Version of the package, as a version list. `summary' Short description of the package, typically taken from - the first line of the file. + the first line of the file. `reqs' Requirements of the package. A list of (PACKAGE - VERSION-LIST) naming the dependent package and the minimum - required version. + VERSION-LIST) naming the dependent package and the minimum + required version. `kind' The distribution format of the package. Currently, it is - either `single' or `tar'. + either `single' or `tar'. `archive' The name of the archive (as a string) whence this - package came. + package came. `dir' The directory where the package is installed (if installed), - `builtin' if it is built-in, or nil otherwise. + `builtin' if it is built-in, or nil otherwise. `extras' Optional alist of additional keyword-value pairs. @@ -393,6 +429,7 @@ Slots: (pcase (package-desc-kind pkg-desc) (`single ".el") (`tar ".tar") + (`dir "") (kind (error "Unknown package kind: %s" kind)))) (defun package-desc--keywords (pkg-desc) @@ -430,6 +467,19 @@ 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.") @@ -444,32 +494,32 @@ This is, approximately, the inverse of `version-to-list'. "" (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") + (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)))) + str-list)))) (if (equal "." (car str-list)) - (pop str-list)) + (pop str-list)) (apply 'concat (nreverse str-list))))) (defun package-load-descriptor (pkg-dir) "Load the description file in directory PKG-DIR." (let ((pkg-file (expand-file-name (package--description-file pkg-dir) pkg-dir)) - (signed-file (concat pkg-dir ".signed"))) + (signed-file (concat pkg-dir ".signed"))) (when (file-exists-p pkg-file) (with-temp-buffer (insert-file-contents pkg-file) @@ -477,8 +527,8 @@ This is, approximately, the inverse of `version-to-list'. (let ((pkg-desc (package-process-define-package (read (current-buffer)) pkg-file))) (setf (package-desc-dir pkg-desc) pkg-dir) - (if (file-exists-p signed-file) - (setf (package-desc-signed pkg-desc) t)) + (if (file-exists-p signed-file) + (setf (package-desc-signed pkg-desc) t)) pkg-desc))))) (defun package-load-all-descriptors () @@ -512,23 +562,39 @@ 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-activate-1 (pkg-desc) +(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 +correspond to previously loaded files (those returned by +`package--list-loaded-files')." (let* ((name (package-desc-name pkg-desc)) - (pkg-dir (package-desc-dir pkg-desc)) + (pkg-dir (package-desc-dir pkg-desc)) (pkg-dir-dir (file-name-as-directory pkg-dir))) (unless pkg-dir (error "Internal error: unable to find directory for `%s'" - (package-desc-full-name pkg-desc))) + (package-desc-full-name pkg-desc))) ;; Add to load path, add autoloads, and activate the package. - (let ((old-lp load-path)) - (with-demoted-errors - (load (expand-file-name (format "%s-autoloads" name) pkg-dir) nil t)) + (let* ((old-lp load-path) + (autoloads-file (expand-file-name + (format "%s-autoloads" name) pkg-dir)) + (loaded-files-list (and reload (package--list-loaded-files pkg-dir)))) + (with-demoted-errors "Error in package-activate-1: %s" + (load autoloads-file nil t)) (when (and (eq old-lp load-path) (not (or (member pkg-dir load-path) (member pkg-dir-dir load-path)))) ;; Old packages don't add themselves to the `load-path', so we have to ;; do it ourselves. - (push pkg-dir load-path))) + (push pkg-dir load-path)) + ;; Call `load' on all files in `pkg-dir' already present in + ;; `load-history'. This is done so that macros in these files are updated + ;; to their new definitions. If another package is being installed which + ;; depends on this new definition, not doing this update would cause + ;; compilation errors and break the installation. + (with-demoted-errors "Error in package-activate-1: %s" + (mapc (lambda (feature) (load feature nil t)) + ;; Skip autoloads file since we already evaluated it above. + (remove (file-truename autoloads-file) loaded-files-list)))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -539,6 +605,41 @@ Return the max version (as a string) if the package is held at a lower version." ;; Don't return nil. 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 +DIR, sorted by most recently loaded last." + (let* ((history (delq nil + (mapcar (lambda (x) + (let ((f (car x))) + (and f (file-name-sans-extension f)))) + load-history))) + (dir (file-truename dir)) + ;; List all files that have already been loaded. + (list-of-conflicts + (delq + nil + (mapcar + (lambda (x) (let* ((file (file-relative-name x dir)) + ;; Previously loaded file, if any. + (previous + (ignore-errors + (file-name-sans-extension + (file-truename (find-library-name file))))) + (pos (when previous (member previous history)))) + ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) + (when pos + (cons (file-name-sans-extension file) (length pos))))) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'"))))) + ;; Turn the list of (FILENAME . POS) back into a list of features. Files in + ;; subdirectories are returned relative to DIR (so not actually features). + (let ((default-directory (file-name-as-directory dir))) + (mapcar (lambda (x) (file-truename (car x))) + (sort list-of-conflicts + ;; 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 @@ -588,14 +689,14 @@ If FORCE is true, (re-)activate it if it's already activated." (fail (catch 'dep-failure ;; Activate its dependencies recursively. (dolist (req (package-desc-reqs pkg-vec)) - (unless (package-activate (car req) (cadr req)) + (unless (package-activate (car req)) (throw 'dep-failure req)))))) - (if fail - (warn "Unable to activate package `%s'. + (if fail + (warn "Unable to activate package `%s'. Required package `%s-%s' is unavailable" - package (car fail) (package-version-join (cadr fail))) - ;; If all goes well, activate the package itself. - (package-activate-1 pkg-vec))))))) + package (car fail) (package-version-join (cadr fail))) + ;; If all goes well, activate the package itself. + (package-activate-1 pkg-vec force))))))) (defun define-package (_name-string _version-string &optional _docstring _requirements @@ -638,17 +739,17 @@ EXTRA-PROPERTIES is currently unused." (unless (file-exists-p file) (write-region (concat ";;; " (file-name-nondirectory file) - " --- automatically extracted autoloads\n" - ";;\n" - ";;; Code:\n" + " --- 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") + " \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) @@ -657,9 +758,10 @@ EXTRA-PROPERTIES is currently unused." (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)) - (version-control 'never)) + ;;(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))) @@ -679,15 +781,15 @@ untar into a directory named DIR; otherwise, signal an error." (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) - (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) + (case-fold-search (memq system-type '(windows-nt ms-dos cygwin)))) (dolist (tar-data tar-parse-info) (let ((name (expand-file-name (tar-header-name tar-data)))) - (or (string-match regexp name) - ;; Tarballs created by some utilities don't list - ;; directories with a trailing slash (Bug#13136). - (and (string-equal dir name) - (eq (tar-header-link-type tar-data) 5)) - (error "Package does not untar cleanly into directory %s/" dir))))) + (or (string-match regexp name) + ;; Tarballs created by some utilities don't list + ;; directories with a trailing slash (Bug#13136). + (and (string-equal dir name) + (eq (tar-header-link-type tar-data) 5)) + (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -698,6 +800,7 @@ untar into a directory named DIR; otherwise, signal an error." (print-length nil)) (write-region (concat + ";;; -*- no-byte-compile: t -*-\n" (prin1-to-string (nconc (list 'define-package @@ -718,21 +821,29 @@ untar into a directory named DIR; otherwise, signal an error." nil pkg-file nil 'silent)))) (defun package--alist-to-plist-args (alist) - (mapcar (lambda (x) - (if (and (not (consp x)) - (or (keywordp x) - (not (symbolp x)) - (memq x '(nil t)))) - x `',x)) + (mapcar 'macroexp-quote (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))) - (defun package-unpack (pkg-desc) "Install the contents of the current buffer as a package." (let* ((name (package-desc-name pkg-desc)) (dirname (package-desc-full-name pkg-desc)) - (pkg-dir (expand-file-name dirname package-user-dir))) + (pkg-dir (expand-file-name dirname package-user-dir))) (pcase (package-desc-kind pkg-desc) + (`dir + (make-directory pkg-dir t) + (let ((file-list + (directory-files + default-directory 'full "\\`[^.].*\\.el\\'" 'nosort))) + (dolist (source-file file-list) + (let ((target-el-file + (expand-file-name (file-name-nondirectory source-file) pkg-dir))) + (copy-file source-file target-el-file t))) + ;; Now that the files have been installed, this package is + ;; indistinguishable from a `tar' or a `single'. Let's make + ;; things simple by ensuring we're one of them. + (setf (package-desc-kind pkg-desc) + (if (> (length file-list) 1) 'tar 'single)))) (`tar (make-directory package-user-dir t) ;; FIXME: should we delete PKG-DIR if it exists? @@ -786,33 +897,44 @@ buffer is killed afterwards. Return the last value in BODY." (declare (indent 2) (debug t)) `(with-temp-buffer (if (string-match-p "\\`https?:" ,location) - (url-insert-file-contents (concat ,location ,file)) + (url-insert-file-contents (concat ,location ,file)) (unless (file-name-absolute-p ,location) - (error "Archive location %s is not an absolute file name" - ,location)) + (error "Archive location %s is not an absolute file name" + ,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))) + (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-context-set-home-directory "epg" (context directory)) + (&optional protocol armor textmode include-certs + cipher-algorithm + digest-algorithm + compress-algorithm)) (declare-function epg-verify-string "epg" (context signature - &optional signed-text)) + &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)) +(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)))))) + (defun package--check-signature (location file) "Check signature of the current buffer. GnuPG keyring is located under \"gnupg\" in `package-user-dir'." @@ -820,77 +942,89 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (homedir (expand-file-name "gnupg" package-user-dir)) (sig-file (concat file ".sig")) (sig-content (package--with-work-buffer location sig-file - (buffer-string)))) - (epg-context-set-home-directory context homedir) - (epg-verify-string context sig-content (buffer-string)) + (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)))) - (if (and (null good-signatures) had-fatal-error) - (error "Failed to verify signature %s: %S" - sig-file - (mapcar #'epg-signature-to-string - (epg-context-result-for context 'verify))) - good-signatures)))) + (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-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) + (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))))) + (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 + (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))))) + (setf (package-desc-signed (car pkg-descs)) t))))) (defvar package--initialized nil) (defun package-installed-p (package &optional min-version) "Return true if PACKAGE, of MIN-VERSION or newer, is installed. -MIN-VERSION should be a version list." +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!")) - (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))) + (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-compute-transaction (packages requirements &optional seen) "Return a list of packages to be installed, including PACKAGES. @@ -914,7 +1048,7 @@ SEEN is used internally to detect infinite recursion." ;; older bar-1.3). (dolist (elt requirements) (let* ((next-pkg (car elt)) - (next-version (cadr elt)) + (next-version (cadr elt)) (already ())) (dolist (pkg packages) (if (eq next-pkg (package-desc-name pkg)) @@ -938,9 +1072,9 @@ SEEN is used internally to detect infinite recursion." ((package-installed-p next-pkg next-version) nil) (t - ;; A package is required, but not installed. It might also be - ;; blocked via `package-load-list'. - (let ((pkg-descs (cdr (assq next-pkg package-archive-contents))) + ;; A package is required, but not installed. It might also be + ;; blocked via `package-load-list'. + (let ((pkg-descs (cdr (assq next-pkg package-archive-contents))) (found nil) (problem nil)) (while (and pkg-descs (not found)) @@ -964,14 +1098,14 @@ but version %s required" (format "Required package '%s' is disabled" next-pkg))))) (t (setq found pkg-desc))))) - (unless found + (unless found (if problem (error "%s" problem) (error "Package `%s-%s' is unavailable" next-pkg (package-version-join next-version)))) - (setq packages - (package-compute-transaction (cons found packages) - (package-desc-reqs found) + (setq packages + (package-compute-transaction (cons found packages) + (package-desc-reqs found) (cons found seen)))))))) packages) @@ -979,13 +1113,13 @@ but version %s required" "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)))) + (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)))) @@ -997,12 +1131,12 @@ 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)))))) + (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-read-all-archive-contents () "Re-read `archive-contents', if it exists. @@ -1018,10 +1152,10 @@ 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))) + (contents (package--read-archive-file contents-file))) (when contents (dolist (package contents) - (package--add-to-archive-contents package archive))))) + (package--add-to-archive-contents package archive))))) ;; Package descriptor objects used inside the "archive-contents" file. ;; Changing this defstruct implies changing the format of the @@ -1050,23 +1184,45 @@ Also, add the originating archive to the `package-desc' structure." ;; Older archive-contents files have only 4 ;; elements here. (package--ac-desc-extras (cdr package))))) - (existing-packages (assq name package-archive-contents)) (pinned-to-archive (assoc name package-pinned-packages))) - (cond - ;; Skip entirely if pinned to another archive. - ((and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive))) - nil) - ((not existing-packages) - (push (list name pkg-desc) package-archive-contents)) - (t - (while - (if (and (cdr existing-packages) - (version-list-< - version (package-desc-version (cadr existing-packages)))) - (setq existing-packages (cdr existing-packages)) - (push pkg-desc (cdr existing-packages)) - nil)))))) + ;; 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--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--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-download-transaction (packages) "Download and install all the packages in PACKAGES. @@ -1077,10 +1233,16 @@ using `package-compute-transaction'." (mapc #'package-install-from-archive packages)) ;;;###autoload -(defun package-install (pkg) +(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." +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 PKG is a package-desc and it is already installed, don't try +to install it but still mark it as selected." (interactive (progn ;; Initialize the package system to get the list of package @@ -1096,14 +1258,38 @@ in an archive in `package-archives'. Interactively, prompt for its name." (unless (package-installed-p (car elt)) (symbol-name (car elt)))) package-archive-contents)) - nil t))))) - (package-download-transaction - (if (package-desc-p pkg) - (package-compute-transaction (list pkg) - (package-desc-reqs pkg)) + nil t)) + nil))) + (let ((name (if (package-desc-p 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)))))) +;;;###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)) + (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -1112,8 +1298,8 @@ Otherwise return nil." (when (string-match "\\`[ \t]*[$]Revision:[ \t]+" str) (setq str (substring str (match-end 0)))) (condition-case nil - (if (version-to-list str) - str) + (if (version-to-list str) + str) (error nil)))) (declare-function lm-homepage "lisp-mnt" (&optional file)) @@ -1147,8 +1333,8 @@ boundaries." (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))) + (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. @@ -1157,15 +1343,15 @@ boundaries." (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")))) + ;; 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")) + (error + "Package lacks a \"Version\" or \"Package-Version\" header")) (package-desc-from-define file-name pkg-version desc (if requires-str @@ -1188,36 +1374,85 @@ The return result is a `package-desc'." (unless tar-desc (error "No package descriptor file found")) (with-current-buffer (tar--extract tar-desc) - (goto-char (point-min)) (unwind-protect - (let* ((pkg-def-parsed (read (current-buffer))) - (pkg-desc - (if (not (eq (car pkg-def-parsed) 'define-package)) - (error "Can't find define-package in %s" - (tar-header-name tar-desc)) - (apply #'package-desc-from-define - (append (cdr pkg-def-parsed)))))) - (setf (package-desc-kind pkg-desc) 'tar) - pkg-desc) + (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. -The current buffer is assumed to be a single .el or .tar file that follows the -packaging guidelines; see info node `(elisp)Packaging'. +The current buffer is assumed to be a single .el or .tar file or +a directory. These must follow the packaging guidelines (see +info node `(elisp)Packaging'). + +Specially, if current buffer is a directory, the -pkg.el +description file is not mandatory, in which case the information +is derived from the main .el file in the directory. + Downloads and installs required packages as needed." (interactive) - (let ((pkg-desc (if (derived-mode-p 'tar-mode) - (package-tar-file-info) - (package-buffer-info)))) + (let* ((pkg-desc + (cond + ((derived-mode-p 'dired-mode) + ;; This is the only way a package-desc object with a `dir' + ;; desc-kind can be created. Such packages can't be + ;; uploaded or installed from archives, they can only be + ;; installed from local buffers or directories. + (package-dir-info)) + ((derived-mode-p 'tar-mode) + (package-tar-file-info)) + (t + (package-buffer-info)))) + (name (package-desc-name pkg-desc))) ;; Download and install the dependencies. (let* ((requires (package-desc-reqs pkg-desc)) (transaction (package-compute-transaction nil requires))) (package-download-transaction transaction)) ;; 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))) pkg-desc)) ;;;###autoload @@ -1226,68 +1461,215 @@ Downloads and installs required packages as needed." The file can either be a tar file or an Emacs Lisp file." (interactive "fPackage file name: ") (with-temp-buffer - (insert-file-contents-literally file) - (when (string-match "\\.tar\\'" file) (tar-mode)) + (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-delete (pkg-desc) - (let ((dir (package-desc-dir pkg-desc))) - (if (not (string-prefix-p (file-name-as-directory - (expand-file-name package-user-dir)) - (expand-file-name dir))) - ;; Don't delete "system" packages. - (error "Package `%s' is a system package, not deleting" - (package-desc-full-name pkg-desc)) - (delete-directory dir t t) - ;; Remove NAME-VERSION.signed file. - (let ((signed-file (concat dir ".signed"))) - (if (file-exists-p signed-file) - (delete-file signed-file))) - ;; Update package-alist. - (let* ((name (package-desc-name pkg-desc)) - (pkgs (assq name package-alist))) - (delete pkg-desc pkgs) - (unless (cdr pkgs) - (setq package-alist (delq pkgs package-alist)))) - (message "Package `%s' deleted." (package-desc-full-name pkg-desc))))) +(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-user-selected-packages () + "Ensure packages in `package-selected-packages' are installed. +If some packages are not installed propose to install them." + (interactive) + ;; We don't need to populate `package-selected-packages' before + ;; using here, because the outcome is the same either way (nothing + ;; gets installed). + (if (not package-selected-packages) + (message "`package-selected-packages' is empty, nothing to install") + (cl-loop for p in package-selected-packages + unless (package-installed-p p) + collect p into lst + finally + (if lst + (when (y-or-n-p + (format "%s packages will be installed:\n%s, proceed?" + (length lst) + (mapconcat #'symbol-name lst ", "))) + (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)))))) + +(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)) + pkg)) + +(defun package-delete (pkg-desc &optional force nosave) + "Delete package PKG-DESC. + +Argument PKG-DESC is a full description of package as vector. +When package is used elsewhere as dependency of another package, +refuse deleting it and return an error. +If FORCE is non-nil package will be deleted even if it is used +elsewhere. +If NOSAVE is non-nil, the package is not removed from +`package-selected-packages'." + (let ((dir (package-desc-dir pkg-desc)) + (name (package-desc-name pkg-desc)) + pkg-used-elsewhere-by) + ;; If the user is trying to delete this package, they definitely + ;; don't want it marked as selected, so we remove it from + ;; `package-selected-packages' even if it can't be deleted. + (when (and (null nosave) + (package--user-selected-p name) + ;; 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))) + (cond ((not (string-prefix-p (file-name-as-directory + (expand-file-name package-user-dir)) + (expand-file-name dir))) + ;; Don't delete "system" packages. + (error "Package `%s' is a system package, not deleting" + (package-desc-full-name pkg-desc))) + ((and (null force) + (setq pkg-used-elsewhere-by + (package--used-elsewhere-p pkg-desc))) + ;; 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)) + (t + (delete-directory dir t t) + ;; Remove NAME-VERSION.signed file. + (let ((signed-file (concat dir ".signed"))) + (if (file-exists-p signed-file) + (delete-file signed-file))) + ;; Update package-alist. + (let ((pkgs (assq name package-alist))) + (delete pkg-desc pkgs) + (unless (cdr pkgs) + (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-autoremove () + "Remove packages that are no more needed. + +Packages that are no more needed by other packages in +`package-selected-packages' and their dependencies +will be deleted." + (interactive) + ;; If `package-selected-packages' is nil, it would make no sense to + ;; try to populate it here, because then `package-autoremove' will + ;; do absolutely nothing. + (when (or package-selected-packages + (yes-or-no-p + "`package-selected-packages' is empty! Really remove ALL packages? ")) + (let ((removable (package--removable-packages))) + (if removable + (when (y-or-n-p + (format "%s packages will be deleted:\n%s, proceed? " + (length removable) + (mapconcat #'symbol-name removable ", "))) + (mapc (lambda (p) + (package-delete (cadr (assq p package-alist)) t)) + 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-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))))) + (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) + (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 + (expand-file-name (concat file ".signed") dir) nil 'silent)))) (declare-function epg-check-configuration "epg-config" - (config &optional minimum-version)) + (config &optional minimum-version)) (declare-function epg-configuration "epg-config" ()) (declare-function epg-import-keys-from-file "epg" (context keys)) @@ -1297,19 +1679,20 @@ similar to an entry in `package-alist'. Save the cached copy to (interactive "fFile: ") (setq file (expand-file-name file)) (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir))) - ;; FIXME Use `with-file-modes' when merged to trunk. - (let ((umask (default-file-modes))) - (unwind-protect - (progn - (set-default-file-modes 448) - (make-directory homedir t)) - (set-default-file-modes umask))) - (epg-context-set-home-directory context homedir) + (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. @@ -1320,19 +1703,35 @@ makes them available for download." (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))) (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)))))) + (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") + (package--download-one-archive archive "archive-contents") (error (message "Failed to download `%s' archive." - (car archive))))) - (package-read-all-archive-contents)) + (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) @@ -1346,7 +1745,23 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (unless no-activate (dolist (elt package-alist) (package-activate (car elt)))) - (setq package--initialized t)) + (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. @@ -1376,10 +1791,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (if (not (or (package-desc-p package) (and package (symbolp package)))) (message "No package specified") (help-setup-xref (list #'describe-package package) - (called-interactively-p 'interactive)) + (called-interactively-p 'interactive)) (with-help-window (help-buffer) (with-current-buffer standard-output - (describe-package-1 package))))) + (describe-package-1 package))))) (defun describe-package-1 (pkg) (require 'lisp-mnt) @@ -1401,7 +1816,10 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (built-in (eq pkg-dir 'builtin)) (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) + (incompatible-reason (package--incompatible-p desc)) (signed (if desc (package-desc-signed desc)))) + (when incompatible-reason + (setq status "incompatible")) (prin1 name) (princ " is ") (princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a ")) @@ -1410,64 +1828,73 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert " " (propertize "Status" 'font-lock-face 'bold) ": ") (cond (built-in - (insert (propertize (capitalize status) + (insert (propertize (capitalize status) 'font-lock-face 'font-lock-builtin-face) ".")) - (pkg-dir - (insert (propertize (if (equal status "unsigned") - "Installed" - (capitalize status)) ;FIXME: Why comment-face? - 'font-lock-face 'font-lock-comment-face)) - (insert " in `") - ;; Todo: Add button for uninstalling. - (help-insert-xref-button (abbreviate-file-name + (pkg-dir + (insert (propertize (if (member status '("unsigned" "dependency")) + "Installed" + (capitalize status)) ;FIXME: Why comment-face? + 'font-lock-face 'font-lock-comment-face)) + (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) + 'help-package-def pkg-dir) + (if (and (package-built-in-p name) (not (package-built-in-p name version))) - (insert "',\n shadowing a " - (propertize "built-in package" - 'font-lock-face 'font-lock-builtin-face)) - (insert "'")) - (if signed - (insert ".") - (insert " (unsigned)."))) - (installable + (insert "',\n shadowing a " + (propertize "built-in package" + 'font-lock-face 'font-lock-builtin-face)) + (insert "'")) + (if signed + (insert ".") + (insert " (unsigned)."))) + (incompatible-reason + (insert (propertize "Incompatible" 'face font-lock-warning-face) + " because it depends on ") + (if (stringp incompatible-reason) + (insert "Emacs " incompatible-reason ".") + (insert "uninstallable packages."))) + (installable (insert (capitalize status)) - (insert " from " (format "%s" archive)) - (insert " -- ") + (insert " from " (format "%s" archive)) + (insert " -- ") (package-make-button "Install" 'action 'package-install-button-action 'package-desc desc)) - (t (insert (capitalize status) "."))) + (t (insert (capitalize status) "."))) (insert "\n") (insert " " (propertize "Archive" 'font-lock-face 'bold) - ": " (or archive "n/a") "\n") + ": " (or archive "n/a") "\n") (and version - (insert " " - (propertize "Version" 'font-lock-face 'bold) ": " + (insert " " + (propertize "Version" 'font-lock-face 'bold) ": " (package-version-join version) "\n")) (setq reqs (if desc (package-desc-reqs desc))) (when reqs (insert " " (propertize "Requires" 'font-lock-face 'bold) ": ") - (let ((first t) - name vers text) - (dolist (req reqs) - (setq name (car req) - vers (cadr req) - text (format "%s-%s" (symbol-name name) - (package-version-join vers))) - (cond (first (setq first nil)) - ((>= (+ 2 (current-column) (length text)) - (window-width)) - (insert ",\n ")) - (t (insert ", "))) - (help-insert-xref-button text 'help-package name)) - (insert "\n"))) + (let ((first t)) + (dolist (req reqs) + (let* ((name (car req)) + (vers (cadr req)) + (text (format "%s-%s" (symbol-name name) + (package-version-join vers))) + (reason (if (and (listp incompatible-reason) + (assq name incompatible-reason)) + " (not available)" ""))) + (cond (first (setq first nil)) + ((>= (+ 2 (current-column) (length text) (length reason)) + (window-width)) + (insert ",\n ")) + (t (insert ", "))) + (help-insert-xref-button text 'help-package name) + (insert reason))) + (insert "\n"))) (insert " " (propertize "Summary" 'font-lock-face 'bold) - ": " (if desc (package-desc-summary desc)) "\n") + ": " (if desc (package-desc-summary desc)) "\n") (when homepage (insert " " (propertize "Homepage" 'font-lock-face 'bold) ": ") (help-insert-xref-button homepage 'help-url homepage) @@ -1509,23 +1936,23 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert "\n") (if built-in - ;; For built-in packages, insert the commentary. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) + ;; For built-in packages, insert the commentary. + (let ((fn (locate-file (format "%s.el" name) load-path + load-file-rep-suffixes)) + (opoint (point))) + (insert (or (lm-commentary fn) "")) + (save-excursion + (goto-char opoint) + (when (re-search-forward "^;;; Commentary:\n" nil t) + (replace-match "")) + (while (re-search-forward "^\\(;+ ?\\)" nil t) + (replace-match "")))) (let ((readme (expand-file-name (format "%s-readme.txt" name) - package-user-dir)) - readme-string) - ;; For elpa packages, try downloading the commentary. If that - ;; fails, try an existing readme file in `package-user-dir'. - (cond ((condition-case nil + package-user-dir)) + readme-string) + ;; For elpa packages, try downloading the commentary. If that + ;; fails, try an existing readme file in `package-user-dir'. + (cond ((condition-case nil (save-excursion (package--with-work-buffer (package-archive-base desc) @@ -1539,17 +1966,17 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." nil 'silent) (setq readme-string (buffer-string)) t)) - (error nil)) - (insert readme-string)) - ((file-readable-p readme) - (insert-file-contents readme) - (goto-char (point-max)))))))) + (error nil)) + (insert readme-string)) + ((file-readable-p readme) + (insert-file-contents readme) + (goto-char (point-max)))))))) (defun package-install-button-action (button) (let ((pkg-desc (button-get button 'package-desc))) (when (y-or-n-p (format "Install package `%s'? " (package-desc-full-name pkg-desc))) - (package-install pkg-desc) + (package-install pkg-desc nil) (revert-buffer nil t) (goto-char (point-min))))) @@ -1572,7 +1999,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (defvar package-menu-mode-map (let ((map (make-sparse-keymap)) - (menu-map (make-sparse-keymap "Package"))) + (menu-map (make-sparse-keymap "Package"))) (set-keymap-parent map tabulated-list-mode-map) (define-key map "\C-m" 'package-menu-describe-package) (define-key map "u" 'package-menu-mark-unmark) @@ -1589,54 +2016,54 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (define-key map [menu-bar package-menu] (cons "Package" menu-map)) (define-key menu-map [mq] '(menu-item "Quit" quit-window - :help "Quit package selection")) + :help "Quit package selection")) (define-key menu-map [s1] '("--")) (define-key menu-map [mn] '(menu-item "Next" next-line - :help "Next Line")) + :help "Next Line")) (define-key menu-map [mp] '(menu-item "Previous" previous-line - :help "Previous Line")) + :help "Previous Line")) (define-key menu-map [s2] '("--")) (define-key menu-map [mu] '(menu-item "Unmark" package-menu-mark-unmark - :help "Clear any marks on a package and move to the next line")) + :help "Clear any marks on a package and move to the next line")) (define-key menu-map [munm] '(menu-item "Unmark Backwards" package-menu-backup-unmark - :help "Back up one line and clear any marks on that package")) + :help "Back up one line and clear any marks on that package")) (define-key menu-map [md] '(menu-item "Mark for Deletion" package-menu-mark-delete - :help "Mark a package for deletion and move to the next line")) + :help "Mark a package for deletion and move to the next line")) (define-key menu-map [mi] '(menu-item "Mark for Install" package-menu-mark-install - :help "Mark a package for installation and move to the next line")) + :help "Mark a package for installation and move to the next line")) (define-key menu-map [mupgrades] '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades - :help "Mark packages that have a newer version for upgrading")) + :help "Mark packages that have a newer version for upgrading")) (define-key menu-map [s3] '("--")) (define-key menu-map [mf] '(menu-item "Filter Package List..." package-menu-filter - :help "Filter package selection (q to go back)")) + :help "Filter package selection (q to go back)")) (define-key menu-map [mg] '(menu-item "Update Package List" revert-buffer - :help "Update the list of packages")) + :help "Update the list of packages")) (define-key menu-map [mr] '(menu-item "Refresh Package List" package-menu-refresh - :help "Download the ELPA archive")) + :help "Download the ELPA archive")) (define-key menu-map [s4] '("--")) (define-key menu-map [mt] '(menu-item "Mark Obsolete Packages" package-menu-mark-obsolete-for-deletion - :help "Mark all obsolete packages for deletion")) + :help "Mark all obsolete packages for deletion")) (define-key menu-map [mx] '(menu-item "Execute Actions" package-menu-execute - :help "Perform all the marked actions")) + :help "Perform all the marked actions")) (define-key menu-map [s5] '("--")) (define-key menu-map [mh] '(menu-item "Help" package-menu-quick-help - :help "Show short key binding help for package-menu-mode")) + :help "Show short key binding help for package-menu-mode")) (define-key menu-map [mc] '(menu-item "Describe Package" package-menu-describe-package - :help "Display information about this package")) + :help "Display information about this package")) map) "Local keymap for `package-menu-mode' buffers.") @@ -1674,13 +2101,44 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package-list-unsigned nil "If non-nil, mention in the list which packages were installed w/o signature.") +(defvar package--emacs-version-list (version-to-list emacs-version) + "`emacs-version', as a list.") + +(defun package--incompatible-p (pkg &optional shallow) + "Return non-nil if PKG has no chance of being installable. +PKG is a package-desc object. + +If SHALLOW is non-nil, this only checks if PKG depends on a +higher `emacs-version' than the one being used. Otherwise, also +checks the viability of dependencies, according to +`package--compatibility-table'. + +If PKG requires an incompatible Emacs version, the return value +is this version (as a string). +If PKG requires incompatible packages, the return value is a list +of these dependencies, similar to the list returned by +`package-desc-reqs'." + (let* ((reqs (package-desc-reqs pkg)) + (version (cadr (assq 'emacs reqs)))) + (if (and version (version-list-< package--emacs-version-list version)) + (package-version-join version) + (unless shallow + (let (out) + (dolist (dep (package-desc-reqs pkg) out) + (let ((dep-name (car dep))) + (unless (eq 'emacs dep-name) + (let ((cv (gethash dep-name package--compatibility-table))) + (when (version-list-< (or cv '(0)) (or (cadr dep) '(0))) + (push dep out))))))))))) + (defun package-desc-status (pkg-desc) (let* ((name (package-desc-name pkg-desc)) (dir (package-desc-dir pkg-desc)) (lle (assq name package-load-list)) (held (cadr lle)) (version (package-desc-version pkg-desc)) - (signed (package-desc-signed pkg-desc))) + (signed (or (not package-list-unsigned) + (package-desc-signed pkg-desc)))) (cond ((eq dir 'builtin) "built-in") ((and lle (null held)) "disabled") @@ -1691,11 +2149,14 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." ((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") ((eq pkg-desc (cadr (assq name package-alist))) - (if (or (not package-list-unsigned) signed) "installed" "unsigned")) + (if (not signed) "unsigned" + (if (package--user-selected-p name) + "installed" "dependency"))) (t "obsolete"))) (t (let* ((ins (cadr (assq name package-alist))) @@ -1706,8 +2167,9 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." "new" "available")) ((version-list-< version ins-v) "obsolete") ((version-list-= version ins-v) - (if (or (not package-list-unsigned) signed) - "installed" "unsigned")))))))) + (if (not signed) "unsigned" + (if (package--user-selected-p name) + "installed" "dependency"))))))))) (defun package-menu--refresh (&optional packages keywords) "Re-populate the `tabulated-list-entries'. @@ -1731,8 +2193,8 @@ KEYWORDS should be nil or a list of keywords." (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))) + (or (eq packages t) (memq name packages))) + (package--push (package--from-builtin elt) "built-in" info-list))) ;; Available and disabled packages: (dolist (elt package-archive-contents) @@ -1777,7 +2239,7 @@ Built-in packages are converted with `package--from-builtin'." (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. (or package-list-unversioned (package--bi-desc-version (cdr elt))) - (or (eq packages t) (memq name packages))) + (or (eq packages t) (memq name packages))) (funcall function (package--from-builtin elt)))) ;; Available and disabled packages: @@ -1828,18 +2290,20 @@ shown." PKG has the form (PKG-DESC . STATUS). Return (PKG-DESC [NAME VERSION STATUS DOC])." (let* ((pkg-desc (car pkg)) - (status (cdr pkg)) - (face (pcase status + (status (cdr pkg)) + (face (pcase status (`"built-in" 'font-lock-builtin-face) (`"available" 'default) (`"new" 'bold) (`"held" 'font-lock-constant-face) (`"disabled" 'font-lock-warning-face) (`"installed" 'font-lock-comment-face) + (`"dependency" 'font-lock-comment-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)) + `[,(list (symbol-name (package-desc-name pkg-desc)) 'face 'link 'follow-link t 'package-desc pkg-desc @@ -1869,23 +2333,24 @@ This fetches the contents of each archive specified in If optional arg BUTTON is non-nil, describe its associated package." (interactive) (let ((pkg-desc (if button (button-get button 'package-desc) - (tabulated-list-get-id)))) + (tabulated-list-get-id)))) (if pkg-desc - (describe-package pkg-desc) + (describe-package pkg-desc) (user-error "No package here")))) ;; fixme numeric argument (defun package-menu-mark-delete (&optional _num) "Mark a package for deletion and move to the next line." (interactive "p") - (if (member (package-menu-get-status) '("installed" "obsolete" "unsigned")) + (if (member (package-menu-get-status) + '("installed" "dependency" "obsolete" "unsigned")) (tabulated-list-put-tag "D" t) (forward-line))) (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")) + (if (member (package-menu-get-status) '("available" "new" "dependency")) (tabulated-list-put-tag "I" t) (forward-line))) @@ -1907,8 +2372,8 @@ If optional arg BUTTON is non-nil, describe its associated package." (goto-char (point-min)) (while (not (eobp)) (if (equal (package-menu-get-status) "obsolete") - (tabulated-list-put-tag "D" t) - (forward-line 1))))) + (tabulated-list-put-tag "D" t) + (forward-line 1))))) (defun package-menu-quick-help () "Show short key binding help for package-menu-mode." @@ -1920,9 +2385,9 @@ If optional arg BUTTON is non-nil, describe its associated package." (defun package-menu-get-status () (let* ((id (tabulated-list-get-id)) - (entry (and id (assq id tabulated-list-entries)))) + (entry (and id (assq id tabulated-list-entries)))) (if entry - (aref (cadr entry) 2) + (aref (cadr entry) 2) ""))) (defun package-menu--find-upgrades () @@ -1931,19 +2396,19 @@ If optional arg BUTTON is non-nil, describe its associated package." (dolist (entry tabulated-list-entries) ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) - (status (aref (cadr entry) 2))) - (cond ((member status '("installed" "unsigned")) - (push pkg-desc installed)) - ((member status '("available" "new")) - (push (cons (package-desc-name pkg-desc) pkg-desc) - available))))) + (status (aref (cadr entry) 2))) + (cond ((member status '("installed" "dependency" "unsigned")) + (push pkg-desc installed)) + ((member status '("available" "new")) + (setq available (package--append-to-alist pkg-desc available)))))) ;; Loop through list of installed packages, finding upgrades. (dolist (pkg-desc installed) - (let ((avail-pkg (assq (package-desc-name pkg-desc) available))) - (and avail-pkg - (version-list-< (package-desc-version pkg-desc) - (package-desc-version (cdr avail-pkg))) - (push avail-pkg upgrades)))) + (let* ((name (package-desc-name pkg-desc)) + (avail-pkg (cadr (assq name available)))) + (and avail-pkg + (version-list-< (package-desc-priority-version pkg-desc) + (package-desc-priority-version avail-pkg)) + (push (cons name avail-pkg) upgrades)))) upgrades)) (defun package-menu-mark-upgrades () @@ -1957,22 +2422,56 @@ call will upgrade the package." (error "The current buffer is not a Package Menu")) (let ((upgrades (package-menu--find-upgrades))) (if (null upgrades) - (message "No packages to upgrade.") + (message "No packages to upgrade.") (widen) (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let* ((pkg-desc (tabulated-list-get-id)) - (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) - (cond ((null upgrade) - (forward-line 1)) - ((equal pkg-desc upgrade) - (package-menu-mark-install)) - (t - (package-menu-mark-delete)))))) + (goto-char (point-min)) + (while (not (eobp)) + (let* ((pkg-desc (tabulated-list-get-id)) + (upgrade (cdr (assq (package-desc-name pkg-desc) upgrades)))) + (cond ((null upgrade) + (forward-line 1)) + ((equal pkg-desc upgrade) + (package-menu-mark-install)) + (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--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-execute (&optional noquery) "Perform marked Package Menu actions. @@ -1986,15 +2485,15 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (setq cmd (char-after)) - (unless (eq cmd ?\s) - ;; This is the key PKG-DESC. - (setq pkg-desc (tabulated-list-get-id)) - (cond ((eq cmd ?D) - (push pkg-desc delete-list)) - ((eq cmd ?I) - (push pkg-desc install-list)))) - (forward-line))) + (setq cmd (char-after)) + (unless (eq cmd ?\s) + ;; This is the key PKG-DESC. + (setq pkg-desc (tabulated-list-get-id)) + (cond ((eq cmd ?D) + (push pkg-desc delete-list)) + ((eq cmd ?I) + (push pkg-desc install-list)))) + (forward-line))) (when install-list (if (or noquery @@ -2006,70 +2505,90 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (length install-list) (mapconcat #'package-desc-full-name install-list ", "))))) - (mapc 'package-install 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'? " + (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 delete-list) - (condition-case-unless-debug err - (package-delete elt) - (error (message (cadr err))))) - (error "Aborted"))) - (if (or delete-list install-list) - (package-menu--generate t t) - (message "No operations specified.")))) + (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)))) (defun package-menu--version-predicate (A B) (let ((vA (or (aref (cadr A) 1) '(0))) - (vB (or (aref (cadr B) 1) '(0)))) + (vB (or (aref (cadr B) 1) '(0)))) (if (version-list-= vA vB) - (package-menu--name-predicate A B) + (package-menu--name-predicate A B) (version-list-< vA vB)))) (defun package-menu--status-predicate (A B) (let ((sA (aref (cadr A) 2)) - (sB (aref (cadr B) 2))) + (sB (aref (cadr B) 2))) (cond ((string= sA sB) - (package-menu--name-predicate A B)) - ((string= sA "new") t) - ((string= sB "new") nil) - ((string= sA "available") t) - ((string= sB "available") nil) - ((string= sA "installed") t) - ((string= sB "installed") nil) - ((string= sA "unsigned") t) - ((string= sB "unsigned") nil) - ((string= sA "held") t) - ((string= sB "held") nil) - ((string= sA "built-in") t) - ((string= sB "built-in") nil) - ((string= sA "obsolete") t) - ((string= sB "obsolete") nil) - (t (string< sA sB))))) + (package-menu--name-predicate A B)) + ((string= sA "new") t) + ((string= sB "new") nil) + ((string= sA "available") t) + ((string= sB "available") nil) + ((string= sA "installed") t) + ((string= sB "installed") nil) + ((string= sA "dependency") t) + ((string= sB "dependency") nil) + ((string= sA "unsigned") t) + ((string= sB "unsigned") nil) + ((string= sA "held") t) + ((string= sB "held") nil) + ((string= sA "built-in") t) + ((string= sB "built-in") nil) + ((string= sA "obsolete") t) + ((string= sB "obsolete") nil) + ((string= sA "incompat") t) + ((string= sB "incompat") nil) + (t (string< sA sB))))) (defun package-menu--description-predicate (A B) (let ((dA (aref (cadr A) 3)) - (dB (aref (cadr B) 3))) + (dB (aref (cadr B) 3))) (if (string= dA dB) - (package-menu--name-predicate A B) + (package-menu--name-predicate A B) (string< dA dB)))) (defun package-menu--name-predicate (A B) (string< (symbol-name (package-desc-name (car A))) - (symbol-name (package-desc-name (car B))))) + (symbol-name (package-desc-name (car B))))) (defun package-menu--archive-predicate (A B) (string< (or (package-desc-archive (car A)) "") - (or (package-desc-archive (car B)) ""))) + (or (package-desc-archive (car B)) ""))) ;;;###autoload (defun list-packages (&optional no-fetch) @@ -2091,27 +2610,27 @@ The list is displayed in a buffer named `*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)))) + (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)) + (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")))))) + (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")))))) ;;;###autoload (defalias 'package-list-packages 'list-packages) |