Commit 5f9153fa authored by Artur Malabarba's avatar Artur Malabarba

* lisp/emacs-lisp/package.el: Refactor -with-work-buffer-async

(package--with-work-buffer-async): Reimplement as
`package--with-response-buffer'.
(package--with-work-buffer): Mark obsolete.
(package--with-response-buffer): New macro. This is a more self
contained and less contrived version of
`package--with-work-buffer-async'.  It uses keyword arguments,
doesn't have async on the name, doesn't fallback on
`package--with-work-buffer', and has _much_ simpler error
handling.

(package--check-signature, package--download-one-archive)
(package-install-from-archive, describe-package-1): Use it.

(package--download-and-read-archives): Let
`package--download-one-archive' take care of calling
`package--update-downloads-in-progress'.
parent 353f5e76
...@@ -1124,7 +1124,8 @@ FILE is the name of a file relative to that base location. ...@@ -1124,7 +1124,8 @@ FILE is the name of a file relative to that base location.
This macro retrieves FILE from LOCATION into a temporary buffer, This macro retrieves FILE from LOCATION into a temporary buffer,
and evaluates BODY while that buffer is current. This work and evaluates BODY while that buffer is current. This work
buffer is killed afterwards. Return the last value in BODY." buffer is killed afterwards. Return the last value in BODY."
(declare (indent 2) (debug t)) (declare (indent 2) (debug t)
(obsolete package--with-response-buffer "25.1"))
`(with-temp-buffer `(with-temp-buffer
(if (string-match-p "\\`https?:" ,location) (if (string-match-p "\\`https?:" ,location)
(url-insert-file-contents (concat ,location ,file)) (url-insert-file-contents (concat ,location ,file))
...@@ -1134,47 +1135,52 @@ buffer is killed afterwards. Return the last value in BODY." ...@@ -1134,47 +1135,52 @@ buffer is killed afterwards. Return the last value in BODY."
(insert-file-contents (expand-file-name ,file ,location))) (insert-file-contents (expand-file-name ,file ,location)))
,@body)) ,@body))
(defmacro package--with-work-buffer-async (location file async &rest body) (cl-defmacro package--with-response-buffer (url &rest body &key async file error-form noerror &allow-other-keys)
"Run BODY in a buffer containing the contents of FILE at LOCATION. "Access URL and run BODY in a buffer containing the response.
If ASYNC is non-nil, and if it is possible, run BODY Point is after the headers when BODY runs.
asynchronously. If an error is encountered and ASYNC is a FILE, if provided, is added to URL.
function, call it with no arguments (instead of executing BODY). URL can be a local file name, which must be absolute.
If it returns non-nil, or if it wasn't a function, propagate the ASYNC, if non-nil, runs the request asynchronously.
error. ERROR-FORM is run only if an error occurs. If NOERROR is
non-nil, don't propagate errors caused by the connection or by
For a description of the other arguments see BODY (does not apply to errors signaled by ERROR-FORM).
`package--with-work-buffer'."
(declare (indent 3) (debug t)) \(fn URL &key ASYNC FILE ERROR-FORM NOERROR &rest BODY)"
(macroexp-let2* macroexp-copyable-p (declare (indent defun) (debug t))
((async-1 async) (while (keywordp (car body))
(file-1 file) (setq body (cdr (cdr body))))
(location-1 location)) (macroexp-let2* nil ((url-1 url))
`(if (or (not ,async-1) `(cl-macrolet ((wrap-errors (&rest bodyforms)
(not (string-match-p "\\`https?:" ,location-1))) (let ((err (make-symbol "err")))
(package--with-work-buffer ,location-1 ,file-1 ,@body) `(condition-case ,err
;; This `condition-case' is to catch connection errors. ,(macroexp-progn bodyforms)
(condition-case error-signal ,(list 'error ',error-form
(url-retrieve (concat ,location-1 ,file-1) (list 'unless ',noerror
;; This is to catch execution errors. `(signal (car ,err) (cdr ,err))))))))
(lambda (status) (if (string-match-p "\\`https?:" ,url-1)
(condition-case error-signal (let* ((url (concat ,url-1 ,file))
(progn (callback (lambda (status)
(when-let ((er (plist-get status :error))) (let ((b (current-buffer)))
(error "Error retrieving: %s %S" (concat ,location-1 ,file-1) er)) (unwind-protect (wrap-errors
(goto-char (point-min)) (when-let ((er (plist-get status :error)))
(unless (search-forward "\n\n" nil 'noerror) (error "Error retrieving: %s %S" url er))
(error "Invalid url response in buffer %s" (unless (search-forward-regexp "^\r?\n\r?" nil 'noerror)
(current-buffer))) (rest-error 'rest-unintelligible-result))
(delete-region (point-min) (point)) (delete-region (point-min) (point))
,@body ,@body)
(kill-buffer (current-buffer))) (when (buffer-live-p b)
(error (when (if (functionp ,async-1) (funcall ,async-1) t) (kill-buffer b)))))))
(signal (car error-signal) (cdr error-signal)))))) (if ,async
nil (wrap-errors (url-retrieve url callback nil 'silent))
'silent) (let ((buffer (wrap-errors (url-retrieve-synchronously url 'silent))))
(error (when (if (functionp ,async-1) (funcall ,async-1) t) (with-current-buffer buffer
(message "Error contacting: %s" (concat ,location-1 ,file-1)) (funcall callback nil)))))
(signal (car error-signal) (cdr error-signal)))))))) (wrap-errors (with-temp-buffer
(let ((url (expand-file-name ,file ,url-1)))
(unless (file-name-absolute-p url)
(error "Location %s is not a url nor an absolute file name" url))
(insert-file-contents url))
,@body))))))
(defun package--check-signature-content (content string &optional sig-file) (defun package--check-signature-content (content string &optional sig-file)
"Check signature CONTENT against STRING. "Check signature CONTENT against STRING.
...@@ -1220,15 +1226,12 @@ list can be empty). If the signatures file is not found, ...@@ -1220,15 +1226,12 @@ list can be empty). If the signatures file is not found,
CALLBACK is called with no arguments." CALLBACK is called with no arguments."
(let ((sig-file (concat file ".sig")) (let ((sig-file (concat file ".sig"))
(string (or string (buffer-string)))) (string (or string (buffer-string))))
(condition-case nil (package--with-response-buffer location :file sig-file
(package--with-work-buffer-async :async async :noerror t
location sig-file (when async (or callback t)) :error-form (when callback (funcall callback nil))
(let ((sig (package--check-signature-content (let ((sig (package--check-signature-content (buffer-substring (point) (point-max)) string sig-file)))
(buffer-string) string sig-file))) (when callback (funcall callback sig))
(when callback (funcall callback sig)) sig))))
sig))
(file-error (funcall callback)))))
;;; Packages on Archives ;;; Packages on Archives
;; The following variables store information about packages available ;; The following variables store information about packages available
...@@ -1470,7 +1473,9 @@ Once it's empty, run `package--post-download-archives-hook'." ...@@ -1470,7 +1473,9 @@ Once it's empty, run `package--post-download-archives-hook'."
ARCHIVE should be a cons cell of the form (NAME . LOCATION), ARCHIVE should be a cons cell of the form (NAME . LOCATION),
similar to an entry in `package-alist'. Save the cached copy to similar to an entry in `package-alist'. Save the cached copy to
\"archives/NAME/FILE\" in `package-user-dir'." \"archives/NAME/FILE\" in `package-user-dir'."
(package--with-work-buffer-async (cdr archive) file async (package--with-response-buffer (cdr archive) :file file
:async async
:error-form (package--update-downloads-in-progress archive)
(let* ((location (cdr archive)) (let* ((location (cdr archive))
(name (car archive)) (name (car archive))
(content (buffer-string)) (content (buffer-string))
...@@ -1494,17 +1499,14 @@ similar to an entry in `package-alist'. Save the cached copy to ...@@ -1494,17 +1499,14 @@ similar to an entry in `package-alist'. Save the cached copy to
;; remove it from the in-progress list. ;; remove it from the in-progress list.
(package--update-downloads-in-progress archive) (package--update-downloads-in-progress archive)
(error "Unsigned archive `%s'" name)) (error "Unsigned archive `%s'" name))
;; Either everything worked or we don't mind not signing.
;; Write out the archives file. ;; Write out the archives file.
(write-region content nil local-file nil 'silent) (write-region content nil local-file nil 'silent)
;; Write out good signatures into archive-contents.signed file. ;; Write out good signatures into archive-contents.signed file.
(when good-sigs (when good-sigs
(write-region (mapconcat #'epg-signature-to-string good-sigs "\n") (write-region (mapconcat #'epg-signature-to-string good-sigs "\n")
nil (concat local-file ".signed") nil 'silent)) nil (concat local-file ".signed") nil 'silent))
(package--update-downloads-in-progress archive) (package--update-downloads-in-progress archive))))))))
;; If we got this far, either everything worked or we don't mind
;; not signing, so tell `package--with-work-buffer-async' to not
;; propagate errors.
nil)))))))
(defun package--download-and-read-archives (&optional async) (defun package--download-and-read-archives (&optional async)
"Download descriptions of all `package-archives' and read them. "Download descriptions of all `package-archives' and read them.
...@@ -1517,12 +1519,7 @@ perform the downloads asynchronously." ...@@ -1517,12 +1519,7 @@ perform the downloads asynchronously."
:test #'equal)) :test #'equal))
(dolist (archive package-archives) (dolist (archive package-archives)
(condition-case-unless-debug nil (condition-case-unless-debug nil
(package--download-one-archive (package--download-one-archive archive "archive-contents" async)
archive "archive-contents"
;; Called if the async download fails
(when async
;; The t at the end means to propagate connection errors.
(lambda () (package--update-downloads-in-progress archive) t)))
(error (message "Failed to download `%s' archive." (error (message "Failed to download `%s' archive."
(car archive)))))) (car archive))))))
...@@ -1777,7 +1774,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." ...@@ -1777,7 +1774,7 @@ if all the in-between dependencies are also in PACKAGE-LIST."
(let* ((location (package-archive-base pkg-desc)) (let* ((location (package-archive-base pkg-desc))
(file (concat (package-desc-full-name pkg-desc) (file (concat (package-desc-full-name pkg-desc)
(package-desc-suffix pkg-desc)))) (package-desc-suffix pkg-desc))))
(package--with-work-buffer location file (package--with-response-buffer location :file file
(if (or (not package-check-signature) (if (or (not package-check-signature)
(member (package-desc-archive pkg-desc) (member (package-desc-archive pkg-desc)
package-unsigned-archives)) package-unsigned-archives))
...@@ -2368,26 +2365,23 @@ Otherwise no newline is inserted." ...@@ -2368,26 +2365,23 @@ Otherwise no newline is inserted."
(replace-match "")) (replace-match ""))
(while (re-search-forward "^\\(;+ ?\\)" nil t) (while (re-search-forward "^\\(;+ ?\\)" nil t)
(replace-match "")))) (replace-match ""))))
(let ((readme (expand-file-name (format "%s-readme.txt" name) (let* ((basename (format "%s-readme.txt" name))
package-user-dir)) (readme (expand-file-name basename package-user-dir))
readme-string) readme-string)
;; For elpa packages, try downloading the commentary. If that ;; For elpa packages, try downloading the commentary. If that
;; fails, try an existing readme file in `package-user-dir'. ;; fails, try an existing readme file in `package-user-dir'.
(cond ((condition-case nil (cond ((and (package-desc-archive desc)
(save-excursion (package--with-response-buffer (package-archive-base desc)
(package--with-work-buffer :file basename :noerror t
(package-archive-base desc) (save-excursion
(format "%s-readme.txt" name) (goto-char (point-max))
(save-excursion (unless (bolp)
(goto-char (point-max)) (insert ?\n)))
(unless (bolp) (write-region nil nil
(insert ?\n))) (expand-file-name readme package-user-dir)
(write-region nil nil nil 'silent)
(expand-file-name readme package-user-dir) (setq readme-string (buffer-string))
nil 'silent) t))
(setq readme-string (buffer-string))
t))
(error nil))
(insert readme-string)) (insert readme-string))
((file-readable-p readme) ((file-readable-p readme)
(insert-file-contents readme) (insert-file-contents readme)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment