[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/package.el-async-refresh bc0fc5e: Implement async
From: |
Artur Malabarba |
Subject: |
[Emacs-diffs] scratch/package.el-async-refresh bc0fc5e: Implement async refreshing in package-refresh-contents |
Date: |
Tue, 31 Mar 2015 00:21:10 +0000 |
branch: scratch/package.el-async-refresh
commit bc0fc5edb747356d9cb1e8469a7f5f4781f7af0c
Author: Artur Malabarba <address@hidden>
Commit: Artur Malabarba <address@hidden>
Implement async refreshing in package-refresh-contents
The package menu uses this according to the variable package-menu-async.
---
lisp/emacs-lisp/package.el | 278 +++++++++++++++++++++++++++++++-------------
1 files changed, 196 insertions(+), 82 deletions(-)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 526c0b4..f582d4b 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -1082,20 +1082,43 @@ buffer is killed afterwards. Return the last value in
BODY."
(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'."
+(defmacro package--with-work-buffer-async (location file async &rest body)
+ "Run BODY in a buffer containing the contents of FILE at LOCATION.
+If ASYNC is non-nil, and if it is possible, the operation is run
+asynchronously. If an error is encountered and ASYNC is a
+function, it is called with no arguments (instead of executing
+body), otherwise the error is propagated. For description on the
+other arguments see `package--with-work-buffer'."
+ (declare (indent 3) (debug t))
+ `(if (or (not ,async)
+ (not (string-match-p "\\`https?:" ,location)))
+ (package--with-work-buffer ,location ,file ,@body)
+ (url-retrieve (concat ,location ,file)
+ (lambda (status)
+ (if (eq (car status) :error)
+ (if (functionp ,async)
+ (funcall ,async)
+ (signal (cdar status) (cddr status)))
+ (goto-char (point-min))
+ (unless (search-forward "\n\n" nil 'noerror)
+ (error "Invalid url response"))
+ (delete-region (point-min) (point))
+ ,@body)
+ (kill-buffer (current-buffer)))
+ nil
+ 'silent)))
+
+(defun package--check-signature-content (content string &optional sig-file)
+ "Check signature CONTENT against STRING.
+SIG-FILE is the name of the signature file, used when signaling
+errors."
(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))))
+ (homedir (expand-file-name "gnupg" package-user-dir)))
(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))))
+ (epg-verify-string context content 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.
@@ -1114,6 +1137,30 @@ GnuPG keyring is located under \"gnupg\" in
`package-user-dir'."
(error "Failed to verify signature %s" sig-file))
good-signatures)))
+(defun package--check-signature (location file &optional string async callback)
+ "Check signature of the current buffer.
+Signature file is downloaded from LOCATION by appending \".sig\"
+to FILE.
+GnuPG keyring is located under \"gnupg\" in `package-user-dir'.
+STRING is the string to verify, it defaults to `buffer-string'.
+If ASYNC is non-nil, the download of the signature file is
+done asynchronously.
+
+If the signature is verified and CALLBACK was provided, CALLBACK
+is `funcall'ed with the list of good signatures as argument (the
+list can be empty). If the signatures file is not found,
+CALLBACK is called with no arguments."
+ (let ((sig-file (concat file ".sig"))
+ (string (or string (buffer-string))))
+ (condition-case nil
+ (package--with-work-buffer-async
+ location sig-file (when async (or callback t))
+ (let ((sig (package--check-signature-content
+ (buffer-string) string sig-file)))
+ (when callback (funcall callback sig))
+ sig))
+ (file-error (funcall callback)))))
+
;;; Packages on Archives
;; The following variables store information about packages available
@@ -1281,36 +1328,8 @@ If optional arg NO-ACTIVATE is non-nil, don't activate
packages."
;;;; 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))))
+(defvar package--downloads-in-progress nil
+ "List of in-progress asynchronous downloads.")
(declare-function epg-check-configuration "epg-config"
(config &optional minimum-version))
@@ -1331,12 +1350,83 @@ similar to an entry in `package-alist'. Save the
cached copy to
(epg-import-keys-from-file context file)
(message "Importing %s...done" (file-name-nondirectory file))))
+(defvar package--post-download-archives-hook nil
+ "Hook run after the archive contents are downloaded.")
+(put 'package--post-download-archives-hook 'risky-local-variable t)
+
+(defun package--notify-done ()
+ (message "Package refresh done"))
+
+(add-hook 'package--post-download-archives-hook #'package--notify-done)
+(add-hook 'package--post-download-archives-hook
#'package--build-compatibility-table)
+(add-hook 'package--post-download-archives-hook
#'package-read-all-archive-contents)
+
+(defun package--update-downloads-in-progress (entry)
+ "Remove ENTRY from `package--downloads-in-progress'.
+Once it's empty, run `package--post-download-archives-hook'."
+ ;; Keep track of the downloading progress.
+ (setq package--downloads-in-progress
+ (remove entry package--downloads-in-progress))
+ ;; If this was the last download, run the hook.
+ (unless package--downloads-in-progress
+ (run-hooks 'package--post-download-archives-hook)))
+
+(defun package--download-one-archive (archive file &optional async)
+ "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/FILE\" in `package-user-dir'."
+ (package--with-work-buffer-async (cdr archive) file async
+ (let* ((location (cdr archive))
+ (name (car archive))
+ (content (buffer-string))
+ (dir (expand-file-name (format "archives/%s" name)
package-user-dir))
+ (local-file (expand-file-name file dir)))
+ (when (listp (read-from-string content))
+ (make-directory dir t)
+ (if (or (not package-check-signature)
+ (member archive package-unsigned-archives))
+ ;; If we don't care about the signature, save the file and
+ ;; we're done.
+ (progn (write-region content nil local-file nil 'silent)
+ (package--update-downloads-in-progress archive))
+ ;; If we care, check it (perhaps async) and *then* write the file.
+ (package--check-signature
+ location file content async
+ (lambda (&optional good-sigs)
+ (unless (or good-sigs (eq package-check-signature
'allow-unsigned))
+ (error "Unsigned archive `%s'" name))
+ ;; Write out the archives file.
+ (write-region content nil local-file nil 'silent)
+ ;; Write out good signatures into archive-contents.signed file.
+ (when good-sigs
+ (write-region (mapconcat #'epg-signature-to-string good-sigs
"\n")
+ nil (concat local-file ".signed") nil 'silent))
+ (package--update-downloads-in-progress archive))))))))
+
+(defun package--download-and-read-archives (&optional async)
+ "Download descriptions of all `package-archives' and read them.
+This populates `package-archive-contents'. If ASYNC is non-nil,
+the downloads are performed asynchronously."
+ (when async
+ (setq package--downloads-in-progress package-archives))
+ (dolist (archive package-archives)
+ (condition-case-unless-debug nil
+ (package--download-one-archive archive "archive-contents" async)
+ (error (message "Failed to download `%s' archive."
+ (car archive)))))
+ ;; This is what reads the dowloaded archive contents.
+ (unless async
+ (run-hooks 'package--post-download-archives-hook)))
+
;;;###autoload
-(defun package-refresh-contents ()
+(defun package-refresh-contents (&optional async)
"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."
+and make them available for download.
+Optional argument, ASYNC, specifies whether the downloads should
+be performed in the background."
(interactive)
;; FIXME: Do it asynchronously.
(unless (file-exists-p package-user-dir)
@@ -1349,14 +1439,7 @@ and make them available for download."
(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)
- (message "Package refresh done"))
+ (package--download-and-read-archives async))
;;; Dependency Management
@@ -2160,7 +2243,7 @@ will be deleted."
map)
"Local keymap for `package-menu-mode' buffers.")
-(defvar package-menu--new-package-list nil
+(defvar-local package-menu--new-package-list nil
"List of newly-available packages since `list-packages' was last called.")
(define-derived-mode package-menu-mode tabulated-list-mode "Package Menu"
@@ -2668,6 +2751,45 @@ Optional argument NOQUERY non-nil means do not ask the
user to confirm."
(string< (or (package-desc-archive (car A)) "")
(or (package-desc-archive (car B)) "")))
+(defvar-local package-menu--old-archive-contents nil
+ "`package-archive-contents' before the latest refresh.")
+
+(defun package-menu--populate-new-package-list ()
+ "Decide which packages are new in `package-archives-contents'.
+Store this list in `package-menu--new-package-list'."
+ ;; Find which packages are new.
+ (when package-menu--old-archive-contents
+ (dolist (elt package-archive-contents)
+ (unless (assq (car elt) package-menu--old-archive-contents)
+ (push (car elt) package-menu--new-package-list)))
+ (setq package-menu--old-archive-contents nil)))
+
+(defun package-menu--revert ()
+ "Call `revert-buffer' on the *Packages* buffer.
+Used in `package--post-download-archives-hook'."
+ (let ((buf (get-buffer "*Packages*")))
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (revert-buffer nil 'noconfirm)))))
+
+(defun package-menu--find-and-notify-upgrades ()
+ "Notify the user of upgradeable packages."
+ (let ((upgrades (package-menu--find-upgrades)))
+ (if upgrades
+ (message "%d package%s can be upgraded; type `%s' to mark %s for
upgrading."
+ (length upgrades)
+ (if (= (length upgrades) 1) "" "s")
+ (substitute-command-keys "\\[package-menu-mark-upgrades]")
+ (if (= (length upgrades) 1) "it" "them")))))
+
+(defcustom package-menu-async t
+ "If non-nil, package-menu will use async operations when possible.
+Currently, only the refreshing of archive contents supports
+asynchronous operations. Package transactions are still done
+synchronously."
+ :type 'boolean
+ :group 'package)
+
;;;###autoload
(defun list-packages (&optional no-fetch)
"Display a list of packages.
@@ -2679,36 +2801,28 @@ The list is displayed in a buffer named `*Packages*'."
;; Initialize the package system if necessary.
(unless package--initialized
(package-initialize t))
- (let (old-archives new-packages)
- (unless no-fetch
- ;; Read the locally-cached archive-contents.
- (package-read-all-archive-contents)
- (setq old-archives package-archive-contents)
- ;; Fetch the remote list of packages.
- (package-refresh-contents)
- ;; Find which packages are new.
- (dolist (elt package-archive-contents)
- (unless (assq (car elt) old-archives)
- (push (car elt) new-packages))))
-
- ;; Generate the Package Menu.
- (let ((buf (get-buffer-create "*Packages*")))
- (with-current-buffer buf
- (package-menu-mode)
- (set (make-local-variable 'package-menu--new-package-list)
- new-packages)
- (package-menu--generate nil t))
- ;; The package menu buffer has keybindings. If the user types
- ;; `M-x list-packages', that suggests it should become current.
- (switch-to-buffer buf))
-
- (let ((upgrades (package-menu--find-upgrades)))
- (if upgrades
- (message "%d package%s can be upgraded; type `%s' to mark %s for
upgrading."
- (length upgrades)
- (if (= (length upgrades) 1) "" "s")
- (substitute-command-keys "\\[package-menu-mark-upgrades]")
- (if (= (length upgrades) 1) "it" "them"))))))
+ ;; Integrate the package-menu with updating the archives.
+ (add-hook 'package--post-download-archives-hook
+ #'package-menu--populate-new-package-list 'append)
+ (add-hook 'package--post-download-archives-hook
+ #'package-menu--revert 'append)
+ (add-hook 'package--post-download-archives-hook
+ #'package-menu--find-and-notify-upgrades 'append)
+
+ (unless no-fetch
+ (setq package-menu--old-archive-contents package-archive-contents)
+ (setq package-menu--new-package-list nil)
+ ;; Fetch the remote list of packages.
+ (package-refresh-contents package-menu-async))
+
+ ;; Generate the Package Menu.
+ (let ((buf (get-buffer-create "*Packages*")))
+ (with-current-buffer buf
+ (package-menu-mode)
+ (package-menu--generate nil t))
+ ;; The package menu buffer has keybindings. If the user types
+ ;; `M-x list-packages', that suggests it should become current.
+ (switch-to-buffer buf)))
;;;###autoload
(defalias 'package-list-packages 'list-packages)