Archived
1
0
Fork 0
This repository has been archived on 2024-10-19. You can view files and clone it, but cannot push or open issues or pull requests.
emacs/code/elpa/async-20240719.640/async-package.el
2024-07-28 12:03:37 -04:00

133 lines
5.3 KiB
EmacsLisp

;;; async-package.el --- Fetch packages asynchronously -*- lexical-binding: t -*-
;; Copyright (C) 2014-2022 Free Software Foundation, Inc.
;; Author: Thierry Volpiatto <thievol@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:
;; Provide the function `async-package-do-action' to
;; (re)install/upgrade packages asynchronously.
;;; 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-pinned-packages ',package-pinned-packages
package-archive-contents ',package-archive-contents
package-alist ',package-alist
load-path ',load-path)
(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
(let ((pkgs (if (listp result) result (list result))))
(when (eq action 'install)
(customize-save-variable
'package-selected-packages
(delete-dups (append pkgs package-selected-packages))))
(package-load-all-descriptors) ; refresh package-alist.
(mapc #'package-activate pkgs) ; 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