From fe188b2e4fd66dfba7f56bbe7c2fb32faef6f5f8 Mon Sep 17 00:00:00 2001 From: Artur Malabarba Date: Mon, 2 Feb 2015 11:55:24 +0000 Subject: [PATCH] emacs-lisp/package.el (package-initialize): Populate `package-selected-packages'. --- lisp/ChangeLog | 6 + lisp/emacs-lisp/package.el | 666 +++++++++++++++++++------------------ 2 files changed, 348 insertions(+), 324 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index fe0a3dba1a0..dd8605a0f20 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2015-02-02 Artur Malabarba + + * emacs-lisp/package.el (package--find-non-dependencies): New + function. + (package-initialize): Use it to populate `package-selected-packages'. + 2015-02-02 Michael Albinus * net/tramp-sh.el (tramp-histfile-override): Add another choice 'unset. diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index d95bc5e6d73..9a29d63ced2 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -295,8 +295,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. @@ -320,8 +320,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") @@ -387,20 +387,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. @@ -477,32 +477,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) @@ -510,8 +510,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 () @@ -551,11 +551,11 @@ 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) (autoloads-file (expand-file-name @@ -575,7 +575,7 @@ correspond to previously loaded files (those returned by ;; 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)) + (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. @@ -674,12 +674,12 @@ If FORCE is true, (re-)activate it if it's already activated." (dolist (req (package-desc-reqs pkg-vec)) (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 force))))))) + 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 @@ -722,17 +722,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) @@ -741,10 +741,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)) + ;;(ignore-name (concat name "-pkg.el")) + (generated-autoload-file (expand-file-name auto-name pkg-dir)) (backup-inhibited t) - (version-control 'never)) + (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) (update-directory-autoloads pkg-dir) (let ((buf (find-buffer-visiting generated-autoload-file))) @@ -764,15 +764,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) @@ -811,7 +811,7 @@ untar into a directory named DIR; otherwise, signal an error." "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) @@ -880,28 +880,28 @@ 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)) + (&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)) @@ -910,13 +910,13 @@ buffer is killed afterwards. Return the last value in BODY." (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)))))) + (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. @@ -925,10 +925,10 @@ 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)))) + (buffer-string)))) (setf (epg-context-home-directory context) homedir) (condition-case error - (epg-verify-string context sig-content (buffer-string)) + (epg-verify-string context sig-content (buffer-string)) (error (package--display-verify-error context sig-file) (signal (car error) (cdr error)))) @@ -936,18 +936,18 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." ;; 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 (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)) + (package--display-verify-error context sig-file) + (error "Failed to verify signature %s" sig-file)) good-signatures))) (defun package-install-from-archive (pkg-desc) @@ -956,37 +956,37 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (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) @@ -997,8 +997,8 @@ MIN-VERSION should be a version list." (or (let ((pkg-descs (cdr (assq package package-alist)))) (and pkg-descs - (version-list-<= min-version - (package-desc-version (car pkg-descs))))) + (version-list-<= min-version + (package-desc-version (car pkg-descs))))) ;; Also check built-in packages. (package-built-in-p package min-version))) @@ -1024,7 +1024,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)) @@ -1048,9 +1048,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)) @@ -1074,14 +1074,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) @@ -1089,13 +1089,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)))) @@ -1107,12 +1107,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. @@ -1128,10 +1128,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 @@ -1250,8 +1250,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)) @@ -1285,8 +1285,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. @@ -1295,15 +1295,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 @@ -1564,33 +1564,33 @@ 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)) @@ -1600,7 +1600,7 @@ 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))) + (homedir (expand-file-name "gnupg" package-user-dir))) (with-file-modes 448 (make-directory homedir t)) (setf (epg-context-home-directory context) homedir) @@ -1618,20 +1618,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))))) + (car archive))))) (package-read-all-archive-contents)) +(defun package--find-non-dependencies () + "Return a list of installed packages which are not dependencies. +Finds all packages in `package-alist' which are not dependencies +of any other packages. +Used to populate `package-selected-packages'." + (let ((dep-list + (delete-dups + (apply #'append + (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p)))) + package-alist))))) + (cl-loop for p in package-alist + for name = (car p) + unless (memq name dep-list) + collect name))) + ;;;###autoload (defun package-initialize (&optional no-activate) "Load Emacs Lisp packages, and activate them. @@ -1644,6 +1659,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (unless no-activate (dolist (elt package-alist) (package-activate (car elt)))) + (when (and package-alist (not package-selected-packages)) + (customize-save-variable 'package-selected-packages + (package--find-non-dependencies))) (setq package--initialized t)) @@ -1674,10 +1692,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) @@ -1708,64 +1726,64 @@ 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 (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 (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)."))) + (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"))) + 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"))) (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) @@ -1807,23 +1825,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) @@ -1837,11 +1855,11 @@ 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))) @@ -1870,7 +1888,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) @@ -1887,54 +1905,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.") @@ -2029,8 +2047,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) @@ -2075,7 +2093,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: @@ -2126,8 +2144,8 @@ 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) @@ -2137,7 +2155,7 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (`"unsigned" 'font-lock-warning-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 @@ -2167,9 +2185,9 @@ 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 @@ -2205,8 +2223,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." @@ -2218,9 +2236,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 () @@ -2229,7 +2247,7 @@ 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))) + (status (aref (cadr entry) 2))) (cond ((member status '("installed" "unsigned")) (push pkg-desc installed)) ((member status '("available" "new")) @@ -2255,22 +2273,22 @@ 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-menu-execute (&optional noquery) "Perform marked Package Menu actions. @@ -2284,15 +2302,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 @@ -2312,64 +2330,64 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (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"))) + (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) + (package-menu--generate t t) (message "No operations specified.")))) (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 "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))))) (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) @@ -2391,27 +2409,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) -- 2.39.2