X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/f53d3815aec361985e7ba19676c47cf2095051ab..7e09ef09a479731d01b1ca46e94ddadd73ac98e3:/lisp/emacs-lisp/package.el diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 957c516f5d..79f8b65d43 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -1,6 +1,6 @@ ;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*- -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Tom Tromey ;; Daniel Hackney @@ -113,8 +113,6 @@ ;;; ToDo: -;; - a trust mechanism, since compiling a package can run arbitrary code. -;; For example, download package signatures and check that they match. ;; - putting info dirs at the start of the info path means ;; users see a weird ordering of categories. OTOH we want to ;; override later entries. maybe emacs needs to enforce @@ -164,8 +162,10 @@ ;;; Code: (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." @@ -205,11 +205,9 @@ If VERSION is nil, the package is not loaded (it is \"disabled\")." (defvar Info-directory-list) (declare-function info-initialize "info" ()) -(declare-function url-http-parse-response "url-http" ()) (declare-function url-http-file-exists-p "url-http" (url)) (declare-function lm-header "lisp-mnt" (header)) (declare-function lm-commentary "lisp-mnt" (&optional file)) -(defvar url-http-end-of-headers) (defcustom package-archives '(("gnu" . "http://elpa.gnu.org/packages/")) "An alist of archives from which to fetch. @@ -231,18 +229,25 @@ a package can run arbitrary code." :version "24.1") (defcustom package-pinned-packages nil - "An alist of packages that are pinned to a specific archive - -Each element has the form (SYM . ID). - SYM is a package, as a symbol. - ID is an archive name. This should correspond to an - entry in `package-archives'. - -If the archive of name ID does not contain the package SYM, no -other location will be considered, which will make the -package unavailable." + "An alist of packages that are pinned to specific archives. +This can be useful if you have multiple package archives enabled, +and want to control which archive a given package gets installed from. + +Each element of the alist has the form (PACKAGE . ARCHIVE), where: + PACKAGE is a symbol representing a package + ARCHIVE is a string representing an archive (it should be the car of +an element in `package-archives', e.g. \"gnu\"). + +Adding an entry to this variable means that only ARCHIVE will be +considered as a source for PACKAGE. If other archives provide PACKAGE, +they are ignored (for this package). If ARCHIVE does not contain PACKAGE, +the package will be unavailable." :type '(alist :key-type (symbol :tag "Package") :value-type (string :tag "Archive name")) + ;; I don't really see why this is risky... + ;; I suppose it could prevent you receiving updates for a package, + ;; via an entry (PACKAGE . NON-EXISTING). Which could be an issue + ;; if PACKAGE has a known vulnerability that is fixed in newer versions. :risky t :group 'package :version "24.4") @@ -286,21 +291,30 @@ contrast, `package-user-dir' contains packages for personal use." :group 'package :version "24.1") -(defcustom package-check-signature 'allow-unsigned - "Whether to check package signatures when installing." +(defvar epg-gpg-program) + +(defcustom package-check-signature + (if (progn (require 'epg-config) (executable-find epg-gpg-program)) + 'allow-unsigned) + "Non-nil means to check package signatures when installing. +The value `allow-unsigned' means to still install a package even if +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")) :risky t :group 'package - :version "24.1") + :version "24.4") (defcustom package-unsigned-archives nil - "A list of archives which do not use package signature." + "List of archives where we do not check for package signatures." :type '(repeat (string :tag "Archive name")) :risky t :group 'package - :version "24.1") + :version "24.4") (defvar package--default-summary "No description available.") @@ -330,7 +344,10 @@ contrast, `package-user-dir' contains packages for personal use." (unless (memq (car rest-plist) '(:kind :archive)) (let ((value (cadr rest-plist))) (when value - (push (cons (car rest-plist) value) + (push (cons (car rest-plist) + (if (eq (car-safe value) 'quote) + (cadr value) + value)) alist)))) (setq rest-plist (cddr rest-plist))) alist))))) @@ -382,6 +399,12 @@ Slots: (`tar ".tar") (kind (error "Unknown package kind: %s" kind)))) +(defun package-desc--keywords (pkg-desc) + (let ((keywords (cdr (assoc :keywords (package-desc-extras pkg-desc))))) + (if (eq (car-safe keywords) 'quote) + (nth 1 keywords) + keywords))) + ;; Package descriptor format used in finder-inf.el and package--builtins. (cl-defstruct (package--bi-desc (:constructor package-make-builtin (version summary)) @@ -429,7 +452,7 @@ This is, approximately, the inverse of `version-to-list'. ((>= num 0) (push (int-to-string num) str-list) (push "." str-list)) - ((< num -3) + ((< num -4) (error "Invalid version list `%s'" vlist)) (t ;; pre, or beta, or alpha @@ -439,7 +462,8 @@ This is, approximately, the inverse of `version-to-list'. (error "Invalid version list `%s'" vlist))) (push (cond ((= num -1) "pre") ((= num -2) "beta") - ((= num -3) "alpha")) + ((= num -3) "alpha") + ((= num -4) "snapshot")) str-list)))) (if (equal "." (car str-list)) (pop str-list)) @@ -492,7 +516,11 @@ 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-dir (file-name-as-directory pkg-dir))) @@ -500,15 +528,27 @@ Return the max version (as a string) if the package is held at a lower version." (error "Internal error: unable to find directory for `%s'" (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. @@ -519,17 +559,54 @@ 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 specifying the minimum acceptable version." - (let ((bi (assq package package--builtin-versions))) - (cond - (bi (version-list-<= min-version (cdr bi))) - (min-version nil) - (t - (require 'finder-inf nil t) ; For `package--builtins'. - (assq package package--builtins))))) + (if (package-desc-p package) ;; was built-in and then was converted + (eq 'builtin (package-desc-dir package)) + (let ((bi (assq package package--builtin-versions))) + (cond + (bi (version-list-<= min-version (cdr bi))) + ((remove 0 min-version) nil) + (t + (require 'finder-inf nil t) ; For `package--builtins'. + (assq package package--builtins)))))) (defun package--from-builtin (bi-desc) (package-desc-create :name (pop bi-desc) @@ -566,14 +643,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'. 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-activate-1 pkg-vec force))))))) (defun define-package (_name-string _version-string &optional _docstring _requirements @@ -627,7 +704,7 @@ EXTRA-PROPERTIES is currently unused." ";; End:\n" ";;; " (file-name-nondirectory file) " ends here\n") - nil file)) + nil file nil 'silent)) file) (defvar generated-autoload-file) @@ -637,6 +714,7 @@ EXTRA-PROPERTIES is currently unused." (let* ((auto-name (format "%s-autoloads.el" name)) ;;(ignore-name (concat name "-pkg.el")) (generated-autoload-file (expand-file-name auto-name pkg-dir)) + (backup-inhibited t) (version-control 'never)) (package-autoload-ensure-default-file generated-autoload-file) (update-directory-autoloads pkg-dir) @@ -668,16 +746,15 @@ untar into a directory named DIR; otherwise, signal an error." (error "Package does not untar cleanly into directory %s/" dir))))) (tar-untar-buffer)) -(defun package-generate-description-file (pkg-desc pkg-dir) +(defun package-generate-description-file (pkg-desc pkg-file) "Create the foo-pkg.el file for single-file packages." - (let* ((name (package-desc-name pkg-desc)) - (pkg-file (expand-file-name (package--description-file pkg-dir) - pkg-dir))) + (let* ((name (package-desc-name pkg-desc))) (let ((print-level nil) (print-quoted t) (print-length nil)) (write-region (concat + ";;; -*- no-byte-compile: t -*-\n" (prin1-to-string (nconc (list 'define-package @@ -692,15 +769,15 @@ untar into a directory named DIR; otherwise, signal an error." (list (car elt) (package-version-join (cadr elt)))) requires)))) - (package--alist-to-plist + (package--alist-to-plist-args (package-desc-extras pkg-desc)))) "\n") - nil - pkg-file)))) - -(defun package--alist-to-plist (alist) - (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist))) + nil pkg-file nil 'silent)))) +(defun package--alist-to-plist-args (alist) + (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)) @@ -732,9 +809,10 @@ untar into a directory named DIR; otherwise, signal an error." (defun package--make-autoloads-and-stuff (pkg-desc pkg-dir) "Generate autoloads, description file, etc.. for PKG-DESC installed at PKG-DIR." (package-generate-autoloads (package-desc-name pkg-desc) pkg-dir) - (let ((desc-file (package--description-file pkg-dir))) + (let ((desc-file (expand-file-name (package--description-file pkg-dir) + pkg-dir))) (unless (file-exists-p desc-file) - (package-generate-description-file pkg-desc pkg-dir))) + (package-generate-description-file pkg-desc desc-file))) ;; FIXME: Create foo.info and dir file from foo.texi? ) @@ -745,7 +823,7 @@ untar into a directory named DIR; otherwise, signal an error." (defun package--write-file-no-coding (file-name) (let ((buffer-file-coding-system 'no-conversion)) - (write-region (point-min) (point-max) file-name))) + (write-region (point-min) (point-max) file-name nil 'silent))) (defmacro package--with-work-buffer (location file &rest body) "Run BODY in a buffer containing the contents of FILE at LOCATION. @@ -757,37 +835,14 @@ This macro retrieves FILE from LOCATION into a temporary buffer, and evaluates BODY while that buffer is current. This work buffer is killed afterwards. Return the last value in BODY." (declare (indent 2) (debug t)) - `(let* ((http (string-match "\\`https?:" ,location)) - (buffer - (if http - (url-retrieve-synchronously (concat ,location ,file)) - (generate-new-buffer "*package work buffer*")))) - (prog1 - (with-current-buffer buffer - (if http - (progn (package-handle-response) - (re-search-forward "^$" nil 'move) - (forward-char) - (delete-region (point-min) (point))) - (unless (file-name-absolute-p ,location) - (error "Archive location %s is not an absolute file name" - ,location)) - (insert-file-contents (expand-file-name ,file ,location))) - ,@body) - (kill-buffer buffer)))) - -(defun package-handle-response () - "Handle the response from a `url-retrieve-synchronously' call. -Parse the HTTP response and throw if an error occurred. -The url package seems to require extra processing for this. -This should be called in a `save-excursion', in the download buffer. -It will move point to somewhere in the headers." - ;; We assume HTTP here. - (require 'url-http) - (let ((response (url-http-parse-response))) - (when (or (< response 200) (>= response 300)) - (error "Error during download request:%s" - (buffer-substring-no-properties (point) (line-end-position)))))) + `(with-temp-buffer + (if (string-match-p "\\`https?:" ,location) + (url-insert-file-contents (concat ,location ,file)) + (unless (file-name-absolute-p ,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))) @@ -802,39 +857,54 @@ It will move point to somewhere in the headers." cipher-algorithm digest-algorithm compress-algorithm)) -(declare-function epg-context-set-home-directory "epg" (context directory)) (declare-function epg-verify-string "epg" (context signature &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) (declare-function epg-signature-status "epg" (signature)) (declare-function epg-signature-to-string "epg" (signature)) +(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'." - (let ((context (epg-make-context 'OpenPGP)) - (homedir (expand-file-name "gnupg" package-user-dir)) - (sig-file (concat file ".sig")) - sig-content - good-signatures) - (condition-case-unless-debug error - (setq sig-content (package--with-work-buffer location sig-file - (buffer-string))) - (error "Failed to download %s: %S" sig-file (cdr error))) - (epg-context-set-home-directory context homedir) - (epg-verify-string context sig-content (buffer-string)) - ;; The .sig file may contain multiple signatures. Success if one - ;; of the signatures is good. - (setq good-signatures - (delq nil (mapcar (lambda (sig) - (if (eq (epg-signature-status sig) 'good) - sig)) - (epg-context-result-for context 'verify)))) - (if (null good-signatures) - (error "Failed to verify signature %s: %S" - sig-file - (mapcar #'epg-signature-to-string - (epg-context-result-for context 'verify))) + (let* ((context (epg-make-context 'OpenPGP)) + (homedir (expand-file-name "gnupg" package-user-dir)) + (sig-file (concat file ".sig")) + (sig-content (package--with-work-buffer location sig-file + (buffer-string)))) + (setf (epg-context-home-directory context) homedir) + (condition-case error + (epg-verify-string context sig-content (buffer-string)) + (error + (package--display-verify-error context sig-file) + (signal (car error) (cdr error)))) + (let (good-signatures had-fatal-error) + ;; The .sig file may contain multiple signatures. Success if one + ;; of the signatures is good. + (dolist (sig (epg-context-result-for context 'verify)) + (if (eq (epg-signature-status sig) 'good) + (push sig good-signatures) + ;; If package-check-signature is allow-unsigned, don't + ;; signal error when we can't verify signature because of + ;; missing public key. Other errors are still treated as + ;; fatal (bug#17625). + (unless (and (eq package-check-signature 'allow-unsigned) + (eq (epg-signature-status sig) 'no-pubkey)) + (setq had-fatal-error t)))) + (when (and (null good-signatures) had-fatal-error) + (package--display-verify-error context sig-file) + (error "Failed to verify signature %s" sig-file)) good-signatures))) (defun package-install-from-archive (pkg-desc) @@ -863,7 +933,8 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." (expand-file-name (concat (package-desc-full-name pkg-desc) ".signed") - package-user-dir)) + 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. @@ -877,15 +948,15 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'." "Return true if PACKAGE, of MIN-VERSION or newer, is installed. MIN-VERSION should be a version list." (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))) - -(defun package-compute-transaction (packages requirements) + (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. PACKAGES should be a list of `package-desc'. @@ -897,7 +968,9 @@ version of that package. This function recursively computes the requirements of the packages in REQUIREMENTS, and returns a list of all the packages that must be installed. Packages that are already installed are -not included in this list." +not included in this list. + +SEEN is used internally to detect infinite recursion." ;; FIXME: We really should use backtracking to explore the whole ;; search space (e.g. if foo require bar-1.3, and bar-1.4 requires toto-1.1 ;; whereas bar-1.3 requires toto-1.0 and the user has put a hold on toto-1.0: @@ -910,15 +983,22 @@ not included in this list." (dolist (pkg packages) (if (eq next-pkg (package-desc-name pkg)) (setq already pkg))) - (cond - (already - (if (version-list-< next-version (package-desc-version already)) - ;; Move to front, so it gets installed early enough (bug#14082). - (setq packages (cons already (delq already packages))) - (error "Need package `%s-%s', but only %s is available" + (when already + (if (version-list-<= next-version (package-desc-version already)) + ;; `next-pkg' is already in `packages', but its position there + ;; means it might be installed too late: remove it from there, so + ;; we re-add it (along with its dependencies) at an earlier place + ;; below (bug#16994). + (if (memq already seen) ;Avoid inf-loop on dependency cycles. + (message "Dependency cycle going through %S" + (package-desc-full-name already)) + (setq packages (delq already packages)) + (setq already nil)) + (error "Need package `%s-%s', but only %s is being installed" next-pkg (package-version-join next-version) (package-version-join (package-desc-version already))))) - + (cond + (already nil) ((package-installed-p next-pkg next-version) nil) (t @@ -950,12 +1030,13 @@ but version %s required" (t (setq found pkg-desc))))) (unless found (if problem - (error 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)))))))) + (package-desc-reqs found) + (cons found seen)))))))) packages) (defun package-read-from-string (str) @@ -1036,14 +1117,9 @@ Also, add the originating archive to the `package-desc' structure." (existing-packages (assq name package-archive-contents)) (pinned-to-archive (assoc name package-pinned-packages))) (cond - ;; Skip entirely if pinned to another archive or already installed. - ((or (and pinned-to-archive - (not (equal (cdr pinned-to-archive) archive))) - (let ((bi (assq name package--builtin-versions))) - (and bi (version-list-= version (cdr bi)))) - (let ((ins (cdr (assq name package-alist)))) - (and ins (version-list-= version - (package-desc-version (car ins)))))) + ;; 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)) @@ -1079,8 +1155,11 @@ in an archive in `package-archives'. Interactively, prompt for its name." (package-refresh-contents)) (list (intern (completing-read "Install package: " - (mapcar (lambda (elt) (symbol-name (car elt))) - package-archive-contents) + (delq nil + (mapcar (lambda (elt) + (unless (package-installed-p (car elt)) + (symbol-name (car elt)))) + package-archive-contents)) nil t))))) (package-download-transaction (if (package-desc-p pkg) @@ -1103,6 +1182,25 @@ Otherwise return nil." (declare-function lm-homepage "lisp-mnt" (&optional file)) +(defun package--prepare-dependencies (deps) + "Turn DEPS into an acceptable list of dependencies. + +Any parts missing a version string get a default version string +of \"0\" (meaning any version) and an appropriate level of lists +is wrapped around any parts requiring it." + (cond + ((not (listp deps)) + (error "Invalid requirement specifier: %S" deps)) + (t (mapcar (lambda (dep) + (cond + ((symbolp dep) `(,dep "0")) + ((stringp dep) + (error "Invalid requirement specifier: %S" dep)) + ((and (listp dep) (null (cdr dep))) + (list (car dep) "0")) + (t dep))) + deps)))) + (defun package-buffer-info () "Return a `package-desc' describing the package in the current buffer. @@ -1134,7 +1232,9 @@ boundaries." "Package lacks a \"Version\" or \"Package-Version\" header")) (package-desc-from-define file-name pkg-version desc - (if requires-str (package-read-from-string requires-str)) + (if requires-str + (package--prepare-dependencies + (package-read-from-string requires-str))) :kind 'single :url homepage)))) @@ -1208,8 +1308,11 @@ The file can either be a tar file or an Emacs Lisp file." (if (file-exists-p signed-file) (delete-file signed-file))) ;; Update package-alist. - (let* ((name (package-desc-name pkg-desc))) - (delete pkg-desc (assq name 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-archive-base (desc) @@ -1237,17 +1340,15 @@ similar to an entry in `package-alist'. Save the cached copy to (car archive))))) ;; Read the retrieved buffer to make sure it is valid (e.g. it ;; may fetch a URL redirect page). - (when (listp (read buffer)) + (when (listp (read (current-buffer))) (make-directory dir t) - (setq buffer-file-name (expand-file-name file dir)) - (let ((version-control 'never) - (require-final-newline nil)) - (save-buffer)))) + (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))))) + (expand-file-name (concat file ".signed") dir) + nil 'silent)))) (declare-function epg-check-configuration "epg-config" (config &optional minimum-version)) @@ -1261,8 +1362,9 @@ similar to an entry in `package-alist'. Save the cached copy to (setq file (expand-file-name file)) (let ((context (epg-make-context 'OpenPGP)) (homedir (expand-file-name "gnupg" package-user-dir))) - (make-directory homedir t) - (epg-context-set-home-directory context homedir) + (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)))) @@ -1278,12 +1380,12 @@ makes them available for download." (make-directory package-user-dir t)) (let ((default-keyring (expand-file-name "package-keyring.gpg" data-directory))) - (if (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)))))) + (when (and package-check-signature (file-exists-p default-keyring)) + (condition-case-unless-debug error + (progn + (epg-check-configuration (epg-configuration)) + (package-import-keyring default-keyring)) + (error (message "Cannot import default keyring: %S" (cdr error)))))) (dolist (archive package-archives) (condition-case-unless-debug nil (package--download-one-archive archive "archive-contents") @@ -1352,7 +1454,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (reqs (if desc (package-desc-reqs desc))) (version (if desc (package-desc-version desc))) (archive (if desc (package-desc-archive desc))) - (homepage (if desc (cdr (assoc :url (package-desc-extras desc))))) + (extras (and desc (package-desc-extras desc))) + (homepage (cdr (assoc :url extras))) + (keywords (if desc (package-desc--keywords desc))) (built-in (eq pkg-dir 'builtin)) (installable (and archive (not built-in))) (status (if desc (package-desc-status desc) "orphan")) @@ -1391,17 +1495,14 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert (capitalize status)) (insert " from " (format "%s" archive)) (insert " -- ") - (let ((button-text (if (display-graphic-p) "Install" "[Install]")) - (button-face (if (display-graphic-p) - '(:box (:line-width 2 :color "dark grey") - :background "light grey" - :foreground "black") - 'link))) - (insert-text-button button-text 'face button-face 'follow-link t - 'package-desc desc - 'action 'package-install-button-action))) + (package-make-button + "Install" + 'action 'package-install-button-action + 'package-desc desc)) (t (insert (capitalize status) "."))) (insert "\n") + (insert " " (propertize "Archive" 'font-lock-face 'bold) + ": " (or archive "n/a") "\n") (and version (insert " " (propertize "Version" 'font-lock-face 'bold) ": " @@ -1430,6 +1531,15 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (insert " " (propertize "Homepage" 'font-lock-face 'bold) ": ") (help-insert-xref-button homepage 'help-url homepage) (insert "\n")) + (when keywords + (insert " " (propertize "Keywords" 'font-lock-face 'bold) ": ") + (dolist (k keywords) + (package-make-button + k + 'package-keyword k + 'action 'package-keyword-button-action) + (insert " ")) + (insert "\n")) (let* ((all-pkgs (append (cdr (assq name package-alist)) (cdr (assq name package-archive-contents)) (let ((bi (assq name package--builtins))) @@ -1479,11 +1589,13 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (package--with-work-buffer (package-archive-base desc) (format "%s-readme.txt" name) - (setq buffer-file-name - (expand-file-name readme package-user-dir)) - (let ((version-control 'never) - (require-final-newline t)) - (save-buffer)) + (save-excursion + (goto-char (point-max)) + (unless (bolp) + (insert ?\n))) + (write-region nil nil + (expand-file-name readme package-user-dir) + nil 'silent) (setq readme-string (buffer-string)) t)) (error nil)) @@ -1500,6 +1612,20 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (revert-buffer nil t) (goto-char (point-min))))) +(defun package-keyword-button-action (button) + (let ((pkg-keyword (button-get button 'package-keyword))) + (package-show-package-list t (list pkg-keyword)))) + +(defun package-make-button (text &rest props) + (let ((button-text (if (display-graphic-p) text (concat "[" text "]"))) + (button-face (if (display-graphic-p) + '(:box (:line-width 2 :color "dark grey") + :background "light grey" + :foreground "black") + 'link))) + (apply 'insert-text-button button-text 'face button-face 'follow-link t + props))) + ;;;; Package menu mode. @@ -1514,6 +1640,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." (define-key map "i" 'package-menu-mark-install) (define-key map "U" 'package-menu-mark-upgrades) (define-key map "r" 'package-menu-refresh) + (define-key map "f" 'package-menu-filter) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) @@ -1546,6 +1673,9 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." '(menu-item "Mark Upgradable Packages" package-menu-mark-upgrades :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)")) (define-key menu-map [mg] '(menu-item "Update Package List" revert-buffer :help "Update the list of packages")) @@ -1564,7 +1694,7 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." '(menu-item "Help" package-menu-quick-help :help "Show short key binding help for package-menu-mode")) (define-key menu-map [mc] - '(menu-item "View Commentary" package-menu-view-commentary + '(menu-item "Describe Package" package-menu-describe-package :help "Display information about this package")) map) "Local keymap for `package-menu-mode' buffers.") @@ -1577,10 +1707,13 @@ If optional arg NO-ACTIVATE is non-nil, don't activate packages." Letters do not insert themselves; instead, they are commands. \\ \\{package-menu-mode-map}" - (setq tabulated-list-format [("Package" 18 package-menu--name-predicate) - ("Version" 12 nil) - ("Status" 10 package-menu--status-predicate) - ("Description" 0 nil)]) + (setq tabulated-list-format + `[("Package" 18 package-menu--name-predicate) + ("Version" 13 nil) + ("Status" 10 package-menu--status-predicate) + ,@(if (cdr package-archives) + '(("Archive" 10 package-menu--archive-predicate))) + ("Description" 0 nil)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) (add-hook 'tabulated-list-revert-hook 'package-menu--refresh nil t) @@ -1597,6 +1730,9 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (defvar package-list-unversioned nil "If non-nil include packages that don't have a version in `list-package'.") +(defvar package-list-unsigned nil + "If non-nil, mention in the list which packages were installed w/o signature.") + (defun package-desc-status (pkg-desc) (let* ((name (package-desc-name pkg-desc)) (dir (package-desc-dir pkg-desc)) @@ -1617,9 +1753,8 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (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 signed - "installed" - "unsigned")) + ((eq pkg-desc (cadr (assq name package-alist))) + (if (or (not package-list-unsigned) signed) "installed" "unsigned")) (t "obsolete"))) (t (let* ((ins (cadr (assq name package-alist))) @@ -1629,13 +1764,14 @@ package PKG-DESC, add one. The alist is keyed with PKG-DESC." (if (memq name package-menu--new-package-list) "new" "available")) ((version-list-< version ins-v) "obsolete") - ((version-list-= version ins-v) (if signed - "installed" - "unsigned")))))))) + ((version-list-= version ins-v) + (if (or (not package-list-unsigned) signed) + "installed" "unsigned")))))))) -(defun package-menu--refresh (&optional packages) +(defun package-menu--refresh (&optional packages keywords) "Re-populate the `tabulated-list-entries'. -PACKAGES should be nil or t, which means to display all known packages." +PACKAGES should be nil or t, which means to display all known packages. +KEYWORDS should be nil or a list of keywords." ;; Construct list of (PKG-DESC . STATUS). (unless packages (setq packages t)) (let (info-list name) @@ -1644,12 +1780,14 @@ PACKAGES should be nil or t, which means to display all known packages." (setq name (car elt)) (when (or (eq packages t) (memq name packages)) (dolist (pkg (cdr elt)) - (package--push pkg (package-desc-status pkg) info-list)))) + (when (package--has-keyword-p pkg keywords) + (package--push pkg (package-desc-status pkg) info-list))))) ;; Built-in packages: (dolist (elt package--builtins) (setq name (car elt)) (when (and (not (eq name 'emacs)) ; Hide the `emacs' package. + (package--has-keyword-p (package--from-builtin elt) keywords) (or package-list-unversioned (package--bi-desc-version (cdr elt))) (or (eq packages t) (memq name packages))) @@ -1661,20 +1799,87 @@ PACKAGES should be nil or t, which means to display all known packages." (when (or (eq packages t) (memq name packages)) (dolist (pkg (cdr elt)) ;; Hide obsolete packages. - (unless (package-installed-p (package-desc-name pkg) - (package-desc-version pkg)) + (when (and (not (package-installed-p (package-desc-name pkg) + (package-desc-version pkg))) + (package--has-keyword-p pkg keywords)) (package--push pkg (package-desc-status pkg) info-list))))) ;; Print the result. (setq tabulated-list-entries (mapcar #'package-menu--print-info info-list)))) -(defun package-menu--generate (remember-pos packages) +(defun package-all-keywords () + "Collect all package keywords" + (let (keywords) + (package--mapc (lambda (desc) + (let* ((desc-keywords (and desc (package-desc--keywords desc)))) + (setq keywords (append keywords desc-keywords))))) + keywords)) + +(defun package--mapc (function &optional packages) + "Call FUNCTION for all known PACKAGES. +PACKAGES can be nil or t, which means to display all known +packages, or a list of packages. + +Built-in packages are converted with `package--from-builtin'." + (unless packages (setq packages t)) + (let (name) + ;; Installed packages: + (dolist (elt package-alist) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (mapc function (cdr elt)))) + + ;; Built-in packages: + (dolist (elt package--builtins) + (setq name (car elt)) + (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))) + (funcall function (package--from-builtin elt)))) + + ;; Available and disabled packages: + (dolist (elt package-archive-contents) + (setq name (car elt)) + (when (or (eq packages t) (memq name packages)) + (dolist (pkg (cdr elt)) + ;; Hide obsolete packages. + (unless (package-installed-p (package-desc-name pkg) + (package-desc-version pkg)) + (funcall function pkg))))))) + +(defun package--has-keyword-p (desc &optional keywords) + "Test if package DESC has any of the given KEYWORDS. +When none are given, the package matches." + (if keywords + (let* ((desc-keywords (and desc (package-desc--keywords desc))) + found) + (dolist (k keywords) + (when (and (not found) + (member k desc-keywords)) + (setq found t))) + found) + t)) + +(defun package-menu--generate (remember-pos packages &optional keywords) "Populate the Package Menu. If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, -or a list of package names (symbols) to display." - (package-menu--refresh packages) +or a list of package names (symbols) to display. + +With KEYWORDS given, only packages with those keywords are +shown." + (package-menu--refresh packages keywords) + (setf (car (aref tabulated-list-format 0)) + (if keywords + (let ((filters (mapconcat 'identity keywords ","))) + (concat "Package[" filters "]")) + "Package")) + (if keywords + (define-key package-menu-mode-map "q" 'package-show-package-list) + (define-key package-menu-mode-map "q" 'quit-window)) + (tabulated-list-init-header) (tabulated-list-print remember-pos)) (defun package-menu--print-info (pkg) @@ -1684,26 +1889,29 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (let* ((pkg-desc (car pkg)) (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) - (`"unsigned" 'font-lock-warning-face) - (_ 'font-lock-warning-face)))) ; obsolete. + (`"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) + (`"unsigned" 'font-lock-warning-face) + (_ 'font-lock-warning-face)))) ; obsolete. (list pkg-desc - (vector (list (symbol-name (package-desc-name pkg-desc)) - 'face 'link - 'follow-link t - 'package-desc pkg-desc - 'action 'package-menu-describe-package) - (propertize (package-version-join - (package-desc-version pkg-desc)) - 'font-lock-face face) - (propertize status 'font-lock-face face) - (propertize (package-desc-summary pkg-desc) - 'font-lock-face face))))) + `[,(list (symbol-name (package-desc-name pkg-desc)) + 'face 'link + 'follow-link t + 'package-desc pkg-desc + 'action 'package-menu-describe-package) + ,(propertize (package-version-join + (package-desc-version pkg-desc)) + 'font-lock-face face) + ,(propertize status 'font-lock-face face) + ,@(if (cdr package-archives) + (list (propertize (or (package-desc-archive pkg-desc) "") + 'font-lock-face face))) + ,(propertize (package-desc-summary pkg-desc) + 'font-lock-face face)]))) (defun package-menu-refresh () "Download the Emacs Lisp package archive. @@ -1918,6 +2126,10 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." (string< (symbol-name (package-desc-name (car A))) (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)) ""))) + ;;;###autoload (defun list-packages (&optional no-fetch) "Display a list of packages. @@ -1964,17 +2176,33 @@ The list is displayed in a buffer named `*Packages*'." (defalias 'package-list-packages 'list-packages) ;; Used in finder.el -(defun package-show-package-list (packages) +(defun package-show-package-list (&optional packages keywords) "Display PACKAGES in a *Packages* buffer. This is similar to `list-packages', but it does not fetch the updated list of packages, and it only displays packages with -names in PACKAGES (which should be a list of symbols)." +names in PACKAGES (which should be a list of symbols). + +When KEYWORDS are given, only packages with those KEYWORDS are +shown." + (interactive) (require 'finder-inf nil t) - (let ((buf (get-buffer-create "*Packages*"))) + (let* ((buf (get-buffer-create "*Packages*")) + (win (get-buffer-window buf))) (with-current-buffer buf (package-menu-mode) - (package-menu--generate nil packages)) - (switch-to-buffer buf))) + (package-menu--generate nil packages keywords)) + (if win + (select-window win) + (switch-to-buffer buf)))) + +;; package-menu--generate rebinds "q" on the fly, so we have to +;; hard-code the binding in the doc-string here. +(defun package-menu-filter (keyword) + "Filter the *Packages* buffer. +Show only those items that relate to the specified KEYWORD. +To restore the full package list, type `q'." + (interactive (list (completing-read "Keyword: " (package-all-keywords)))) + (package-show-package-list t (list keyword))) (defun package-list-packages-no-fetch () "Display a list of packages.