branch: externals/async
commit b8308c7967b9cae6037af6f810b0538d667e29b1
Author: Thierry Volpiatto <thie...@posteo.net>
Commit: Thierry Volpiatto <thie...@posteo.net>
Provide async function for package.el
New file async-package.el.
---
async-package.el | 122 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 122 insertions(+)
diff --git a/async-package.el b/async-package.el
new file mode 100644
index 0000000000..06bca85a71
--- /dev/null
+++ b/async-package.el
@@ -0,0 +1,122 @@
+;;; async-package.el --- Fetch packages asynchronously -*- lexical-binding: t
-*-
+
+;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
+
+;; Author: Thierry Volpiatto <thie...@posteo.net>
+
+;; Keywords: dired async byte-compile package
+;; X-URL: https://github.com/jwiegley/emacs-async
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'async-bytecomp)
+(require 'dired-async)
+(require 'package)
+
+(define-minor-mode async-package--modeline-mode
+ "Notify mode-line that an async process run."
+ :group 'async
+ :global t
+ :lighter (:eval (propertize (format " [%s async job Installing package(s)]"
+ (length (dired-async-processes
+ 'async-pkg-install)))
+ 'face 'async-package-message))
+ (unless async-package--modeline-mode
+ (let ((visible-bell t)) (ding))))
+
+(defface async-package-message
+ '((t (:foreground "yellow")))
+ "Face used for mode-line message.")
+
+(defun async-package-do-action (action packages error-file)
+ "Execute ACTION asynchronously on PACKAGES.
+Argument ACTION can be one of \\='install, \\='upgrade, \\='reinstall.
+Argument PACKAGES is a list of packages (symbols).
+Argument ERROR-FILE is the file where errors are logged, if some."
+ (require 'async-bytecomp)
+ (let ((fn (pcase action
+ ('install 'package-install)
+ ('upgrade 'package-upgrade)
+ ('reinstall 'package-reinstall)))
+ (action-string (pcase action
+ ('install "Installing")
+ ('upgrade "Upgrading")
+ ('reinstall "Reinstalling"))))
+ (message "%s %s package(s)..." action-string (length packages))
+ (process-put
+ (async-start
+ `(lambda ()
+ (require 'bytecomp)
+ (setq package-archives ',package-archives)
+ (package-initialize)
+ (prog1
+ (condition-case err
+ (mapc ',fn ',packages)
+ (error
+ (with-temp-file ,error-file
+ (insert
+ (format
+ "%S:\n Please refresh package list before %s"
+ err ,action-string)))))
+ (let (error-data)
+ (when (get-buffer byte-compile-log-buffer)
+ (setq error-data (with-current-buffer byte-compile-log-buffer
+ (buffer-substring-no-properties
+ (point-min) (point-max))))
+ (unless (string= error-data "")
+ (with-temp-file ,async-byte-compile-log-file
+ (erase-buffer)
+ (insert error-data)))))))
+ (lambda (result)
+ (if (file-exists-p error-file)
+ (let ((buf (find-file-noselect error-file)))
+ (pop-to-buffer
+ buf '(nil . ((window-height . fit-window-to-buffer))))
+ (special-mode)
+ (delete-file error-file)
+ (async-package--modeline-mode -1))
+ (when result
+ (setq package-selected-packages
+ (append result package-selected-packages))
+ (package-initialize) ; load packages.
+ (async-package--modeline-mode -1)
+ (message "%s %s packages done" action-string (length packages))
+ (run-with-timer
+ 0.1 nil
+ (lambda (lst str)
+ (dired-async-mode-line-message
+ "%s %d package(s) done"
+ 'async-package-message
+ str (length lst)))
+ packages action-string)
+ (when (file-exists-p async-byte-compile-log-file)
+ (let ((buf (get-buffer-create byte-compile-log-buffer)))
+ (with-current-buffer buf
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert-file-contents async-byte-compile-log-file)
+ (compilation-mode))
+ (display-buffer buf)
+ (delete-file async-byte-compile-log-file))))))))
+ 'async-pkg-install t)
+ (async-package--modeline-mode 1)))
+
+(provide 'async-package)
+
+;;; async-package.el ends here
