my-emacs-d/elpa/helm-20161019.2251/helm-elisp-package.el

441 lines
19 KiB
EmacsLisp
Raw Normal View History

2016-04-21 21:27:19 +00:00
;;; helm-elisp-package.el --- helm interface for package.el -*- lexical-binding: t -*-
;; Copyright (C) 2012 ~ 2016 Thierry Volpiatto <thierry.volpiatto@gmail.com>
;; 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 <http://www.gnu.org/licenses/>.
;;; Code:
(require 'cl-lib)
(require 'helm)
(require 'helm-help)
(require 'package)
(defgroup helm-el-package nil
"helm elisp packages."
:group 'helm)
(defcustom helm-el-package-initial-filter 'all
"Show only installed, upgraded or all packages at startup."
:group 'helm-el-package
:type '(radio :tag "Initial filter for elisp packages"
(const :tag "Show all packages" all)
(const :tag "Show installed packages" installed)
(const :tag "Show not installed packages" uninstalled)
(const :tag "Show upgradable packages" upgrade)))
;; internals vars
(defvar helm-el-package--show-only 'all)
(defvar helm-el-package--initialized-p nil)
(defvar helm-el-package--tabulated-list nil)
(defvar helm-el-package--upgrades nil)
(defvar helm-el-package--removable-packages nil)
;; Shutup bytecompiler for emacs-24*
(defvar package-menu-async) ; Only available on emacs-25.
2016-06-29 07:21:54 +00:00
(declare-function async-byte-recompile-directory "ext:async-bytecomp.el")
2016-04-21 21:27:19 +00:00
(defun helm-el-package--init ()
(let (package-menu-async)
(when (null package-alist)
(setq helm-el-package--show-only 'all))
(when (fboundp 'package--removable-packages)
(setq helm-el-package--removable-packages
(package--removable-packages)))
(save-selected-window
(if (and helm-el-package--initialized-p
(fboundp 'package-show-package-list))
;; Use this as `list-packages' doesn't work
;; properly (empty buffer) when called from lisp
;; with 'no-fetch (emacs-25 WA).
(package-show-package-list)
2016-08-18 20:01:20 +00:00
(when helm--force-updating-p (message "Refreshing packages list..."))
2016-04-21 21:27:19 +00:00
(list-packages helm-el-package--initialized-p))
(setq helm-el-package--initialized-p t)
(message nil))
(helm-init-candidates-in-buffer
'global
(with-current-buffer (get-buffer "*Packages*")
(setq helm-el-package--tabulated-list tabulated-list-entries)
(buffer-string)))
(setq helm-el-package--upgrades (helm-el-package-menu--find-upgrades))
2016-08-18 20:01:20 +00:00
(if helm--force-updating-p
2016-04-21 21:27:19 +00:00
(if helm-el-package--upgrades
2016-09-15 09:18:17 +00:00
(message "Refreshing packages list done, [%d] package(s) to upgrade"
2016-04-21 21:27:19 +00:00
(length helm-el-package--upgrades))
(message "Refreshing packages list done, no upgrades available"))
(setq helm-el-package--show-only (if helm-el-package--upgrades
'upgrade
helm-el-package-initial-filter)))
(kill-buffer "*Packages*")))
(defun helm-el-package-describe (candidate)
(let ((id (get-text-property 0 'tabulated-list-id candidate)))
(describe-package (if (fboundp 'package-desc-name)
(package-desc-name id)
(car id)))))
(defun helm-el-package-visit-homepage (candidate)
(let* ((id (get-text-property 0 'tabulated-list-id candidate))
(pkg (if (fboundp 'package-desc-name) (package-desc-name id)
(car id)))
(desc (cadr (assoc pkg package-archive-contents)))
(extras (package-desc-extras desc))
(url (and (listp extras) (cdr-safe (assoc :url extras)))))
(if (stringp url)
(browse-url url)
(message "Package %s has no homepage"
(propertize (symbol-name pkg)
'face 'font-lock-keyword-face)))))
(defun helm-el-run-visit-homepage ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-visit-homepage)))
(put 'helm-el-run-visit-homepage 'helm-only t)
(defun helm-el-package-install-1 (pkg-list)
(cl-loop with mkd = pkg-list
2016-06-29 07:21:54 +00:00
for p in mkd
for id = (get-text-property 0 'tabulated-list-id p)
do (package-install
(if (fboundp 'package-desc-name) id (car id)))
collect (if (fboundp 'package-desc-full-name) id (car id))
into installed-list
finally do (if (fboundp 'package-desc-full-name)
(message (format "%d packages installed:\n(%s)"
(length installed-list)
(mapconcat #'package-desc-full-name
installed-list ", ")))
(message (format "%d packages installed:\n(%s)"
(length installed-list)
(mapconcat 'symbol-name installed-list ", "))))))
2016-04-21 21:27:19 +00:00
(defun helm-el-package-install (_candidate)
(helm-el-package-install-1 (helm-marked-candidates)))
(defun helm-el-run-package-install ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-install)))
(put 'helm-el-run-package-install 'helm-only t)
2016-09-15 09:18:17 +00:00
(defun helm-el-package-uninstall-1 (pkg-list &optional force)
2016-04-21 21:27:19 +00:00
(cl-loop with mkd = pkg-list
for p in mkd
for id = (get-text-property 0 'tabulated-list-id p)
do
(condition-case-unless-debug err
(with-no-warnings
(if (fboundp 'package-desc-full-name)
;; emacs 24.4
2016-09-15 09:18:17 +00:00
(condition-case nil
(package-delete id force)
(wrong-number-of-arguments
(package-delete id)))
2016-04-21 21:27:19 +00:00
;; emacs 24.3
(package-delete (symbol-name (car id))
(package-version-join (cdr id)))))
(error (message (cadr err))))
unless (assoc (elt id 1) package-alist)
collect (if (fboundp 'package-desc-full-name)
id
(cons (symbol-name (car id))
(package-version-join (cdr id))))
into delete-list
finally do (if delete-list
(if (fboundp 'package-desc-full-name)
;; emacs 24.4
(message (format "%d packages deleted:\n(%s)"
(length delete-list)
(mapconcat #'package-desc-full-name
delete-list ", ")))
;; emacs 24.3
(message (format "%d packages deleted:\n(%s)"
(length delete-list)
(mapconcat (lambda (x)
(concat (car x) "-" (cdr x)))
delete-list ", ")))
;; emacs 24.3 doesn't update
;; its `package-alist' after deleting.
(cl-loop for p in package-alist
when (assq (symbol-name (car p)) delete-list)
do (setq package-alist (delete p package-alist))))
"No package deleted")))
(defun helm-el-package-uninstall (_candidate)
2016-09-15 09:18:17 +00:00
(helm-el-package-uninstall-1 (helm-marked-candidates) helm-current-prefix-arg))
2016-04-21 21:27:19 +00:00
(defun helm-el-run-package-uninstall ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-uninstall)))
(put 'helm-el-run-package-uninstall 'helm-only t)
(defun helm-el-package-menu--find-upgrades ()
(cl-loop for entry in helm-el-package--tabulated-list
for pkg-desc = (car entry)
for status = (package-desc-status pkg-desc)
when (member status '("installed" "unsigned" "dependency"))
collect pkg-desc
into installed
when (member status '("available" "new"))
collect (cons (package-desc-name pkg-desc) pkg-desc)
into available
finally return
(cl-loop for pkg in installed
for avail-pkg = (assq (package-desc-name pkg) available)
when (and avail-pkg
(version-list-< (package-desc-version pkg)
(package-desc-version
(cdr avail-pkg))))
collect avail-pkg)))
(defun helm-el-package-upgrade-1 (pkg-list)
(cl-loop for p in pkg-list
for pkg-desc = (car p)
for upgrade = (cdr (assq (package-desc-name pkg-desc)
helm-el-package--upgrades))
do
(cond ((null upgrade)
(ignore))
((equal pkg-desc upgrade)
;;Install.
2016-06-29 07:21:54 +00:00
(with-no-warnings
(if (boundp 'package-selected-packages)
(package-install pkg-desc t)
(package-install pkg-desc))))
2016-04-21 21:27:19 +00:00
(t
;; Delete.
(if (boundp 'package-selected-packages)
(with-no-warnings
(package-delete pkg-desc t t))
(package-delete pkg-desc))))))
(defun helm-el-package-upgrade (_candidate)
(helm-el-package-upgrade-1
(cl-loop with pkgs = (helm-marked-candidates)
for p in helm-el-package--tabulated-list
for pkg = (car p)
if (member (symbol-name (package-desc-name pkg)) pkgs)
collect p)))
(defun helm-el-run-package-upgrade ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-upgrade)))
(put 'helm-el-run-package-upgrade 'helm-only t)
(defun helm-el-package-upgrade-all ()
(if helm-el-package--upgrades
(with-helm-display-marked-candidates
helm-marked-buffer-name (mapcar (lambda (x) (symbol-name (car x)))
helm-el-package--upgrades)
(when (y-or-n-p "Upgrade all packages? ")
(helm-el-package-upgrade-1 helm-el-package--tabulated-list)))
(message "No packages to upgrade actually!")))
(defun helm-el-package-upgrade-all-action (_candidate)
(helm-el-package-upgrade-all))
(defun helm-el-run-package-upgrade-all ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-upgrade-all-action)))
(put 'helm-el-run-package-upgrade-all 'helm-only t)
(defun helm-el-package--transformer (candidates _source)
(cl-loop for c in candidates
for id = (get-text-property 0 'tabulated-list-id c)
for name = (if (fboundp 'package-desc-name)
(and id (package-desc-name id))
(car id))
2016-08-18 20:01:20 +00:00
for desc = (package-desc-status id)
for built-in-p = (and (package-built-in-p name)
(not (member desc '("available" "new"
"installed" "dependency"))))
for installed-p = (member desc '("installed" "dependency"))
2016-04-21 21:27:19 +00:00
for upgrade-p = (assq name helm-el-package--upgrades)
for user-installed-p = (and (boundp 'package-selected-packages)
(memq name package-selected-packages))
do (when user-installed-p (put-text-property 0 2 'display "S " c))
do (when (memq name helm-el-package--removable-packages)
(put-text-property 0 2 'display "U " c)
(put-text-property
2 (+ (length (symbol-name name)) 2)
'face 'font-lock-variable-name-face c))
for cand = (cons c (car (split-string c)))
2016-08-18 20:01:20 +00:00
when (or (and built-in-p
(eq helm-el-package--show-only 'built-in))
(and upgrade-p
2016-04-21 21:27:19 +00:00
(eq helm-el-package--show-only 'upgrade))
(and installed-p
(eq helm-el-package--show-only 'installed))
(and (not installed-p)
2016-08-18 20:01:20 +00:00
(not built-in-p)
(eq helm-el-package--show-only 'uninstalled))
2016-04-21 21:27:19 +00:00
(eq helm-el-package--show-only 'all))
collect cand))
2016-08-18 20:01:20 +00:00
(defun helm-el-package-show-built-in ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'built-in)
(helm-update)))
(put 'helm-el-package-show-built-in 'helm-only t)
2016-04-21 21:27:19 +00:00
(defun helm-el-package-show-upgrade ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'upgrade)
(helm-update)))
(put 'helm-el-package-show-upgrade 'helm-only t)
(defun helm-el-package-show-installed ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'installed)
(helm-update)))
(put 'helm-el-package-show-installed 'helm-only t)
(defun helm-el-package-show-all ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'all)
(helm-update)))
(put 'helm-el-package-show-all 'helm-only t)
(defun helm-el-package-show-uninstalled ()
(interactive)
(with-helm-alive-p
(setq helm-el-package--show-only 'uninstalled)
(helm-update)))
(put 'helm-el-package-show-uninstalled 'helm-only t)
(defvar helm-el-package-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map helm-map)
(define-key map (kbd "M-I") 'helm-el-package-show-installed)
(define-key map (kbd "M-O") 'helm-el-package-show-uninstalled)
(define-key map (kbd "M-U") 'helm-el-package-show-upgrade)
2016-08-18 20:01:20 +00:00
(define-key map (kbd "M-B") 'helm-el-package-show-built-in)
2016-04-21 21:27:19 +00:00
(define-key map (kbd "M-A") 'helm-el-package-show-all)
(define-key map (kbd "C-c i") 'helm-el-run-package-install)
(define-key map (kbd "C-c r") 'helm-el-run-package-reinstall)
(define-key map (kbd "C-c d") 'helm-el-run-package-uninstall)
(define-key map (kbd "C-c u") 'helm-el-run-package-upgrade)
(define-key map (kbd "C-c U") 'helm-el-run-package-upgrade-all)
(define-key map (kbd "C-c @") 'helm-el-run-visit-homepage)
map))
(defvar helm-source-list-el-package nil)
(defclass helm-list-el-package-source (helm-source-in-buffer)
((init :initform 'helm-el-package--init)
(get-line :initform 'buffer-substring)
(filtered-candidate-transformer :initform 'helm-el-package--transformer)
(action-transformer :initform 'helm-el-package--action-transformer)
(help-message :initform 'helm-el-package-help-message)
(keymap :initform helm-el-package-map)
(update :initform 'helm-el-package--update)
(candidate-number-limit :initform 9999)
(action :initform '(("Describe package" . helm-el-package-describe)
("Visit homepage" . helm-el-package-visit-homepage)))))
(defun helm-el-package--action-transformer (actions candidate)
2016-08-18 20:01:20 +00:00
(let* ((pkg-desc (get-text-property 0 'tabulated-list-id candidate))
(status (package-desc-status pkg-desc))
2016-04-21 21:27:19 +00:00
(pkg-name (package-desc-name pkg-desc))
2016-08-18 20:01:20 +00:00
(built-in (and (package-built-in-p pkg-name)
(not (member status '("available" "new"
"installed" "dependency")))))
2016-04-21 21:27:19 +00:00
(acts (if helm-el-package--upgrades
(append actions '(("Upgrade all packages"
. helm-el-package-upgrade-all-action)))
actions)))
2016-08-18 20:01:20 +00:00
(cond (built-in '(("Describe package" . helm-el-package-describe)))
((and (package-installed-p pkg-name)
2016-04-21 21:27:19 +00:00
(cdr (assq pkg-name helm-el-package--upgrades)))
(append '(("Upgrade package(s)" . helm-el-package-upgrade)
("Uninstall package(s)" . helm-el-package-uninstall)) acts))
((and (package-installed-p pkg-name)
(or (null (package-built-in-p pkg-name))
(and (package-built-in-p pkg-name)
(assq pkg-name package-alist))))
(append acts '(("Reinstall package(s)" . helm-el-package-reinstall)
2016-06-29 07:21:54 +00:00
("Recompile package(s)" . helm-el-package-recompile)
2016-04-21 21:27:19 +00:00
("Uninstall package(s)" . helm-el-package-uninstall))))
(t (append acts '(("Install packages(s)" . helm-el-package-install)))))))
(defun helm-el-package--update ()
(setq helm-el-package--initialized-p nil))
2016-06-29 07:21:54 +00:00
(defun helm-el-package-recompile (_pkg)
(cl-loop for p in (helm-marked-candidates)
for pkg-desc = (get-text-property 0 'tabulated-list-id p)
for name = (package-desc-name pkg-desc)
for dir = (package-desc-dir pkg-desc)
do (if (fboundp 'async-byte-recompile-directory)
(async-byte-recompile-directory dir)
(when (y-or-n-p (format "Really recompile `%s' while already loaded ?" name))
(byte-recompile-directory dir 0 t)))))
2016-04-21 21:27:19 +00:00
(defun helm-el-package-reinstall (_pkg)
(cl-loop for p in (helm-marked-candidates)
for pkg-desc = (get-text-property 0 'tabulated-list-id p)
for name = (package-desc-name pkg-desc)
do (if (boundp 'package-selected-packages)
(with-no-warnings
(package-delete pkg-desc 'force 'nosave)
;; pkg-desc contain the description
;; of the installed package just removed
;; and is BTW no more valid.
;; Use the entry in package-archive-content
;; which is the non--installed package entry.
;; For some reason `package-install'
;; need a pkg-desc (package-desc-p) for the build-in
;; packages already installed, the name (as symbol)
;; fails with such packages.
(package-install
2016-06-29 07:21:54 +00:00
(cadr (assq name package-archive-contents)) t))
2016-04-21 21:27:19 +00:00
(package-delete pkg-desc)
(package-install name))))
(defun helm-el-run-package-reinstall ()
(interactive)
(with-helm-alive-p
(helm-exit-and-execute-action 'helm-el-package-reinstall)))
(put 'helm-el-run-package-reinstall 'helm-only t)
;;;###autoload
(defun helm-list-elisp-packages (arg)
"Preconfigured helm for listing and handling emacs packages."
(interactive "P")
(when arg (setq helm-el-package--initialized-p nil))
(unless helm-source-list-el-package
(setq helm-source-list-el-package
(helm-make-source "list packages" 'helm-list-el-package-source)))
(helm :sources 'helm-source-list-el-package
:buffer "*helm list packages*"))
;;;###autoload
(defun helm-list-elisp-packages-no-fetch ()
"Preconfigured helm for emacs packages.
Same as `helm-list-elisp-packages' but don't fetch packages on remote."
(interactive)
(let ((helm-el-package--initialized-p t))
(helm-list-elisp-packages nil)))
(provide 'helm-elisp-package)
;;; helm-elisp-package.el ends here