[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/organizing-package.el 830cd2a 3/5: Reorganize pack
|
From: |
Artur Malabarba |
|
Subject: |
[Emacs-diffs] scratch/organizing-package.el 830cd2a 3/5: Reorganize package.el and divide it with page-breaks and comments |
|
Date: |
Sun, 29 Mar 2015 10:33:25 +0000 |
branch: scratch/organizing-package.el
commit 830cd2a0e5c97639735d6e6288f331fc4035976c
Author: Artur Malabarba <address@hidden>
Commit: Artur Malabarba <address@hidden>
Reorganize package.el and divide it with page-breaks and comments
---
lisp/emacs-lisp/package.el | 1496 +++++++++++++++++++++++---------------------
1 files changed, 784 insertions(+), 712 deletions(-)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 6beb5f2..9a0c5e8 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -173,6 +173,8 @@
:group 'applications
:version "24.1")
+
+;;; Customization options
;;;###autoload
(defcustom package-enable-at-startup t
"Whether to activate installed packages when Emacs starts.
@@ -264,17 +266,6 @@ the package will be unavailable."
:group 'package
:version "24.4")
-(defconst package-archive-version 1
- "Version number of the package archive understood by this file.
-Lower version numbers than this will probably be understood as well.")
-
-;; We don't prime the cache since it tends to get out of date.
-(defvar package-archive-contents nil
- "Cache of the contents of the Emacs Lisp Package Archive.
-This is an alist mapping package names (symbols) to
-non-empty lists of `package-desc' structures.")
-(put 'package-archive-contents 'risky-local-variable t)
-
(defcustom package-user-dir (locate-user-emacs-file "elpa")
"Directory containing the user's Emacs Lisp packages.
The directory name should be absolute.
@@ -342,6 +333,14 @@ a sane initial value."
:group 'package
:type '(repeat symbol))
+
+;;; `package-desc' object definition
+;; This is the struct used internally to represent packages.
+;; Functions that deal with packages should generally take this object
+;; as an argument. In some situations (e.g. commands that query the
+;; user) it makes sense to take the package name as a symbol instead,
+;; but keep in mind there could be multiple `package-desc's with the
+;; same name.
(defvar package--default-summary "No description available.")
(cl-defstruct (package-desc
@@ -413,6 +412,12 @@ Slots:
extras
signed)
+(defun package--from-builtin (bi-desc)
+ (package-desc-create :name (pop bi-desc)
+ :version (package--bi-desc-version bi-desc)
+ :summary (package--bi-desc-summary bi-desc)
+ :dir 'builtin))
+
;; Pseudo fields.
(defun package-desc-full-name (pkg-desc)
(format "%s-%s"
@@ -440,6 +445,13 @@ Slots:
reqs
summary)
+
+;;; Installed packages
+;; The following variables store information about packages present in
+;; the system. The most important of these is `package-alist'. The
+;; command `package-initialize' is also closely related to this
+;; section, but it is left for a later section because it also affects
+;; other stuff.
(defvar package--builtins nil
"Alist of built-in packages.
The actual value is initialized by loading the library
@@ -461,24 +473,34 @@ called via `package-initialize'. To change which
packages are
loaded and/or activated, customize `package-load-list'.")
(put 'package-alist 'risky-local-variable t)
-(defvar package--compatibility-table nil
- "Hash table connecting package names to their compatibility.
-Each key is a symbol, the name of a package.
-
-The value is either nil, representing an incompatible package, or
-a version list, representing the highest compatible version of
-that package which is available.
-
-A package is considered incompatible if it requires an Emacs
-version higher than the one being used. To check for package
-\(in)compatibility, don't read this table directly, use
-`package--incompatible-p' which also checks dependencies.")
-
(defvar package-activated-list nil
;; FIXME: This should implicitly include all builtin packages.
"List of the names of currently activated packages.")
(put 'package-activated-list 'risky-local-variable t)
+;;;; Populating `package-alist'.
+;; The following functions are called on each installed package by
+;; `package-load-all-descriptors', which ultimately populates the
+;; `package-alist' variable.
+(defun package-process-define-package (exp)
+ (when (eq (car-safe exp) 'define-package)
+ (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp)))
+ (name (package-desc-name new-pkg-desc))
+ (version (package-desc-version new-pkg-desc))
+ (old-pkgs (assq name package-alist)))
+ (if (null old-pkgs)
+ ;; If there's no old package, just add this to `package-alist'.
+ (push (list name new-pkg-desc) package-alist)
+ ;; If there is, insert the new package at the right place in the list.
+ (while
+ (if (and (cdr old-pkgs)
+ (version-list-< version
+ (package-desc-version (cadr old-pkgs))))
+ (setq old-pkgs (cdr old-pkgs))
+ (push new-pkg-desc (cdr old-pkgs))
+ nil)))
+ new-pkg-desc)))
+
(define-obsolete-function-alias 'package-version-join 'version-join)
(defun package-load-descriptor (pkg-dir)
@@ -490,8 +512,9 @@ version higher than the one being used. To check for
package
(with-temp-buffer
(insert-file-contents pkg-file)
(goto-char (point-min))
- (let ((pkg-desc (package-process-define-package
- (read (current-buffer)) pkg-file)))
+ (let ((pkg-desc (or (package-process-define-package
+ (read (current-buffer)))
+ (error "Can't find define-package in %s"
pkg-file))))
(setf (package-desc-dir pkg-desc) pkg-dir)
(if (file-exists-p signed-file)
(setf (package-desc-signed pkg-desc) t))
@@ -513,6 +536,24 @@ updates `package-alist'."
(when (file-directory-p pkg-dir)
(package-load-descriptor pkg-dir)))))))
+(defun define-package (_name-string _version-string
+ &optional _docstring _requirements
+ &rest _extra-properties)
+ "Define a new package.
+NAME-STRING is the name of the package, as a string.
+VERSION-STRING is the version of the package, as a string.
+DOCSTRING is a short description of the package, a string.
+REQUIREMENTS is a list of dependencies on other packages.
+ Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
+ where OTHER-VERSION is a string.
+
+EXTRA-PROPERTIES is currently unused."
+ ;; FIXME: Placeholder! Should we keep it?
+ (error "Don't call me!"))
+
+
+;;; Package activation
+;; Section for functions used by `package-activate', which see.
(defun package-disabled-p (pkg-name version)
"Return whether PKG-NAME at VERSION can be activated.
The decision is made according to `package-load-list'.
@@ -528,6 +569,20 @@ 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-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."
+ (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))))))
+
(defvar Info-directory-list)
(declare-function info-initialize "info" ())
@@ -575,6 +630,7 @@ correspond to previously loaded files (those returned by
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
@@ -609,33 +665,14 @@ DIR, sorted by most recently loaded last."
;; 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."
- (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)
- :version (package--bi-desc-version bi-desc)
- :summary (package--bi-desc-summary bi-desc)
- :dir 'builtin))
-
-;; This function goes ahead and activates a newer version of a package
-;; if an older one was already activated. This is not ideal; we'd at
-;; least need to check to see if the package has actually been loaded,
-;; and not merely activated.
+;;;; `package-activate'
+;; This function activates a newer version of a package if an older
+;; one was already activated. It also loads a features of this
+;; package which were already loaded.
(defun package-activate (package &optional force)
"Activate package PACKAGE.
-If FORCE is true, (re-)activate it if it's already activated."
+If FORCE is true, (re-)activate it if it's already activated.
+Newer versions are always activated, regardless of FORCE."
(let ((pkg-descs (cdr (assq package package-alist))))
;; Check if PACKAGE is available in `package-alist'.
(while
@@ -667,76 +704,14 @@ Required package `%s-%s' is unavailable"
;; If all goes well, activate the package itself.
(package-activate-1 pkg-vec force)))))))
-(defun define-package (_name-string _version-string
- &optional _docstring _requirements
- &rest _extra-properties)
- "Define a new package.
-NAME-STRING is the name of the package, as a string.
-VERSION-STRING is the version of the package, as a string.
-DOCSTRING is a short description of the package, a string.
-REQUIREMENTS is a list of dependencies on other packages.
- Each requirement is of the form (OTHER-PACKAGE OTHER-VERSION),
- where OTHER-VERSION is a string.
-
-EXTRA-PROPERTIES is currently unused."
- ;; FIXME: Placeholder! Should we keep it?
- (error "Don't call me!"))
-
-(defun package-process-define-package (exp origin)
- (unless (eq (car-safe exp) 'define-package)
- (error "Can't find define-package in %s" origin))
- (let* ((new-pkg-desc (apply #'package-desc-from-define (cdr exp)))
- (name (package-desc-name new-pkg-desc))
- (version (package-desc-version new-pkg-desc))
- (old-pkgs (assq name package-alist)))
- (if (null old-pkgs)
- ;; If there's no old package, just add this to `package-alist'.
- (push (list name new-pkg-desc) package-alist)
- ;; If there is, insert the new package at the right place in the list.
- (while
- (if (and (cdr old-pkgs)
- (version-list-< version
- (package-desc-version (cadr old-pkgs))))
- (setq old-pkgs (cdr old-pkgs))
- (push new-pkg-desc (cdr old-pkgs))
- nil)))
- new-pkg-desc))
-
-;; From Emacs 22, but changed so it adds to load-path.
-(defun package-autoload-ensure-default-file (file)
- "Make sure that the autoload file FILE exists and if not create it."
- (unless (file-exists-p file)
- (write-region
- (concat ";;; " (file-name-nondirectory file)
- " --- automatically extracted autoloads\n"
- ";;\n"
- ";;; Code:\n"
- "(add-to-list 'load-path (or (file-name-directory #$) (car
load-path)))\n"
- " \n;; Local Variables:\n"
- ";; version-control: never\n"
- ";; no-byte-compile: t\n"
- ";; no-update-autoloads: t\n"
- ";; End:\n"
- ";;; " (file-name-nondirectory file)
- " ends here\n")
- nil file nil 'silent))
- file)
-
-(defvar generated-autoload-file)
-(defvar version-control)
-
-(defun package-generate-autoloads (name pkg-dir)
- (let* ((auto-name (format "%s-autoloads.el" name))
- ;;(ignore-name (concat name "-pkg.el"))
- (generated-autoload-file (expand-file-name auto-name pkg-dir))
- (backup-inhibited t)
- (version-control 'never))
- (package-autoload-ensure-default-file generated-autoload-file)
- (update-directory-autoloads pkg-dir)
- (let ((buf (find-buffer-visiting generated-autoload-file)))
- (when buf (kill-buffer buf)))
- auto-name))
+
+;;; Installation -- Local operations
+;; This section contains a variety of features regarding installing a
+;; package to/from disk. This includes autoload generation,
+;; unpacking, compiling, as well as defining a package from the
+;; current buffer.
+;;;; Unpacking
(defvar tar-parse-info)
(declare-function tar-untar-buffer "tar-mode" ())
(declare-function tar-header-name "tar-mode" (tar-header) t)
@@ -761,34 +736,6 @@ 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-file)
- "Create the foo-pkg.el file for single-file packages."
- (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
- (symbol-name name)
- (package-version-join (package-desc-version pkg-desc))
- (package-desc-summary pkg-desc)
- (let ((requires (package-desc-reqs pkg-desc)))
- (list 'quote
- ;; Turn version lists into string form.
- (mapcar
- (lambda (elt)
- (list (car elt)
- (package-version-join (cadr elt))))
- requires))))
- (package--alist-to-plist-args
- (package-desc-extras pkg-desc))))
- "\n")
- nil pkg-file nil 'silent))))
-
(defun package--alist-to-plist-args (alist)
(mapcar 'macroexp-quote
(apply #'nconc
@@ -835,6 +782,70 @@ untar into a directory named DIR; otherwise, signal an
error."
(package-activate name 'force)
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)))
+ (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
+ (symbol-name name)
+ (package-version-join (package-desc-version pkg-desc))
+ (package-desc-summary pkg-desc)
+ (let ((requires (package-desc-reqs pkg-desc)))
+ (list 'quote
+ ;; Turn version lists into string form.
+ (mapcar
+ (lambda (elt)
+ (list (car elt)
+ (package-version-join (cadr elt))))
+ requires))))
+ (package--alist-to-plist-args
+ (package-desc-extras pkg-desc))))
+ "\n")
+ nil pkg-file nil 'silent))))
+
+;;;; Autoload
+;; From Emacs 22, but changed so it adds to load-path.
+(defun package-autoload-ensure-default-file (file)
+ "Make sure that the autoload file FILE exists and if not create it."
+ (unless (file-exists-p file)
+ (write-region
+ (concat ";;; " (file-name-nondirectory file)
+ " --- automatically extracted autoloads\n"
+ ";;\n"
+ ";;; Code:\n"
+ "(add-to-list 'load-path (or (file-name-directory #$) (car
load-path)))\n"
+ " \n;; Local Variables:\n"
+ ";; version-control: never\n"
+ ";; no-byte-compile: t\n"
+ ";; no-update-autoloads: t\n"
+ ";; End:\n"
+ ";;; " (file-name-nondirectory file)
+ " ends here\n")
+ nil file nil 'silent))
+ file)
+
+(defvar generated-autoload-file)
+(defvar version-control)
+
+(defun package-generate-autoloads (name pkg-dir)
+ (let* ((auto-name (format "%s-autoloads.el" name))
+ ;;(ignore-name (concat name "-pkg.el"))
+ (generated-autoload-file (expand-file-name auto-name pkg-dir))
+ (backup-inhibited t)
+ (version-control 'never))
+ (package-autoload-ensure-default-file generated-autoload-file)
+ (update-directory-autoloads pkg-dir)
+ (let ((buf (find-buffer-visiting generated-autoload-file)))
+ (when buf (kill-buffer buf)))
+ auto-name))
+
(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)
@@ -845,33 +856,150 @@ untar into a directory named DIR; otherwise, signal an
error."
;; FIXME: Create foo.info and dir file from foo.texi?
)
+;;;; Compilation
(defun package--compile (pkg-desc)
"Byte-compile installed package PKG-DESC."
(package-activate-1 pkg-desc)
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t))
-(defun package--write-file-no-coding (file-name)
- (let ((buffer-file-coding-system 'no-conversion))
- (write-region (point-min) (point-max) file-name nil 'silent)))
+;;;; Inferring package from current buffer
+(defun package-read-from-string (str)
+ "Read a Lisp expression from STR.
+Signal an error if the entire string was not used."
+ (let* ((read-data (read-from-string str))
+ (more-left
+ (condition-case nil
+ ;; The call to `ignore' suppresses a compiler warning.
+ (progn (ignore (read-from-string
+ (substring str (cdr read-data))))
+ t)
+ (end-of-file nil))))
+ (if more-left
+ (error "Can't read whole string")
+ (car read-data))))
-(defmacro package--with-work-buffer (location file &rest body)
- "Run BODY in a buffer containing the contents of FILE at LOCATION.
-LOCATION is the base location of a package archive, and should be
-one of the URLs (or file names) specified in `package-archives'.
-FILE is the name of a file relative to that base location.
+(defun package--prepare-dependencies (deps)
+ "Turn DEPS into an acceptable list of dependencies.
-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))
- `(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))
+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))))
+
+(declare-function lm-header "lisp-mnt" (header))
+
+(defun package-buffer-info ()
+ "Return a `package-desc' describing the package in the current buffer.
+
+If the buffer does not contain a conforming package, signal an
+error. If there is a package, narrow the buffer to the file's
+boundaries."
+ (goto-char (point-min))
+ (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[
\t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
+ (error "Package lacks a file header"))
+ (let ((file-name (match-string-no-properties 1))
+ (desc (match-string-no-properties 2))
+ (start (line-beginning-position)))
+ (unless (search-forward (concat ";;; " file-name ".el ends here"))
+ (error "Package lacks a terminating comment"))
+ ;; Try to include a trailing newline.
+ (forward-line)
+ (narrow-to-region start (point))
+ (require 'lisp-mnt)
+ ;; Use some headers we've invented to drive the process.
+ (let* ((requires-str (lm-header "package-requires"))
+ ;; Prefer Package-Version; if defined, the package author
+ ;; probably wants us to use it. Otherwise try Version.
+ (pkg-version
+ (or (package-strip-rcs-id (lm-header "package-version"))
+ (package-strip-rcs-id (lm-header "version"))))
+ (homepage (lm-homepage)))
+ (unless pkg-version
+ (error
+ "Package lacks a \"Version\" or \"Package-Version\" header"))
+ (package-desc-from-define
+ file-name pkg-version desc
+ (if requires-str
+ (package--prepare-dependencies
+ (package-read-from-string requires-str)))
+ :kind 'single
+ :url homepage))))
+
+(defun package--read-pkg-desc (kind)
+ "Read a `define-package' form in current buffer.
+Return the pkg-desc, with desc-kind set to KIND."
+ (goto-char (point-min))
+ (unwind-protect
+ (let* ((pkg-def-parsed (read (current-buffer)))
+ (pkg-desc
+ (when (eq (car pkg-def-parsed) 'define-package)
+ (apply #'package-desc-from-define
+ (append (cdr pkg-def-parsed))))))
+ (when pkg-desc
+ (setf (package-desc-kind pkg-desc) kind)
+ pkg-desc))))
+
+(declare-function tar-get-file-descriptor "tar-mode" (file))
+(declare-function tar--extract "tar-mode" (descriptor))
+
+(defun package-tar-file-info ()
+ "Find package information for a tar file.
+The return result is a `package-desc'."
+ (cl-assert (derived-mode-p 'tar-mode))
+ (let* ((dir-name (file-name-directory
+ (tar-header-name (car tar-parse-info))))
+ (desc-file (package--description-file dir-name))
+ (tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
+ (unless tar-desc
+ (error "No package descriptor file found"))
+ (with-current-buffer (tar--extract tar-desc)
+ (unwind-protect
+ (or (package--read-pkg-desc 'tar)
+ (error "Can't find define-package in %s"
+ (tar-header-name tar-desc)))
+ (kill-buffer (current-buffer))))))
+
+(defun package-dir-info ()
+ "Find package information for a directory.
+The return result is a `package-desc'."
+ (cl-assert (derived-mode-p 'dired-mode))
+ (let* ((desc-file (package--description-file default-directory)))
+ (if (file-readable-p desc-file)
+ (with-temp-buffer
+ (insert-file-contents desc-file)
+ (package--read-pkg-desc 'dir))
+ (let ((files (directory-files default-directory t "\\.el\\'" t))
+ info)
+ (while files
+ (with-temp-buffer
+ (insert-file-contents (pop files))
+ ;; When we find the file with the data,
+ (when (setq info (ignore-errors (package-buffer-info)))
+ ;; stop looping,
+ (setq files nil)
+ ;; set the 'dir kind,
+ (setf (package-desc-kind info) 'dir))))
+ ;; and return the info.
+ info))))
+
+
+;;; Communicating with Archives
+;; Set of low-level functions for communicating with archives and
+;; signature checking.
+(defun package--write-file-no-coding (file-name)
+ (let ((buffer-file-coding-system 'no-conversion))
+ (write-region (point-min) (point-max) file-name nil 'silent)))
(declare-function url-http-file-exists-p "url-http" (url))
@@ -906,6 +1034,25 @@ buffer is killed afterwards. Return the last value in
BODY."
(insert (format "Error while verifying signature %s:\n" sig-file)))
(insert "\nCommand output:\n" (epg-context-error-output context))))))
+(defmacro package--with-work-buffer (location file &rest body)
+ "Run BODY in a buffer containing the contents of FILE at LOCATION.
+LOCATION is the base location of a package archive, and should be
+one of the URLs (or file names) specified in `package-archives'.
+FILE is the name of a file relative to that base location.
+
+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))
+ `(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--check-signature (location file)
"Check signature of the current buffer.
GnuPG keyring is located under \"gnupg\" in `package-user-dir'."
@@ -938,94 +1085,284 @@ GnuPG keyring is located under \"gnupg\" in
`package-user-dir'."
(error "Failed to verify signature %s" sig-file))
good-signatures)))
-(defun package-install-from-archive (pkg-desc)
- "Download and install a tar package."
- ;; This won't happen, unless the archive is doing something wrong.
- (when (eq (package-desc-kind pkg-desc) 'dir)
- (error "Can't install directory package from archive"))
- (let* ((location (package-archive-base pkg-desc))
- (file (concat (package-desc-full-name pkg-desc)
- (package-desc-suffix pkg-desc)))
- (sig-file (concat file ".sig"))
- good-signatures pkg-descs)
- (package--with-work-buffer location file
- (if (and package-check-signature
- (not (member (package-desc-archive pkg-desc)
- package-unsigned-archives)))
- (if (package--archive-file-exists-p location sig-file)
- (setq good-signatures (package--check-signature location file))
- (unless (eq package-check-signature 'allow-unsigned)
- (error "Unsigned package: `%s'"
- (package-desc-name pkg-desc)))))
- (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)))))
+
+;;; Packages on Archives
+;; The following variables store information about packages available
+;; from archives. The most important of these is
+;; `package-archive-contents' which is initially populated by the
+;; function `package-read-all-archive-contents' from a cache on disk.
+;; The `package-initialize' command is also closely related to this
+;; section, but it has its own section.
+(defconst package-archive-version 1
+ "Version number of the package archive understood by this file.
+Lower version numbers than this will probably be understood as well.")
-(defvar package--initialized nil)
+;; We don't prime the cache since it tends to get out of date.
+(defvar package-archive-contents nil
+ "Cache of the contents of the Emacs Lisp Package Archive.
+This is an alist mapping package names (symbols) to
+non-empty lists of `package-desc' structures.")
+(put 'package-archive-contents 'risky-local-variable t)
-(defun package-installed-p (package &optional min-version)
- "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
-If PACKAGE is a symbol, it is the package name and MIN-VERSION
-should be a version list.
+(defvar package--compatibility-table nil
+ "Hash table connecting package names to their compatibility.
+Each key is a symbol, the name of a package.
-If PACKAGE is a package-desc object, MIN-VERSION is ignored."
- (unless package--initialized (error "package.el is not yet initialized!"))
- (if (package-desc-p package)
- (let ((dir (package-desc-dir package)))
- (and (stringp dir)
- (file-exists-p dir)))
- (or
- (let ((pkg-descs (cdr (assq package package-alist))))
- (and pkg-descs
- (version-list-<= min-version
- (package-desc-version (car pkg-descs)))))
- ;; Also check built-in packages.
- (package-built-in-p package min-version))))
+The value is either nil, representing an incompatible package, or
+a version list, representing the highest compatible version of
+that package which is available.
-(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'.
+A package is considered incompatible if it requires an Emacs
+version higher than the one being used. To check for package
+\(in)compatibility, don't read this table directly, use
+`package--incompatible-p' which also checks dependencies.")
-REQUIREMENTS should be a list of additional requirements; each
-element in this list should have the form (PACKAGE VERSION-LIST),
-where PACKAGE is a package name and VERSION-LIST is the required
-version of that package.
+(defun package--build-compatibility-table ()
+ "Build `package--compatibility-table' with `package--mapc'."
+ ;; Build compat table.
+ (setq package--compatibility-table (make-hash-table :test 'eq))
+ (package--mapc #'package--add-to-compatibility-table))
-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.
+(defun package--add-to-compatibility-table (pkg)
+ "If PKG is compatible (without dependencies), add to the compatibility table.
+PKG is a package-desc object.
+Only adds if its version is higher than what's already stored in
+the table."
+ (unless (package--incompatible-p pkg 'shallow)
+ (let* ((name (package-desc-name pkg))
+ (version (or (package-desc-version pkg) '(0)))
+ (table-version (gethash name package--compatibility-table)))
+ (when (or (not table-version)
+ (version-list-< table-version version))
+ (puthash name version package--compatibility-table)))))
-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:
- ;; the current code might fail to see that it could install foo by using the
- ;; older bar-1.3).
- (dolist (elt requirements)
- (let* ((next-pkg (car elt))
- (next-version (cadr elt))
- (already ()))
- (dolist (pkg packages)
- (if (eq next-pkg (package-desc-name pkg))
- (setq already pkg)))
- (when already
- (if (version-list-<= next-version (package-desc-version already))
+;; Package descriptor objects used inside the "archive-contents" file.
+;; Changing this defstruct implies changing the format of the
+;; "archive-contents" files.
+(cl-defstruct (package--ac-desc
+ (:constructor package-make-ac-desc (version reqs summary kind
extras))
+ (:copier nil)
+ (:type vector))
+ version reqs summary kind extras)
+
+(defun package--append-to-alist (pkg-desc alist)
+ "Append an entry for PKG-DESC to the start of ALIST and return it.
+This entry takes the form (`package-desc-name' PKG-DESC).
+
+If ALIST already has an entry with this name, destructively add
+PKG-DESC to the cdr of this entry instead, sorted by version
+number."
+ (let* ((name (package-desc-name pkg-desc))
+ (priority-version (package-desc-priority-version pkg-desc))
+ (existing-packages (assq name alist)))
+ (if (not existing-packages)
+ (cons (list name pkg-desc)
+ alist)
+ (while (if (and (cdr existing-packages)
+ (version-list-< priority-version
+ (package-desc-priority-version
+ (cadr existing-packages))))
+ (setq existing-packages (cdr existing-packages))
+ (push pkg-desc (cdr existing-packages))
+ nil))
+ alist)))
+
+(defun package--add-to-archive-contents (package archive)
+ "Add the PACKAGE from the given ARCHIVE if necessary.
+PACKAGE should have the form (NAME . PACKAGE--AC-DESC).
+Also, add the originating archive to the `package-desc' structure."
+ (let* ((name (car package))
+ (version (package--ac-desc-version (cdr package)))
+ (pkg-desc
+ (package-desc-create
+ :name name
+ :version version
+ :reqs (package--ac-desc-reqs (cdr package))
+ :summary (package--ac-desc-summary (cdr package))
+ :kind (package--ac-desc-kind (cdr package))
+ :archive archive
+ :extras (and (> (length (cdr package)) 4)
+ ;; Older archive-contents files have only 4
+ ;; elements here.
+ (package--ac-desc-extras (cdr package)))))
+ (pinned-to-archive (assoc name package-pinned-packages)))
+ ;; Skip entirely if pinned to another archive.
+ (when (not (and pinned-to-archive
+ (not (equal (cdr pinned-to-archive) archive))))
+ (setq package-archive-contents
+ (package--append-to-alist pkg-desc package-archive-contents)))))
+
+(defun package--read-archive-file (file)
+ "Re-read archive file FILE, if it exists.
+Will return the data from the file, or nil if the file does not exist.
+Will throw an error if the archive version is too new."
+ (let ((filename (expand-file-name file package-user-dir)))
+ (when (file-exists-p filename)
+ (with-temp-buffer
+ (insert-file-contents-literally filename)
+ (let ((contents (read (current-buffer))))
+ (if (> (car contents) package-archive-version)
+ (error "Package archive version %d is higher than %d"
+ (car contents) package-archive-version))
+ (cdr contents))))))
+
+(defun package-read-archive-contents (archive)
+ "Re-read archive contents for ARCHIVE.
+If successful, set the variable `package-archive-contents'.
+If the archive version is too new, signal an error."
+ ;; Version 1 of 'archive-contents' is identical to our internal
+ ;; representation.
+ (let* ((contents-file (format "archives/%s/archive-contents" archive))
+ (contents (package--read-archive-file contents-file)))
+ (when contents
+ (dolist (package contents)
+ (package--add-to-archive-contents package archive)))))
+
+(defun package-read-all-archive-contents ()
+ "Re-read `archive-contents', if it exists.
+If successful, set `package-archive-contents'."
+ (setq package-archive-contents nil)
+ (dolist (archive package-archives)
+ (package-read-archive-contents (car archive))))
+
+;;;; Package Initialize
+;; A bit of a milestone. This brings together some of the above
+;; sections and populates all relevant lists of packages from contents
+;; available on disk.
+(defvar package--initialized nil)
+
+;;;###autoload
+(defun package-initialize (&optional no-activate)
+ "Load Emacs Lisp packages, and activate them.
+The variable `package-load-list' controls which packages to load.
+If optional arg NO-ACTIVATE is non-nil, don't activate packages."
+ (interactive)
+ (setq package-alist nil)
+ (package-load-all-descriptors)
+ (package-read-all-archive-contents)
+ (unless no-activate
+ (dolist (elt package-alist)
+ (package-activate (car elt))))
+ (setq package--initialized t)
+ ;; This uses `package--mapc' so it must be called after
+ ;; `package--initialized' is t.
+ (package--build-compatibility-table))
+
+
+;;;; Populating `package-archive-contents' from archives
+;; This subsection populates the variables listed above from the
+;; actual archives, instead of from a local cache.
+(defun package--download-one-archive (archive file)
+ "Retrieve an archive file FILE from ARCHIVE, and cache it.
+ARCHIVE should be a cons cell of the form (NAME . LOCATION),
+similar to an entry in `package-alist'. Save the cached copy to
+\"archives/NAME/archive-contents\" in `package-user-dir'."
+ (let ((dir (expand-file-name (format "archives/%s" (car archive))
+ package-user-dir))
+ (sig-file (concat file ".sig"))
+ good-signatures)
+ (package--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 (current-buffer)))
+ (make-directory dir t)
+ (write-region nil nil (expand-file-name file dir) nil 'silent)))
+ (when good-signatures
+ ;; Write out good signatures into archive-contents.signed file.
+ (write-region (mapconcat #'epg-signature-to-string good-signatures "\n")
+ nil
+ (expand-file-name (concat file ".signed") dir)
+ nil '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 ()
+ "Download descriptions of all configured ELPA packages.
+For each archive configured in the variable `package-archives',
+inform Emacs about the latest versions of all packages it offers,
+and make them available for download."
+ (interactive)
+ ;; 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")
+ (error (message "Failed to download `%s' archive."
+ (car archive)))))
+ (package-read-all-archive-contents)
+ (package--build-compatibility-table))
+
+
+;;; Dependency Management
+;; Calculating the full transaction necessary for an installation,
+;; keeping track of which packages were installed strictly as
+;; dependencies, and determining which packages cannot be removed
+;; because they are dependencies.
+(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'.
+
+REQUIREMENTS should be a list of additional requirements; each
+element in this list should have the form (PACKAGE VERSION-LIST),
+where PACKAGE is a package name and VERSION-LIST is the required
+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.
+
+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:
+ ;; the current code might fail to see that it could install foo by using the
+ ;; older bar-1.3).
+ (dolist (elt requirements)
+ (let* ((next-pkg (car elt))
+ (next-version (cadr elt))
+ (already ()))
+ (dolist (pkg packages)
+ (if (eq next-pkg (package-desc-name pkg))
+ (setq already pkg)))
+ (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
@@ -1080,120 +1417,178 @@ but version %s required"
(cons found seen))))))))
packages)
-(defun package-read-from-string (str)
- "Read a Lisp expression from STR.
-Signal an error if the entire string was not used."
- (let* ((read-data (read-from-string str))
- (more-left
- (condition-case nil
- ;; The call to `ignore' suppresses a compiler warning.
- (progn (ignore (read-from-string
- (substring str (cdr read-data))))
- t)
- (end-of-file nil))))
- (if more-left
- (error "Can't read whole string")
- (car read-data))))
+(defun package--find-non-dependencies ()
+ "Return a list of installed packages which are not dependencies.
+Finds all packages in `package-alist' which are not dependencies
+of any other packages.
+Used to populate `package-selected-packages'."
+ (let ((dep-list
+ (delete-dups
+ (apply #'append
+ (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr p))))
+ package-alist)))))
+ (cl-loop for p in package-alist
+ for name = (car p)
+ unless (memq name dep-list)
+ collect name)))
-(defun package--read-archive-file (file)
- "Re-read archive file FILE, if it exists.
-Will return the data from the file, or nil if the file does not exist.
-Will throw an error if the archive version is too new."
- (let ((filename (expand-file-name file package-user-dir)))
- (when (file-exists-p filename)
- (with-temp-buffer
- (insert-file-contents-literally filename)
- (let ((contents (read (current-buffer))))
- (if (> (car contents) package-archive-version)
- (error "Package archive version %d is higher than %d"
- (car contents) package-archive-version))
- (cdr contents))))))
+(defun package--user-selected-p (pkg)
+ "Return non-nil if PKG is a package was installed by the user.
+PKG is a package name.
+This looks into `package-selected-packages', populating it first
+if it is still empty."
+ (unless (consp package-selected-packages)
+ (customize-save-variable
+ 'package-selected-packages
+ (setq package-selected-packages (package--find-non-dependencies))))
+ (memq pkg package-selected-packages))
-(defun package-read-all-archive-contents ()
- "Re-read `archive-contents', if it exists.
-If successful, set `package-archive-contents'."
- (setq package-archive-contents nil)
- (dolist (archive package-archives)
- (package-read-archive-contents (car archive))))
+(defun package--get-deps (pkg &optional only)
+ (let* ((pkg-desc (cadr (assq pkg package-alist)))
+ (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc)
+ for name = (car p)
+ when (assq name package-alist)
+ collect name))
+ (indirect-deps (unless (eq only 'direct)
+ (delete-dups
+ (cl-loop for p in direct-deps
+ append (package--get-deps p))))))
+ (cl-case only
+ (direct direct-deps)
+ (separate (list direct-deps indirect-deps))
+ (indirect indirect-deps)
+ (t (delete-dups (append direct-deps indirect-deps))))))
-(defun package-read-archive-contents (archive)
- "Re-read archive contents for ARCHIVE.
-If successful, set the variable `package-archive-contents'.
-If the archive version is too new, signal an error."
- ;; Version 1 of 'archive-contents' is identical to our internal
- ;; representation.
- (let* ((contents-file (format "archives/%s/archive-contents" archive))
- (contents (package--read-archive-file contents-file)))
- (when contents
- (dolist (package contents)
- (package--add-to-archive-contents package archive)))))
+(defun package--removable-packages ()
+ "Return a list of names of packages no longer needed.
+These are packages which are neither contained in
+`package-selected-packages' nor a dependency of one that is."
+ (let ((needed (cl-loop for p in package-selected-packages
+ if (assq p package-alist)
+ ;; `p' and its dependencies are needed.
+ append (cons p (package--get-deps p)))))
+ (cl-loop for p in (mapcar #'car package-alist)
+ unless (memq p needed)
+ collect p)))
-;; Package descriptor objects used inside the "archive-contents" file.
-;; Changing this defstruct implies changing the format of the
-;; "archive-contents" files.
-(cl-defstruct (package--ac-desc
- (:constructor package-make-ac-desc (version reqs summary kind
extras))
- (:copier nil)
- (:type vector))
- version reqs summary kind extras)
+(defun package--used-elsewhere-p (pkg-desc &optional pkg-list)
+ "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST.
+Return the first package found in PKG-LIST of which PKG is a
+dependency.
+
+When not specified, PKG-LIST defaults to `package-alist'
+with PKG-DESC entry removed."
+ (unless (string= (package-desc-status pkg-desc) "obsolete")
+ (let ((pkg (package-desc-name pkg-desc)))
+ (cl-loop with alist = (or pkg-list
+ (remove (assq pkg package-alist)
+ package-alist))
+ for p in alist thereis
+ (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p))))
+ (car p))))))
+
+(defun package--sort-deps-in-alist (package only)
+ "Return a list of dependencies for PACKAGE sorted by dependency.
+PACKAGE is included as the first element of the returned list.
+ONLY is an alist associating package names to package objects.
+Only these packages will be in the return value an their cdrs are
+destructively set to nil in ONLY."
+ (let ((out))
+ (dolist (dep (package-desc-reqs package))
+ (when-let ((cell (assq (car dep) only))
+ (dep-package (cdr-safe cell)))
+ (setcdr cell nil)
+ (setq out (append (package--sort-deps-in-alist dep-package only)
+ out))))
+ (cons package out)))
+
+(defun package--sort-by-dependence (package-list)
+ "Return PACKAGE-LIST sorted by dependence.
+That is, any element of the returned list is guaranteed to not
+directly depend on any elements that come before it.
-(defun package--add-to-archive-contents (package archive)
- "Add the PACKAGE from the given ARCHIVE if necessary.
-PACKAGE should have the form (NAME . PACKAGE--AC-DESC).
-Also, add the originating archive to the `package-desc' structure."
- (let* ((name (car package))
- (version (package--ac-desc-version (cdr package)))
- (pkg-desc
- (package-desc-create
- :name name
- :version version
- :reqs (package--ac-desc-reqs (cdr package))
- :summary (package--ac-desc-summary (cdr package))
- :kind (package--ac-desc-kind (cdr package))
- :archive archive
- :extras (and (> (length (cdr package)) 4)
- ;; Older archive-contents files have only 4
- ;; elements here.
- (package--ac-desc-extras (cdr package)))))
- (pinned-to-archive (assoc name package-pinned-packages)))
- ;; Skip entirely if pinned to another archive.
- (when (not (and pinned-to-archive
- (not (equal (cdr pinned-to-archive) archive))))
- (setq package-archive-contents
- (package--append-to-alist pkg-desc package-archive-contents)))))
+PACKAGE-LIST is a list of package-desc objects.
+Indirect dependencies are guaranteed to be returned in order only
+if all the in-between dependencies are also in PACKAGE-LIST."
+ (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p))
package-list))
+ out-list)
+ (dolist (cell alist out-list)
+ ;; `package--sort-deps-in-alist' destructively changes alist, so
+ ;; some cells might already be empty. We check this here.
+ (when-let ((pkg-desc (cdr cell)))
+ (setcdr cell nil)
+ (setq out-list
+ (append (package--sort-deps-in-alist pkg-desc alist)
+ out-list))))))
-(defun package--append-to-alist (pkg-desc alist)
- "Append an entry for PKG-DESC to the start of ALIST and return it.
-This entry takes the form (`package-desc-name' PKG-DESC).
+
+;;; Installation Functions
+;; As opposed to the previous section (which listed some underlying
+;; functions necessary for installation), this one contains the actual
+;; functions that install packages. The package itself can be
+;; installed in a variety of ways (archives, buffer, file), but
+;; requirements (dependencies) are always satisfied by looking in
+;; `package-archive-contents'.
+(defun package-archive-base (desc)
+ "Return the archive containing the package NAME."
+ (cdr (assoc (package-desc-archive desc) package-archives)))
-If ALIST already has an entry with this name, destructively add
-PKG-DESC to the cdr of this entry instead, sorted by version
-number."
- (let* ((name (package-desc-name pkg-desc))
- (priority-version (package-desc-priority-version pkg-desc))
- (existing-packages (assq name alist)))
- (if (not existing-packages)
- (cons (list name pkg-desc)
- alist)
- (while (if (and (cdr existing-packages)
- (version-list-< priority-version
- (package-desc-priority-version
- (cadr existing-packages))))
- (setq existing-packages (cdr existing-packages))
- (push pkg-desc (cdr existing-packages))
- nil))
- alist)))
+(defun package-install-from-archive (pkg-desc)
+ "Download and install a tar package."
+ ;; This won't happen, unless the archive is doing something wrong.
+ (when (eq (package-desc-kind pkg-desc) 'dir)
+ (error "Can't install directory package from archive"))
+ (let* ((location (package-archive-base pkg-desc))
+ (file (concat (package-desc-full-name pkg-desc)
+ (package-desc-suffix pkg-desc)))
+ (sig-file (concat file ".sig"))
+ good-signatures pkg-descs)
+ (package--with-work-buffer location file
+ (if (and package-check-signature
+ (not (member (package-desc-archive pkg-desc)
+ package-unsigned-archives)))
+ (if (package--archive-file-exists-p location sig-file)
+ (setq good-signatures (package--check-signature location file))
+ (unless (eq package-check-signature 'allow-unsigned)
+ (error "Unsigned package: `%s'"
+ (package-desc-name pkg-desc)))))
+ (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)))))
-(defun package--user-selected-p (pkg)
- "Return non-nil if PKG is a package was installed by the user.
-PKG is a package name.
-This looks into `package-selected-packages', populating it first
-if it is still empty."
- (unless (consp package-selected-packages)
- (customize-save-variable
- 'package-selected-packages
- (setq package-selected-packages (package--find-non-dependencies))))
- (memq pkg package-selected-packages))
+(defun package-installed-p (package &optional min-version)
+ "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
+If PACKAGE is a symbol, it is the package name and MIN-VERSION
+should be a version list.
+
+If PACKAGE is a package-desc object, MIN-VERSION is ignored."
+ (unless package--initialized (error "package.el is not yet initialized!"))
+ (if (package-desc-p package)
+ (let ((dir (package-desc-dir package)))
+ (and (stringp dir)
+ (file-exists-p dir)))
+ (or
+ (let ((pkg-descs (cdr (assq package package-alist))))
+ (and pkg-descs
+ (version-list-<= min-version
+ (package-desc-version (car pkg-descs)))))
+ ;; Also check built-in packages.
+ (package-built-in-p package min-version))))
(defun package-download-transaction (packages)
"Download and install all the packages in PACKAGES.
@@ -1247,20 +1642,6 @@ to install it but still mark it as selected."
(package-compute-transaction ()
(list (list pkg))))))
-;;;###autoload
-(defun package-reinstall (pkg)
- "Reinstall package PKG.
-PKG should be either a symbol, the package name, or a package-desc
-object."
- (interactive (list (intern (completing-read
- "Reinstall package: "
- (mapcar #'symbol-name
- (mapcar #'car package-alist))))))
- (package-delete
- (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist)))
- 'force 'nosave)
- (package-install pkg 'dont-select))
-
(defun package-strip-rcs-id (str)
"Strip RCS version ID from the version string STR.
If the result looks like a dotted numeric version, return it.
@@ -1275,122 +1656,6 @@ 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))))
-
-(declare-function lm-header "lisp-mnt" (header))
-
-(defun package-buffer-info ()
- "Return a `package-desc' describing the package in the current buffer.
-
-If the buffer does not contain a conforming package, signal an
-error. If there is a package, narrow the buffer to the file's
-boundaries."
- (goto-char (point-min))
- (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[
\t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
- (error "Package lacks a file header"))
- (let ((file-name (match-string-no-properties 1))
- (desc (match-string-no-properties 2))
- (start (line-beginning-position)))
- (unless (search-forward (concat ";;; " file-name ".el ends here"))
- (error "Package lacks a terminating comment"))
- ;; Try to include a trailing newline.
- (forward-line)
- (narrow-to-region start (point))
- (require 'lisp-mnt)
- ;; Use some headers we've invented to drive the process.
- (let* ((requires-str (lm-header "package-requires"))
- ;; Prefer Package-Version; if defined, the package author
- ;; probably wants us to use it. Otherwise try Version.
- (pkg-version
- (or (package-strip-rcs-id (lm-header "package-version"))
- (package-strip-rcs-id (lm-header "version"))))
- (homepage (lm-homepage)))
- (unless pkg-version
- (error
- "Package lacks a \"Version\" or \"Package-Version\" header"))
- (package-desc-from-define
- file-name pkg-version desc
- (if requires-str
- (package--prepare-dependencies
- (package-read-from-string requires-str)))
- :kind 'single
- :url homepage))))
-
-(declare-function tar-get-file-descriptor "tar-mode" (file))
-(declare-function tar--extract "tar-mode" (descriptor))
-
-(defun package-tar-file-info ()
- "Find package information for a tar file.
-The return result is a `package-desc'."
- (cl-assert (derived-mode-p 'tar-mode))
- (let* ((dir-name (file-name-directory
- (tar-header-name (car tar-parse-info))))
- (desc-file (package--description-file dir-name))
- (tar-desc (tar-get-file-descriptor (concat dir-name desc-file))))
- (unless tar-desc
- (error "No package descriptor file found"))
- (with-current-buffer (tar--extract tar-desc)
- (unwind-protect
- (or (package--read-pkg-desc 'tar)
- (error "Can't find define-package in %s"
- (tar-header-name tar-desc)))
- (kill-buffer (current-buffer))))))
-
-(defun package-dir-info ()
- "Find package information for a directory.
-The return result is a `package-desc'."
- (cl-assert (derived-mode-p 'dired-mode))
- (let* ((desc-file (package--description-file default-directory)))
- (if (file-readable-p desc-file)
- (with-temp-buffer
- (insert-file-contents desc-file)
- (package--read-pkg-desc 'dir))
- (let ((files (directory-files default-directory t "\\.el\\'" t))
- info)
- (while files
- (with-temp-buffer
- (insert-file-contents (pop files))
- ;; When we find the file with the data,
- (when (setq info (ignore-errors (package-buffer-info)))
- ;; stop looping,
- (setq files nil)
- ;; set the 'dir kind,
- (setf (package-desc-kind info) 'dir))))
- ;; and return the info.
- info))))
-
-(defun package--read-pkg-desc (kind)
- "Read a `define-package' form in current buffer.
-Return the pkg-desc, with desc-kind set to KIND."
- (goto-char (point-min))
- (unwind-protect
- (let* ((pkg-def-parsed (read (current-buffer)))
- (pkg-desc
- (when (eq (car pkg-def-parsed) 'define-package)
- (apply #'package-desc-from-define
- (append (cdr pkg-def-parsed))))))
- (when pkg-desc
- (setf (package-desc-kind pkg-desc) kind)
- pkg-desc))))
-
-
;;;###autoload
(defun package-install-from-buffer ()
"Install a package from the current buffer.
@@ -1442,22 +1707,6 @@ The file can either be a tar file or an Emacs Lisp file."
(when (string-match "\\.tar\\'" file) (tar-mode)))
(package-install-from-buffer)))
-(defun package--get-deps (pkg &optional only)
- (let* ((pkg-desc (cadr (assq pkg package-alist)))
- (direct-deps (cl-loop for p in (package-desc-reqs pkg-desc)
- for name = (car p)
- when (assq name package-alist)
- collect name))
- (indirect-deps (unless (eq only 'direct)
- (delete-dups
- (cl-loop for p in direct-deps
- append (package--get-deps p))))))
- (cl-case only
- (direct direct-deps)
- (separate (list direct-deps indirect-deps))
- (indirect indirect-deps)
- (t (delete-dups (append direct-deps indirect-deps))))))
-
;;;###autoload
(defun package-install-user-selected-packages ()
"Ensure packages in `package-selected-packages' are installed.
@@ -1480,22 +1729,8 @@ If some packages are not installed propose to install
them."
(mapc #'package-install lst))
(message "All your packages are already installed")))))
-(defun package--used-elsewhere-p (pkg-desc &optional pkg-list)
- "Non-nil if PKG-DESC is a dependency of a package in PKG-LIST.
-Return the first package found in PKG-LIST of which PKG is a
-dependency.
-
-When not specified, PKG-LIST defaults to `package-alist'
-with PKG-DESC entry removed."
- (unless (string= (package-desc-status pkg-desc) "obsolete")
- (let ((pkg (package-desc-name pkg-desc)))
- (cl-loop with alist = (or pkg-list
- (remove (assq pkg package-alist)
- package-alist))
- for p in alist thereis
- (and (memq pkg (mapcar #'car (package-desc-reqs (cadr p))))
- (car p))))))
-
+
+;;; Package Deletion
(defun package--newest-p (pkg)
"Return t if PKG is the newest package with its name."
(equal (cadr (assq (package-desc-name pkg) package-alist))
@@ -1550,17 +1785,19 @@ If NOSAVE is non-nil, the package is not removed from
(setq package-alist (delq pkgs package-alist))))
(message "Package `%s' deleted." (package-desc-full-name
pkg-desc))))))
-(defun package--removable-packages ()
- "Return a list of names of packages no longer needed.
-These are packages which are neither contained in
-`package-selected-packages' nor a dependency of one that is."
- (let ((needed (cl-loop for p in package-selected-packages
- if (assq p package-alist)
- ;; `p' and its dependencies are needed.
- append (cons p (package--get-deps p)))))
- (cl-loop for p in (mapcar #'car package-alist)
- unless (memq p needed)
- collect p)))
+;;;###autoload
+(defun package-reinstall (pkg)
+ "Reinstall package PKG.
+PKG should be either a symbol, the package name, or a package-desc
+object."
+ (interactive (list (intern (completing-read
+ "Reinstall package: "
+ (mapcar #'symbol-name
+ (mapcar #'car package-alist))))))
+ (package-delete
+ (if (package-desc-p pkg) pkg (cadr (assq pkg package-alist)))
+ 'force 'nosave)
+ (package-install pkg 'dont-select))
;;;###autoload
(defun package-autoremove ()
@@ -1587,156 +1824,6 @@ will be deleted."
removable))
(message "Nothing to autoremove")))))
-(defun package-archive-base (desc)
- "Return the archive containing the package NAME."
- (cdr (assoc (package-desc-archive desc) package-archives)))
-
-(defun package-archive-priority (archive)
- "Return the priority of ARCHIVE.
-
-The archive priorities are specified in
-`package-archive-priorities'. If not given there, the priority
-defaults to 0."
- (or (cdr (assoc archive package-archive-priorities))
- 0))
-
-(defun package-desc-priority-version (pkg-desc)
- "Return the version PKG-DESC with the archive priority prepended.
-
-This allows for easy comparison of package versions from
-different archives if archive priorities are meant to be taken in
-consideration."
- (cons (package-archive-priority
- (package-desc-archive pkg-desc))
- (package-desc-version pkg-desc)))
-
-(defun package--download-one-archive (archive file)
- "Retrieve an archive file FILE from ARCHIVE, and cache it.
-ARCHIVE should be a cons cell of the form (NAME . LOCATION),
-similar to an entry in `package-alist'. Save the cached copy to
-\"archives/NAME/archive-contents\" in `package-user-dir'."
- (let ((dir (expand-file-name (format "archives/%s" (car archive))
- package-user-dir))
- (sig-file (concat file ".sig"))
- good-signatures)
- (package--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 (current-buffer)))
- (make-directory dir t)
- (write-region nil nil (expand-file-name file dir) nil 'silent)))
- (when good-signatures
- ;; Write out good signatures into archive-contents.signed file.
- (write-region (mapconcat #'epg-signature-to-string good-signatures "\n")
- nil
- (expand-file-name (concat file ".signed") dir)
- nil '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))))
-
-(defun package--build-compatibility-table ()
- "Build `package--compatibility-table' with `package--mapc'."
- ;; Build compat table.
- (setq package--compatibility-table (make-hash-table :test 'eq))
- (package--mapc #'package--add-to-compatibility-table))
-
-;;;###autoload
-(defun package-refresh-contents ()
- "Download descriptions of all configured ELPA packages.
-For each archive configured in the variable `package-archives',
-inform Emacs about the latest versions of all packages it offers,
-and make them available for download."
- (interactive)
- ;; 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")
- (error (message "Failed to download `%s' archive."
- (car archive)))))
- (package-read-all-archive-contents)
- (package--build-compatibility-table))
-
-(defun package--find-non-dependencies ()
- "Return a list of installed packages which are not dependencies.
-Finds all packages in `package-alist' which are not dependencies
-of any other packages.
-Used to populate `package-selected-packages'."
- (let ((dep-list
- (delete-dups
- (apply #'append
- (mapcar (lambda (p) (mapcar #'car (package-desc-reqs (cadr
p))))
- package-alist)))))
- (cl-loop for p in package-alist
- for name = (car p)
- unless (memq name dep-list)
- collect name)))
-
-;;;###autoload
-(defun package-initialize (&optional no-activate)
- "Load Emacs Lisp packages, and activate them.
-The variable `package-load-list' controls which packages to load.
-If optional arg NO-ACTIVATE is non-nil, don't activate packages."
- (interactive)
- (setq package-alist nil)
- (package-load-all-descriptors)
- (package-read-all-archive-contents)
- (unless no-activate
- (dolist (elt package-alist)
- (package-activate (car elt))))
- (setq package--initialized t)
- ;; This uses `package--mapc' so it must be called after
- ;; `package--initialized' is t.
- (package--build-compatibility-table))
-
-(defun package--add-to-compatibility-table (pkg)
- "If PKG is compatible (without dependencies), add to the compatibility table.
-PKG is a package-desc object.
-Only adds if its version is higher than what's already stored in
-the table."
- (unless (package--incompatible-p pkg 'shallow)
- (let* ((name (package-desc-name pkg))
- (version (or (package-desc-version pkg) '(0)))
- (table-version (gethash name package--compatibility-table)))
- (when (or (not table-version)
- (version-list-< table-version version))
- (puthash name version package--compatibility-table)))))
-
;;;; Package description buffer.
@@ -2366,6 +2453,25 @@ If optional arg BUTTON is non-nil, describe its
associated package."
(aref (cadr entry) 2)
"")))
+(defun package-archive-priority (archive)
+ "Return the priority of ARCHIVE.
+
+The archive priorities are specified in
+`package-archive-priorities'. If not given there, the priority
+defaults to 0."
+ (or (cdr (assoc archive package-archive-priorities))
+ 0))
+
+(defun package-desc-priority-version (pkg-desc)
+ "Return the version PKG-DESC with the archive priority prepended.
+
+This allows for easy comparison of package versions from
+different archives if archive priorities are meant to be taken in
+consideration."
+ (cons (package-archive-priority
+ (package-desc-archive pkg-desc))
+ (package-desc-version pkg-desc)))
+
(defun package-menu--find-upgrades ()
(let (installed available upgrades)
;; Build list of installed/available packages in this buffer.
@@ -2415,40 +2521,6 @@ call will upgrade the package."
(length upgrades)
(if (= (length upgrades) 1) "" "s")))))
-(defun package--sort-deps-in-alist (package only)
- "Return a list of dependencies for PACKAGE sorted by dependency.
-PACKAGE is included as the first element of the returned list.
-ONLY is an alist associating package names to package objects.
-Only these packages will be in the return value an their cdrs are
-destructively set to nil in ONLY."
- (let ((out))
- (dolist (dep (package-desc-reqs package))
- (when-let ((cell (assq (car dep) only))
- (dep-package (cdr-safe cell)))
- (setcdr cell nil)
- (setq out (append (package--sort-deps-in-alist dep-package only)
- out))))
- (cons package out)))
-
-(defun package--sort-by-dependence (package-list)
- "Return PACKAGE-LIST sorted by dependence.
-That is, any element of the returned list is guaranteed to not
-directly depend on any elements that come before it.
-
-PACKAGE-LIST is a list of package-desc objects.
-Indirect dependencies are guaranteed to be returned in order only
-if all the in-between dependencies are also in PACKAGE-LIST."
- (let ((alist (mapcar (lambda (p) (cons (package-desc-name p) p))
package-list))
- out-list)
- (dolist (cell alist out-list)
- ;; `package--sort-deps-in-alist' destructively changes alist, so
- ;; some cells might already be empty. We check this here.
- (when-let ((pkg-desc (cdr cell)))
- (setcdr cell nil)
- (setq out-list
- (append (package--sort-deps-in-alist pkg-desc alist)
- out-list))))))
-
(defun package-menu-execute (&optional noquery)
"Perform marked Package Menu actions.
Packages marked for installation are downloaded and installed;