;;; 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 <tromey@redhat.com>
;; Daniel Hackney <dan@haxney.org>
;;; 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
;;; 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."
(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.
: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")
: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)
+ "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.4")
+
+(defcustom package-unsigned-archives nil
+ "List of archives where we do not check for package signatures."
+ :type '(repeat (string :tag "Archive name"))
+ :risky t
+ :group 'package
+ :version "24.4")
+
(defvar package--default-summary "No description available.")
(cl-defstruct (package-desc
(kind (plist-get rest-plist :kind))
(archive (plist-get rest-plist :archive))
(extras (let (alist)
- (cl-remf rest-plist :kind)
- (cl-remf rest-plist :archive)
(while rest-plist
- (let ((value (cadr rest-plist)))
- (when value
- (push (cons (car rest-plist) value)
- alist)))
+ (unless (memq (car rest-plist) '(:kind :archive))
+ (let ((value (cadr rest-plist)))
+ (when value
+ (push (cons (car rest-plist)
+ (if (eq (car-safe value) 'quote)
+ (cadr value)
+ value))
+ alist))))
(setq rest-plist (cddr rest-plist)))
alist)))))
"Structure containing information about an individual package.
`dir' The directory where the package is installed (if installed),
`builtin' if it is built-in, or nil otherwise.
-`extras' Optional alist of additional keyword-value pairs."
+`extras' Optional alist of additional keyword-value pairs.
+
+`signed' Flag to indicate that the package is signed by provider."
name
version
(summary package--default-summary)
kind
archive
dir
- extras)
+ extras
+ signed)
;; Pseudo fields.
(defun package-desc-full-name (pkg-desc)
(`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))
((>= 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
(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))
(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)))
+ pkg-dir))
+ (signed-file (concat pkg-dir ".signed")))
(when (file-exists-p pkg-file)
(with-temp-buffer
(insert-file-contents pkg-file)
(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))
pkg-desc)))))
(defun package-load-all-descriptors ()
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)))
(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.
;; 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)
(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
";; End:\n"
";;; " (file-name-nondirectory file)
" ends here\n")
- nil file))
+ nil file nil 'silent))
file)
(defvar generated-autoload-file)
(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)
(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
(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))
(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?
)
(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.
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)))
+ (if http
+ (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-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 (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)
"Download and install a tar package."
- (let ((location (package-archive-base pkg-desc))
- (file (concat (package-desc-full-name pkg-desc)
- (package-desc-suffix pkg-desc))))
+ (let* ((location (package-archive-base pkg-desc))
+ (file (concat (package-desc-full-name pkg-desc)
+ (package-desc-suffix pkg-desc)))
+ (sig-file (concat file ".sig"))
+ good-signatures pkg-descs)
(package--with-work-buffer location file
- (package-unpack pkg-desc))))
+ (if (and package-check-signature
+ (not (member (package-desc-archive pkg-desc)
+ package-unsigned-archives)))
+ (if (package--archive-file-exists-p location sig-file)
+ (setq good-signatures (package--check-signature location file))
+ (unless (eq package-check-signature 'allow-unsigned)
+ (error "Unsigned package: `%s'"
+ (package-desc-name pkg-desc)))))
+ (package-unpack pkg-desc))
+ ;; Here the package has been installed successfully, mark it as
+ ;; signed if appropriate.
+ (when good-signatures
+ ;; Write out good signatures into NAME-VERSION.signed file.
+ (write-region (mapconcat #'epg-signature-to-string good-signatures "\n")
+ nil
+ (expand-file-name
+ (concat (package-desc-full-name pkg-desc)
+ ".signed")
+ package-user-dir)
+ nil 'silent)
+ ;; Update the old pkg-desc which will be shown on the description buffer.
+ (setf (package-desc-signed pkg-desc) t)
+ ;; Update the new (activated) pkg-desc as well.
+ (setq pkg-descs (cdr (assq (package-desc-name pkg-desc) package-alist)))
+ (if pkg-descs
+ (setf (package-desc-signed (car pkg-descs)) t)))))
(defvar package--initialized nil)
"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'.
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:
(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
(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)
(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))
(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)
str)
(error 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.
"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))))
(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)))
- (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)
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)))
+ (let ((dir (expand-file-name (format "archives/%s" (car archive))
+ 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)))))
;; 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))
- (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)
+ nil 'silent))))
+
+(declare-function epg-check-configuration "epg-config"
+ (config &optional minimum-version))
+(declare-function epg-configuration "epg-config" ())
+(declare-function epg-import-keys-from-file "epg" (context keys))
+
+;;;###autoload
+(defun package-import-keyring (&optional file)
+ "Import keys from FILE."
+ (interactive "fFile: ")
+ (setq file (expand-file-name file))
+ (let ((context (epg-make-context 'OpenPGP))
+ (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))))
;;;###autoload
(defun package-refresh-contents ()
;; FIXME: Do it asynchronously.
(unless (file-exists-p package-user-dir)
(make-directory package-user-dir t))
+ (let ((default-keyring (expand-file-name "package-keyring.gpg"
+ data-directory)))
+ (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")
(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")))
+ (status (if desc (package-desc-status desc) "orphan"))
+ (signed (if desc (package-desc-signed desc))))
(prin1 name)
(princ " is ")
(princ (if (memq (aref status 0) '(?a ?e ?i ?o ?u)) "an " "a "))
'font-lock-face 'font-lock-builtin-face)
"."))
(pkg-dir
- (insert (propertize (capitalize status) ;FIXME: Why comment-face?
+ (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.
(not (package-built-in-p name version)))
(insert "',\n shadowing a "
(propertize "built-in package"
- 'font-lock-face 'font-lock-builtin-face)
- ".")
- (insert "'.")))
+ 'font-lock-face 'font-lock-builtin-face))
+ (insert "'"))
+ (if signed
+ (insert ".")
+ (insert " (unsigned).")))
(installable
(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) ": "
(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)))
;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'.
(cond ((condition-case nil
- (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))
- (save-buffer))
- (setq readme-string (buffer-string))
- t)
+ (save-excursion
+ (package--with-work-buffer
+ (package-archive-base desc)
+ (format "%s-readme.txt" name)
+ (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))
(insert readme-string))
((file-readable-p readme)
(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)))
+
\f
;;;; Package menu mode.
(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)
'(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"))
'(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.")
Letters do not insert themselves; instead, they are commands.
\\<package-menu-mode-map>
\\{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)
(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))
(lle (assq name package-load-list))
(held (cadr lle))
- (version (package-desc-version pkg-desc)))
+ (version (package-desc-version pkg-desc))
+ (signed (package-desc-signed pkg-desc)))
(cond
((eq dir 'builtin) "built-in")
((and lle (null held)) "disabled")
(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))) "installed")
+ ((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)))
(if (memq name package-menu--new-package-list)
"new" "available"))
((version-list-< version ins-v) "obsolete")
- ((version-list-= version ins-v) "installed")))))))
+ ((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)
(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)))
(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)
(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)
- (_ '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.
(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"))
+ (if (member (package-menu-get-status) '("installed" "obsolete" "unsigned"))
(tabulated-list-put-tag "D" t)
(forward-line)))
;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
(let ((pkg-desc (car entry))
(status (aref (cadr entry) 2)))
- (cond ((equal status "installed")
+ (cond ((member status '("installed" "unsigned"))
(push pkg-desc installed))
((member status '("available" "new"))
(push (cons (package-desc-name pkg-desc) pkg-desc)
((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< (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.
(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.