;;; package.el --- Simple package system for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 2007-2014 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)
-(declare-function url-recreate-url "url-parse" (urlobj))
-(defvar url-http-target-url)
(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")
-(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.")
(when value
(push (cons (car rest-plist)
(if (eq (car-safe value) 'quote)
- (cdr value)
+ (cadr value)
value))
alist))))
(setq rest-plist (cddr rest-plist)))
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
(let ((bi (assq package package--builtin-versions)))
(cond
(bi (version-list-<= min-version (cdr bi)))
- (min-version nil)
+ ((remove 0 min-version) nil)
(t
(require 'finder-inf nil t) ; For `package--builtins'.
(assq package package--builtins))))))
(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
(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 nil 'silent))))
-(defun package--alist-to-plist (alist)
- (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
-
+(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?
)
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 downloading %s:%s"
- (url-recreate-url url-http-target-url)
- (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)))
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'."
(sig-file (concat file ".sig"))
(sig-content (package--with-work-buffer location sig-file
(buffer-string))))
- (epg-context-set-home-directory context homedir)
- (epg-verify-string context sig-content (buffer-string))
- ;; The .sig file may contain multiple signatures. Success if one
- ;; of the signatures is good.
- (let ((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)))
- good-signatures))))
+ (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."
;; Also check built-in packages.
(package-built-in-p package min-version)))
-(defun package-compute-transaction (packages requirements)
+(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
+ (when 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)))
+ ;; `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)
(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")
(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))))
(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")
(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))
- (let ((coding (detect-coding-string readme-string t)))
- (insert (decode-coding-string readme-string coding t))))
+ (insert readme-string))
((file-readable-p readme)
(insert-file-contents readme)
(goto-char (point-max))))))))
\\{package-menu-mode-map}"
(setq tabulated-list-format
`[("Package" 18 package-menu--name-predicate)
- ("Version" 12 nil)
+ ("Version" 13 nil)
("Status" 10 package-menu--status-predicate)
,@(if (cdr package-archives)
'(("Archive" 10 package-menu--archive-predicate)))
(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))
(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)))
(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 keywords)
"Re-populate the `tabulated-list-entries'.
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 keywords))
- (switch-to-buffer buf)))
+ (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.