;;; helm-elisp-package.el --- helm interface for package.el -*- lexical-binding: t -*- ;; Copyright (C) 2012 ~ 2021 Thierry Volpiatto ;; 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 . ;;; 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))) (defcustom helm-el-truncate-lines t "Truncate lines in `helm-buffer' when non-nil." :group 'helm-el-package :type 'boolean) (defcustom helm-el-package-upgrade-on-start nil "Show package upgrades on startup when non nil." :group 'helm-el-package :type 'boolean) (defcustom helm-el-package-autoremove-on-start nil "Try to autoremove no more needed packages on startup. See `package-autoremove'." :group 'helm-el-package :type 'boolean) ;; 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. (defvar helm-marked-buffer-name) (declare-function async-byte-recompile-directory "ext:async-bytecomp.el") (declare-function with-helm-display-marked-candidates "helm-utils.el") (defun helm-el-package--init () ;; In emacs-27 package-show-package-list returns an empty buffer ;; until package-initialize have been called. (unless (or package--initialized (null (boundp 'package-quickstart))) (package-initialize)) (let (package-menu-async (inhibit-read-only t)) (when (null package-alist) (setq helm-el-package--show-only 'all)) (unless (consp package-selected-packages) (helm-aif (package--find-non-dependencies) (setq package-selected-packages it))) (when (and (setq helm-el-package--removable-packages (package--removable-packages)) helm-el-package-autoremove-on-start) (package-autoremove)) (unwind-protect (progn (save-selected-window (if helm-el-package--initialized-p ;; 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) (when helm--force-updating-p (message "Refreshing packages list...")) (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) (remove-text-properties (point-min) (point-max) '(read-only button follow-link category)) (goto-char (point-min)) (while (re-search-forward "^[ \t]+" nil t) (replace-match "")) (buffer-string))) (setq helm-el-package--upgrades (helm-el-package-menu--find-upgrades)) (if helm--force-updating-p (if helm-el-package--upgrades (message "Refreshing packages list done, [%d] package(s) to upgrade" (length helm-el-package--upgrades)) (message "Refreshing packages list done, no upgrades available")) (setq helm-el-package--show-only (if (and helm-el-package-upgrade-on-start 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 (package-desc-name id)))) (defun helm-el-package-visit-homepage (candidate) (let* ((id (get-text-property 0 'tabulated-list-id candidate)) (pkg (package-desc-name 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-elisp-package--pkg-name (pkg) (if (package-desc-p pkg) (package-desc-name pkg) pkg)) (defun helm-el-package-install-1 (pkg-list) (cl-loop with mkd = pkg-list for p in mkd for id = (get-text-property 0 'tabulated-list-id p) for name = (helm-elisp-package--pkg-name id) do (package-install id t) when (helm-aand (assq name package-alist) (package-desc-dir (cadr it)) (file-exists-p it)) collect id into installed-list and do (unless (package--user-selected-p name) (package--save-selected-packages (cons name package-selected-packages))) finally do (message (format "%d packages installed:\n(%s)" (length installed-list) (mapconcat #'package-desc-full-name installed-list ", "))))) (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) (defun helm-el-package-uninstall-1 (pkg-list &optional force) (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 (package-delete id force) (error (message (cadr err)))) ;; Seems like package-descs are symbols with props instead of ;; vectors in emacs-27, use package-desc-name to ensure ;; compatibility in all emacs versions. unless (assoc (package-desc-name id) package-alist) collect id into delete-list finally do (if delete-list (message (format "%d packages deleted:\n(%s)" (length delete-list) (mapconcat #'package-desc-full-name delete-list ", "))) "No package deleted"))) (defun helm-el-package-uninstall (_candidate) (helm-el-package-uninstall-1 (helm-marked-candidates) helm-current-prefix-arg)) (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) ;; A dependency. when (string= status "dependency") collect pkg-desc into dependencies ;; An installed package used as dependency (user have ;; installed this package explicitely). when (package--used-elsewhere-p pkg-desc) collect pkg-desc into installed-as-dep ;; An installed package. when (member status '("installed" "unsigned")) collect pkg-desc into installed when (member status '("available" "new")) collect (cons (package-desc-name pkg-desc) pkg-desc) into available finally return ;; Always try to upgrade dependencies before installed. (cl-loop with all = (append dependencies installed-as-dep installed) for pkg in all for name = (package-desc-name pkg) for avail-pkg = (assq name available) when (and avail-pkg (version-list-< (package-desc-version pkg) (package-desc-version (cdr avail-pkg)))) collect avail-pkg))) (defun helm-el-package--user-installed-p (package) "Return non-nil if PACKAGE is a user-installed package." (let* ((assoc (assq package package-alist)) (pkg-desc (and assoc (cadr assoc))) (dir (and pkg-desc (package-desc-dir pkg-desc)))) (when dir (file-in-directory-p dir package-user-dir)))) (defun helm-el-package-upgrade-1 (pkg-list) (cl-loop for p in pkg-list for pkg-desc = (car p) for pkg-name = (package-desc-name pkg-desc) for upgrade = (cdr (assq pkg-name helm-el-package--upgrades)) do (cond (;; Install. (equal pkg-desc upgrade) (message "Installing package `%s'" pkg-name) (package-install pkg-desc t)) (;; Do nothing. (or (null upgrade) ;; This may happen when a Elpa version of pkg ;; is installed and need upgrade and pkg is as ;; well a builtin package. (package-built-in-p pkg-name)) (ignore)) (;; Delete. t (message "Deleting package `%s'" pkg-name) (package-delete pkg-desc t t))))) (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 (helm-fast-remove-dups (mapcar (lambda (x) (symbol-name (car x))) helm-el-package--upgrades) :test 'equal) (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 disp = (concat " " c) for id = (get-text-property 0 'tabulated-list-id c) for name = (and id (package-desc-name id)) 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")) for upgrade-p = (assq name helm-el-package--upgrades) for user-installed-p = (memq name package-selected-packages) do (when (and user-installed-p (not upgrade-p)) (put-text-property 0 2 'display "S " disp)) do (when (or (memq name helm-el-package--removable-packages) (and upgrade-p installed-p)) (put-text-property 0 2 'display "U " disp) (put-text-property 2 (+ (length (symbol-name name)) 2) 'face 'font-lock-variable-name-face disp)) do (when (and upgrade-p (not installed-p) (not built-in-p)) (put-text-property 0 2 'display "I " disp)) for cand = (cons disp (car (split-string disp))) when (or (and built-in-p (eq helm-el-package--show-only 'built-in)) (and upgrade-p (eq helm-el-package--show-only 'upgrade)) (and installed-p (eq helm-el-package--show-only 'installed)) (and (not installed-p) (not built-in-p) (eq helm-el-package--show-only 'uninstalled)) (eq helm-el-package--show-only 'all)) collect cand)) (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) (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) (define-key map (kbd "M-B") 'helm-el-package-show-built-in) (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))) (find-file-target :initform #'helm-el-package-quit-an-find-file-fn) (group :initform 'helm-el-package))) (defun helm-el-package-quit-an-find-file-fn (source) (let* ((sel (helm-get-selection nil nil source)) (pkg (and (stringp sel) (get-text-property 0 'tabulated-list-id sel)))) (when (and pkg (package-installed-p pkg)) (expand-file-name (package-desc-dir pkg))))) (defun helm-el-package--action-transformer (actions candidate) (let* ((pkg-desc (get-text-property 0 'tabulated-list-id candidate)) (status (package-desc-status pkg-desc)) (pkg-name (package-desc-name pkg-desc)) (built-in (and (package-built-in-p pkg-name) (not (member status '("available" "new" "installed" "dependency"))))) (acts (if helm-el-package--upgrades (append actions '(("Upgrade all packages" . helm-el-package-upgrade-all-action))) actions))) (cond (built-in '(("Describe package" . helm-el-package-describe))) ((and (package-installed-p pkg-name) (cdr (assq pkg-name helm-el-package--upgrades)) (member status '("installed" "dependency"))) (append '(("Upgrade package(s)" . helm-el-package-upgrade) ("Uninstall package(s)" . helm-el-package-uninstall)) acts)) ((and (package-installed-p pkg-name) (cdr (assq pkg-name helm-el-package--upgrades)) (string= status "available")) (append '(("Upgrade package(s)" . helm-el-package-upgrade)) 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) ("Recompile package(s)" . helm-el-package-recompile) ("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)) (defun helm-el-package-recompile (_pkg) (cl-loop for p in (helm-marked-candidates) do (helm-el-package-recompile-1 p))) (defun helm-el-package-recompile-1 (pkg) (let* ((pkg-desc (get-text-property 0 'tabulated-list-id pkg)) (dir (package-desc-dir pkg-desc))) (async-byte-recompile-directory dir))) (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) do (helm-el-package-reinstall-1 pkg-desc))) (defun helm-el-package-reinstall-1 (pkg-desc) (let ((name (package-desc-name pkg-desc))) (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 (cadr (assq name package-archive-contents)) t))) (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 :truncate-lines helm-el-truncate-lines :full-frame t :buffer "*helm list packages*")) ;;;###autoload (defun helm-list-elisp-packages-no-fetch (arg) "Preconfigured Helm for Emacs packages. Same as `helm-list-elisp-packages' but don't fetch packages on remote. Called with a prefix ARG always fetch packages on remote." (interactive "P") (let ((helm-el-package--initialized-p (null arg))) (helm-list-elisp-packages nil))) (provide 'helm-elisp-package) ;;; helm-elisp-package.el ends here