394 lines
15 KiB
EmacsLisp
394 lines
15 KiB
EmacsLisp
;;; paradox-execute.el --- executing package transactions -*- lexical-binding:t -*-
|
||
|
||
;; Copyright (C) 2014-2015 Artur Malabarba <bruce.connor.am@gmail.com>
|
||
|
||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
|
||
;; Prefix: paradox
|
||
;; Separator: -
|
||
|
||
;;; License:
|
||
;;
|
||
;; This file is NOT part of GNU Emacs.
|
||
;;
|
||
;; 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 2
|
||
;; 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.
|
||
;;
|
||
|
||
;;; Commentary:
|
||
;;
|
||
;; Functions related to executing package-menu transactions.
|
||
;; Everything that happens when you hit `x' is in here.
|
||
|
||
|
||
;;; Code:
|
||
(require 'cl-lib)
|
||
(require 'seq)
|
||
|
||
(require 'package)
|
||
(require 'paradox-core)
|
||
(require 'paradox-github)
|
||
|
||
(defgroup paradox-execute nil
|
||
"Paradox Packages Menu configurations."
|
||
:prefix "paradox-"
|
||
:package-version '(paradox . "2.0")
|
||
:group 'paradox)
|
||
|
||
(defvar paradox--current-filter)
|
||
|
||
;;; Customization Variables
|
||
(defcustom paradox-execute-asynchronously 'ask
|
||
"Whether the install/delete/upgrade should be asynchronous.
|
||
Possible values are:
|
||
t, which means always;
|
||
nil, which means never;
|
||
ask, which means ask each time."
|
||
:type '(choice (const :tag "Always" t)
|
||
(const :tag "Never" nil)
|
||
(const :tag "Ask each time" ask))
|
||
:package-version '(paradox . "2.0")
|
||
:group 'paradox-execute)
|
||
|
||
(defcustom paradox-async-display-buffer-function #'display-buffer
|
||
"Function used to display *Paradox Report* buffer after asynchronous upgrade.
|
||
Set this to nil to avoid displaying the buffer. Or set this to a
|
||
function like `display-buffer' or `pop-to-buffer'.
|
||
|
||
This is only used if `paradox-menu-execute' was given a non-nil
|
||
NOQUERY argument. Otherwise, only a message is displayed."
|
||
:type '(choice (const :tag "Don't display the buffer" nil)
|
||
function)
|
||
:package-version '(paradox . "2.0")
|
||
:group 'paradox-execute)
|
||
|
||
|
||
;;; Execution Hook
|
||
(defvar paradox-after-execute-functions nil
|
||
"List of functions run after performing package transactions.
|
||
These are run after a set of installation, deletion, or upgrades
|
||
has been performed. Each function in this hook must take a single
|
||
argument. An associative list of the form
|
||
|
||
((SYMBOL . DATA) (SYMBOL . DATA) ...)
|
||
|
||
This list contains the following entries, describing what
|
||
occurred during the execution:
|
||
|
||
SYMBOL DATA
|
||
`installed' List of installed packages.
|
||
`deleted' List of deleted packages.
|
||
`activated' List of activated packages.
|
||
`error' List of errors.
|
||
`async' Non-nil if transaction was performed asynchronously.
|
||
`noquery' The NOQUERY argument given to `paradox-menu-execute'.")
|
||
(put 'risky-local-variable-p 'paradox-after-execute-functions t)
|
||
(mapc (lambda (x) (add-hook 'paradox-after-execute-functions x t))
|
||
'(paradox--activate-if-asynchronous
|
||
paradox--refresh-package-buffer
|
||
paradox--report-buffer-print
|
||
paradox--report-buffer-display-if-noquery
|
||
paradox--report-message
|
||
))
|
||
|
||
(defun paradox--refresh-package-buffer (_)
|
||
"Refresh the *Packages* buffer, if it exists."
|
||
(let ((buf (get-buffer "*Packages*")))
|
||
(when (buffer-live-p buf)
|
||
(with-current-buffer buf
|
||
(revert-buffer)))))
|
||
|
||
(defun paradox--activate-if-asynchronous (alist)
|
||
"Activate packages after an asynchronous operation.
|
||
Argument ALIST describes the operation."
|
||
(let-alist alist
|
||
(when .async
|
||
(dolist (pkg .activated)
|
||
(if (fboundp 'package--list-loaded-files)
|
||
(package-activate-1 pkg 'reload)
|
||
(package-activate-1 pkg))))))
|
||
|
||
(defun paradox--print-package-list (list)
|
||
"Print LIST at point."
|
||
(let* ((width (apply #'max
|
||
(mapcar (lambda (x) (string-width (symbol-name (package-desc-name x))))
|
||
list)))
|
||
(tabulated-list-format
|
||
`[("Package" ,(1+ width) nil)
|
||
("Version" 0 nil)])
|
||
(tabulated-list-padding 2))
|
||
(mapc
|
||
(lambda (p) (tabulated-list-print-entry
|
||
p
|
||
`[,(symbol-name (package-desc-name p))
|
||
,(package-version-join (package-desc-version p))]))
|
||
list)))
|
||
|
||
(defun paradox--report-buffer-print (alist)
|
||
"Print a transaction report in *Package Report* buffer.
|
||
Possibly display the buffer or message the user depending on the
|
||
situation.
|
||
Argument ALIST describes the operation."
|
||
(let-alist alist
|
||
(let ((buf (get-buffer-create "*Paradox Report*"))
|
||
(inhibit-read-only t))
|
||
(with-current-buffer buf
|
||
(goto-char (point-max))
|
||
;; TODO: Write our own mode for this.
|
||
(special-mode)
|
||
(insert "\n \n")
|
||
(save-excursion
|
||
(insert (format-time-string "Package transaction finished. %c\n"))
|
||
(when .error
|
||
(insert "Errors:\n ")
|
||
(dolist (it .error)
|
||
(princ it (current-buffer))
|
||
(insert "\n"))
|
||
(insert "\n\n"))
|
||
(when .installed
|
||
(insert "Installed:\n")
|
||
(paradox--print-package-list .installed)
|
||
(insert "\n"))
|
||
(when .deleted
|
||
(insert "Deleted:\n")
|
||
(paradox--print-package-list .deleted)
|
||
(insert "\n")))))))
|
||
|
||
(defun paradox--report-buffer-display-if-noquery (alist)
|
||
"Display report buffer if `paradox-execute' was called with a NOQUERY prefix.
|
||
ALIST describes the transaction.
|
||
`paradox-async-display-buffer-function' is used if transaction
|
||
was asynchronous. Otherwise, `pop-to-buffer' is used."
|
||
(let-alist alist
|
||
;; The user has never seen the packages in this transaction. So
|
||
;; we display them in a buffer.
|
||
(when (or .noquery .error)
|
||
(let ((buf (get-buffer "*Paradox Report*")))
|
||
(when (buffer-live-p buf)
|
||
(cond
|
||
;; If we're async, the user might be doing something else, so
|
||
;; we don't steal focus.
|
||
((and .async paradox-async-display-buffer-function)
|
||
(funcall paradox-async-display-buffer-function buf))
|
||
;; If we're not async, just go ahead and pop.
|
||
((or (not .async)
|
||
;; If there's an error, display the buffer even if
|
||
;; `paradox-async-display-buffer-function' is nil.
|
||
.error)
|
||
(pop-to-buffer buf))))))))
|
||
|
||
(defun paradox--report-message (alist)
|
||
"Message the user about the executed transaction.
|
||
ALIST describes the transaction."
|
||
(let-alist alist
|
||
(message "%s%s"
|
||
(paradox--format-message nil .installed .deleted)
|
||
(if (memq 'paradox--report-buffer-print paradox-after-execute-functions)
|
||
" See the buffer *Paradox Report* for more details." ""))
|
||
(when .errors
|
||
(message "Errors encountered during the operation: %S\n%s"
|
||
.errors
|
||
(if (memq 'paradox--report-buffer-print paradox-after-execute-functions)
|
||
" See the buffer *Paradox Report* for more details." "")))))
|
||
|
||
|
||
;;; Execution
|
||
(defun paradox-menu-execute (&optional noquery)
|
||
"Perform marked Package Menu actions.
|
||
Packages marked for installation are downloaded and installed;
|
||
packages marked for deletion are removed.
|
||
|
||
Afterwards, if `paradox-automatically-star' is t, automatically
|
||
star new packages, and unstar removed packages. Upgraded packages
|
||
aren't changed.
|
||
|
||
Synchronicity of the actions depends on
|
||
`paradox-execute-asynchronously'. Optional argument NOQUERY
|
||
non-nil means do not ask the user to confirm. If asynchronous,
|
||
never ask anyway."
|
||
(interactive "P")
|
||
(unless (derived-mode-p 'paradox-menu-mode)
|
||
(error "The current buffer is not in Paradox Menu mode"))
|
||
(when (and (stringp paradox-github-token)
|
||
(eq paradox-automatically-star 'unconfigured))
|
||
(customize-save-variable
|
||
'paradox-automatically-star
|
||
(y-or-n-p "When you install new packages would you like them to be automatically starred?
|
||
\(They will be unstarred when you delete them) ")))
|
||
(when (and (stringp paradox--current-filter)
|
||
(string-match "Upgradable" paradox--current-filter))
|
||
(setq tabulated-list-sort-key '("Status" . nil))
|
||
(setq paradox--current-filter nil))
|
||
(paradox--menu-execute-1 noquery))
|
||
|
||
(defmacro paradox--perform-package-transaction (install delete)
|
||
"Install all packages from INSTALL and delete those from DELETE.
|
||
Return an alist with properties listing installed,
|
||
deleted, and activated packages, and errors."
|
||
`(let (activated installed deleted errored)
|
||
(advice-add #'package-activate-1 :after
|
||
(lambda (pkg &rest _)
|
||
(ignore-errors (push pkg activated)))
|
||
'((name . paradox--track-activated)))
|
||
(condition-case err
|
||
(progn
|
||
(dolist (pkg ,install)
|
||
;; 2nd arg introduced in 25.
|
||
(if (version<= "25" emacs-version)
|
||
(package-install pkg 'dont-select)
|
||
(package-install pkg))
|
||
(push pkg installed))
|
||
(let ((delete-list ,delete))
|
||
(dolist (pkg (if (fboundp 'package--sort-by-dependence)
|
||
(package--sort-by-dependence delete-list)
|
||
delete-list))
|
||
(condition-case err
|
||
(progn (package-delete pkg)
|
||
(push pkg deleted))
|
||
(error (push err errored))))))
|
||
(error (push err errored)))
|
||
(advice-remove #'package-activate-1 'paradox--track-activated)
|
||
(list (cons 'installed (nreverse installed))
|
||
(cons 'deleted (nreverse deleted))
|
||
(cons 'activated (nreverse activated))
|
||
(cons 'error (nreverse errored)))))
|
||
|
||
(defvar paradox--current-filter)
|
||
|
||
(declare-function async-inject-variables "async")
|
||
(defun paradox--menu-execute-1 (&optional noquery)
|
||
"Implementation used by `paradox-menu-execute'.
|
||
NOQUERY, if non-nil, means to execute without prompting the
|
||
user."
|
||
(let ((before-alist (paradox--repo-alist))
|
||
install-list delete-list)
|
||
(save-excursion
|
||
(goto-char (point-min))
|
||
(let ((p (point))
|
||
(inhibit-read-only t))
|
||
(while (not (eobp))
|
||
(let ((c (char-after)))
|
||
(if (eq c ?\s)
|
||
(forward-line 1)
|
||
(push (tabulated-list-get-id)
|
||
(pcase c
|
||
(`?D delete-list)
|
||
(`?I install-list)))
|
||
(delete-region p (point))
|
||
(forward-line 1)
|
||
(setq p (point)))))
|
||
(when (or delete-list install-list)
|
||
(delete-region p (point))
|
||
(ignore-errors
|
||
(set-window-start (selected-window) (point-min))))))
|
||
(if (not (or delete-list install-list))
|
||
(message "No operations specified.")
|
||
;; Confirm with the user.
|
||
(when (or noquery
|
||
(y-or-n-p (paradox--format-message 'question install-list delete-list)))
|
||
;; On Emacs 25, update the selected packages list.
|
||
(when (fboundp 'package--update-selected-packages)
|
||
(let-alist (package-menu--partition-transaction install-list delete-list)
|
||
(package--update-selected-packages .install .delete)))
|
||
;; Background or foreground?
|
||
(if (or (not install-list)
|
||
(not (pcase paradox-execute-asynchronously
|
||
(`nil nil)
|
||
(`ask
|
||
(if noquery nil
|
||
(y-or-n-p "Execute in the background (see `paradox-execute-asynchronously')? ")))
|
||
(_ t))))
|
||
;; Synchronous execution
|
||
(progn
|
||
(let ((alist (paradox--perform-package-transaction install-list delete-list)))
|
||
(run-hook-with-args 'paradox-after-execute-functions
|
||
`((noquery . ,noquery) (async . nil) ,@alist)))
|
||
(when (and (stringp paradox-github-token) paradox-automatically-star)
|
||
(paradox--post-execute-star-unstar before-alist (paradox--repo-alist))))
|
||
;; Start spinning
|
||
(paradox--start-spinner)
|
||
|
||
;; Async execution
|
||
(unless (require 'async nil t)
|
||
(error "For asynchronous execution please install the `async' package"))
|
||
;; We have to do this with eval, because `async-start' is a
|
||
;; macro and it might not have been defined at compile-time.
|
||
(eval
|
||
`(async-start
|
||
(lambda ()
|
||
(require 'package)
|
||
,(async-inject-variables "\\`package-")
|
||
(setq package-menu-async nil)
|
||
(dolist (elt package-alist)
|
||
(package-activate (car elt) 'force))
|
||
(let ((alist ,(macroexpand
|
||
`(paradox--perform-package-transaction ',install-list ',delete-list))))
|
||
(list package-alist
|
||
(when (boundp 'package-selected-packages)
|
||
package-selected-packages)
|
||
package-archive-contents
|
||
;; This is the alist that will be passed to the hook.
|
||
(cons '(noquery . ,noquery) (cons '(async . t) alist)))))
|
||
(lambda (x)
|
||
(setq package-alist (pop x)
|
||
package-selected-packages (pop x)
|
||
package-archive-contents (pop x))
|
||
(when (spinner-p paradox--spinner)
|
||
(spinner-stop paradox--spinner)
|
||
(setq paradox--spinner nil))
|
||
(setq paradox--executing nil)
|
||
(run-hook-with-args 'paradox-after-execute-functions (pop x))
|
||
(paradox--post-execute-star-unstar ',before-alist (paradox--repo-alist))))))))))
|
||
|
||
|
||
;;; Aux functions
|
||
(defun paradox--repo-alist ()
|
||
"List of known repos."
|
||
(delete-dups
|
||
(remove nil
|
||
(mapcar
|
||
(lambda (it) (gethash it paradox--package-repo-list))
|
||
package-alist))))
|
||
|
||
(defun paradox--format-message (question-p install-list delete-list)
|
||
"Format a message regarding a transaction.
|
||
If QUESTION-P is non-nil, format a question suitable for
|
||
`y-or-n-p', otherwise format a report in the past sense.
|
||
INSTALL-LIST and DELETE-LIST are a list of packages about to be
|
||
installed and deleted, respectively."
|
||
(concat
|
||
(when install-list
|
||
(let ((len (length install-list)))
|
||
(format "Install%s %d package%s"
|
||
(if question-p "" "ed")
|
||
len
|
||
(if (> len 1) "s" ""))))
|
||
(when (and install-list (not delete-list))
|
||
(if question-p "? " "."))
|
||
(when (and install-list delete-list)
|
||
", and ")
|
||
(when delete-list
|
||
(let ((len (length delete-list)))
|
||
(format "Delete%s %d package%s%s"
|
||
(if question-p "" "d")
|
||
len
|
||
(if (> len 1) "s" "")
|
||
(if question-p "? " "."))))))
|
||
|
||
(defun paradox--post-execute-star-unstar (before after)
|
||
"Star repos in AFTER absent from BEFORE, unstar vice-versa."
|
||
(let ((repos (hash-table-keys paradox--user-starred-repos)))
|
||
(mapc #'paradox--star-repo
|
||
(seq-difference (seq-difference after before) repos))
|
||
(mapc #'paradox--unstar-repo
|
||
(seq-intersection (seq-difference before after) repos))))
|
||
|
||
(provide 'paradox-execute)
|
||
;;; paradox-execute.el ends here
|