mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 76bbd07de7add0f9d13c6914f158d19630fe2f62
commit | author | age
5cb5f7 1 ;;; helm-elisp-package.el --- helm interface for package.el -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2012 ~ 2018 Thierry Volpiatto <thierry.volpiatto@gmail.com>
4
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation, either version 3 of the License, or
8 ;; (at your option) any later version.
9
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;;; Code:
19 (require 'cl-lib)
20 (require 'helm)
21 (require 'helm-help)
22 (require 'package)
23
24 (defgroup helm-el-package nil
25   "helm elisp packages."
26   :group 'helm)
27
28 (defcustom helm-el-package-initial-filter 'all
29   "Show only installed, upgraded or all packages at startup."
30   :group 'helm-el-package
31   :type '(radio :tag "Initial filter for elisp packages"
32           (const :tag "Show all packages" all)
33           (const :tag "Show installed packages" installed)
34           (const :tag "Show not installed packages" uninstalled)
35           (const :tag "Show upgradable packages" upgrade)))
36
37 (defcustom helm-el-truncate-lines t
38   "Truncate lines in helm-buffer when non--nil."
39   :group 'helm-el-package
40   :type 'boolean)
41
42 ;; internals vars
43 (defvar helm-el-package--show-only 'all)
44 (defvar helm-el-package--initialized-p nil)
45 (defvar helm-el-package--tabulated-list nil)
46 (defvar helm-el-package--upgrades nil)
47 (defvar helm-el-package--removable-packages nil)
48
49 ;; Shutup bytecompiler for emacs-24*
50 (defvar package-menu-async) ; Only available on emacs-25.
51 (declare-function async-byte-recompile-directory "ext:async-bytecomp.el")
52
53 (defun helm-el-package--init ()
54   (let (package-menu-async
55         (inhibit-read-only t))
56     (when (null package-alist)
57       (setq helm-el-package--show-only 'all))
58     (when (and (fboundp 'package--removable-packages)
59                (setq helm-el-package--removable-packages
60                      (package--removable-packages))
61                (fboundp 'package-autoremove))
62       (package-autoremove))
63     (unwind-protect
64          (progn
65            (save-selected-window
66              (if (and helm-el-package--initialized-p
67                       (fboundp 'package-show-package-list))
68                  ;; Use this as `list-packages' doesn't work
69                  ;; properly (empty buffer) when called from lisp
70                  ;; with 'no-fetch (emacs-25 WA).
71                  (package-show-package-list)
72                (when helm--force-updating-p (message "Refreshing packages list..."))  
73                (list-packages helm-el-package--initialized-p))
74              (setq helm-el-package--initialized-p t)
75              (message nil))
76            (helm-init-candidates-in-buffer
77                'global
78              (with-current-buffer (get-buffer "*Packages*")
79                (setq helm-el-package--tabulated-list tabulated-list-entries)
80                (remove-text-properties (point-min) (point-max)
81                                        '(read-only button follow-link category))
82                (buffer-string)))
83            (setq helm-el-package--upgrades (helm-el-package-menu--find-upgrades))
84            (if helm--force-updating-p
85                (if helm-el-package--upgrades
86                    (message "Refreshing packages list done, [%d] package(s) to upgrade"
87                             (length helm-el-package--upgrades))
88                  (message "Refreshing packages list done, no upgrades available"))
89              (setq helm-el-package--show-only (if helm-el-package--upgrades
90                                                   'upgrade
91                                                 helm-el-package-initial-filter))))
92       (kill-buffer "*Packages*"))))
93
94 (defun helm-el-package-describe (candidate)
95   (let ((id (get-text-property 0 'tabulated-list-id candidate)))
96     (describe-package (if (fboundp 'package-desc-name)
97                           (package-desc-name id)
98                         (car id)))))
99
100 (defun helm-el-package-visit-homepage (candidate)
101   (let* ((id (get-text-property 0 'tabulated-list-id candidate))
102          (pkg (if (fboundp 'package-desc-name) (package-desc-name id)
103                 (car id)))
104          (desc (cadr (assoc pkg package-archive-contents)))
105          (extras (package-desc-extras desc))
106          (url (and (listp extras) (cdr-safe (assoc :url extras)))))
107     (if (stringp url)
108         (browse-url url)
109       (message "Package %s has no homepage"
110                (propertize (symbol-name pkg)
111                            'face 'font-lock-keyword-face)))))
112
113 (defun helm-el-run-visit-homepage ()
114   (interactive)
115   (with-helm-alive-p
116     (helm-exit-and-execute-action 'helm-el-package-visit-homepage)))
117 (put 'helm-el-run-visit-homepage 'helm-only t)
118
119 (defun helm-el-package-install-1 (pkg-list)
120   (cl-loop with mkd = pkg-list
121            for p in mkd
122            for id = (get-text-property 0 'tabulated-list-id p)
123            for pkg = (if (fboundp 'package-desc-name) id (car id))
124            do (package-install pkg)
125            collect pkg into installed-list
126            finally do (if (fboundp 'package-desc-full-name)
127                           (message (format "%d packages installed:\n(%s)"
128                                            (length installed-list)
129                                            (mapconcat #'package-desc-full-name
130                                                       installed-list ", ")))
131                           (message (format "%d packages installed:\n(%s)"
132                                            (length installed-list)
133                                            (mapconcat 'symbol-name installed-list ", "))))))
134
135 (defun helm-el-package-install (_candidate)
136   (helm-el-package-install-1 (helm-marked-candidates)))
137
138 (defun helm-el-run-package-install ()
139   (interactive)
140   (with-helm-alive-p
141     (helm-exit-and-execute-action 'helm-el-package-install)))
142 (put 'helm-el-run-package-install 'helm-only t)
143
144 (defun helm-el-package-uninstall-1 (pkg-list &optional force)
145   (cl-loop with mkd = pkg-list
146         for p in mkd
147         for id = (get-text-property 0 'tabulated-list-id p)
148         do
149         (condition-case-unless-debug err
150             (with-no-warnings
151               (if (fboundp 'package-desc-full-name)
152                   ;; emacs 24.4
153                   (condition-case nil
154                       (package-delete id force)
155                     (wrong-number-of-arguments
156                      (package-delete id)))
157                 ;; emacs 24.3
158                 (package-delete (symbol-name (car id))
159                                 (package-version-join (cdr id)))))
160           (error (message (cadr err))))
161         ;; Seems like package-descs are symbols with props instead of
162         ;; vectors in emacs-27, use package-desc-name to ensure
163         ;; compatibility in all emacs versions.
164         unless (assoc (package-desc-name id) package-alist)
165         collect (if (fboundp 'package-desc-full-name)
166                         id
167                       (cons (symbol-name (car id))
168                             (package-version-join (cdr id))))
169         into delete-list
170         finally do (if delete-list
171                        (if (fboundp 'package-desc-full-name)
172                            ;; emacs 24.4
173                            (message (format "%d packages deleted:\n(%s)"
174                                             (length delete-list)
175                                             (mapconcat #'package-desc-full-name
176                                                        delete-list ", ")))
177                            ;; emacs 24.3
178                            (message (format "%d packages deleted:\n(%s)"
179                                             (length delete-list)
180                                             (mapconcat (lambda (x)
181                                                          (concat (car x) "-" (cdr x)))
182                                                        delete-list ", ")))
183                            ;; emacs 24.3 doesn't update
184                            ;; its `package-alist' after deleting.
185                            (cl-loop for p in package-alist
186                                     when (assq (symbol-name (car p)) delete-list)
187                                     do (setq package-alist (delete p package-alist))))
188                        "No package deleted")))
189
190 (defun helm-el-package-uninstall (_candidate)
191   (helm-el-package-uninstall-1 (helm-marked-candidates) helm-current-prefix-arg))
192
193 (defun helm-el-run-package-uninstall ()
194   (interactive)
195   (with-helm-alive-p
196     (helm-exit-and-execute-action 'helm-el-package-uninstall)))
197 (put 'helm-el-run-package-uninstall 'helm-only t)
198
199 (defun helm-el-package-menu--find-upgrades ()
200   (cl-loop for entry in helm-el-package--tabulated-list
201            for pkg-desc = (car entry)
202            for status = (package-desc-status pkg-desc)
203            when (member status '("installed" "unsigned" "dependency"))
204            collect pkg-desc
205            into installed
206            when (member status '("available" "new"))
207            collect (cons (package-desc-name pkg-desc) pkg-desc)
208            into available
209            finally return
210            (cl-loop for pkg in installed
211                     for avail-pkg = (assq (package-desc-name pkg) available)
212                     when (and avail-pkg
213                               (version-list-< (package-desc-version pkg)
214                                               (package-desc-version
215                                                (cdr avail-pkg))))
216                     collect avail-pkg)))
217
218 (defun helm-el-package-upgrade-1 (pkg-list)
219   (cl-loop for p in pkg-list
220            for pkg-desc = (car p)
221            for upgrade = (cdr (assq (package-desc-name pkg-desc)
222                                     helm-el-package--upgrades))
223            do
224            (cond ((null upgrade)
225                   (ignore))
226                  ((equal pkg-desc upgrade)
227                   ;;Install.
228                   (with-no-warnings
229                     (if (boundp 'package-selected-packages)
230                         (package-install pkg-desc t)
231                         (package-install pkg-desc))))
232                  (t
233                   ;; Delete.
234                   (if (boundp 'package-selected-packages)
235                       (with-no-warnings
236                         (package-delete pkg-desc t t))
237                       (package-delete pkg-desc))))))
238
239 (defun helm-el-package-upgrade (_candidate)
240   (helm-el-package-upgrade-1
241    (cl-loop with pkgs = (helm-marked-candidates)
242             for p in helm-el-package--tabulated-list
243             for pkg = (car p)
244             if (member (symbol-name (package-desc-name pkg)) pkgs)
245             collect p)))
246
247 (defun helm-el-run-package-upgrade ()
248   (interactive)
249   (with-helm-alive-p
250     (helm-exit-and-execute-action 'helm-el-package-upgrade)))
251 (put 'helm-el-run-package-upgrade 'helm-only t)
252
253 (defun helm-el-package-upgrade-all ()
254   (if helm-el-package--upgrades
255       (with-helm-display-marked-candidates
256         helm-marked-buffer-name (mapcar (lambda (x) (symbol-name (car x)))
257                                         helm-el-package--upgrades)
258         (when (y-or-n-p "Upgrade all packages? ")
259           (helm-el-package-upgrade-1 helm-el-package--tabulated-list)))
260       (message "No packages to upgrade actually!")))
261
262 (defun helm-el-package-upgrade-all-action (_candidate)
263   (helm-el-package-upgrade-all))
264
265 (defun helm-el-run-package-upgrade-all ()
266   (interactive)
267   (with-helm-alive-p
268     (helm-exit-and-execute-action 'helm-el-package-upgrade-all-action)))
269 (put 'helm-el-run-package-upgrade-all 'helm-only t)
270
271 (defun helm-el-package--transformer (candidates _source)
272   (cl-loop for c in candidates
273            for id = (get-text-property 0 'tabulated-list-id c)
274            for name = (if (fboundp 'package-desc-name)
275                           (and id (package-desc-name id))
276                           (car id))
277            for desc = (package-desc-status id)
278            for built-in-p = (and (package-built-in-p name)
279                                  (not (member desc '("available" "new"
280                                                      "installed" "dependency"))))
281            for installed-p = (member desc '("installed" "dependency"))
282            for upgrade-p = (assq name helm-el-package--upgrades)
283            for user-installed-p = (and (boundp 'package-selected-packages)
284                                        (memq name package-selected-packages))
285            do (when user-installed-p (put-text-property 0 2 'display "S " c))
286            do (when (memq name helm-el-package--removable-packages)
287                 (put-text-property 0 2 'display "U " c)
288                 (put-text-property
289                  2 (+ (length (symbol-name name)) 2)
290                  'face 'font-lock-variable-name-face c))
291            for cand = (cons c (car (split-string c)))
292            when (or (and built-in-p
293                          (eq helm-el-package--show-only 'built-in))
294                     (and upgrade-p
295                          (eq helm-el-package--show-only 'upgrade))
296                     (and installed-p
297                          (eq helm-el-package--show-only 'installed))
298                     (and (not installed-p)
299                          (not built-in-p)
300                          (eq helm-el-package--show-only 'uninstalled))
301                     (eq helm-el-package--show-only 'all))
302            collect cand))
303
304 (defun helm-el-package-show-built-in ()
305   (interactive)
306   (with-helm-alive-p
307     (setq helm-el-package--show-only 'built-in)
308     (helm-update)))
309 (put 'helm-el-package-show-built-in 'helm-only t)
310
311 (defun helm-el-package-show-upgrade ()
312   (interactive)
313   (with-helm-alive-p
314     (setq helm-el-package--show-only 'upgrade)
315     (helm-update)))
316 (put 'helm-el-package-show-upgrade 'helm-only t)
317
318 (defun helm-el-package-show-installed ()
319   (interactive)
320   (with-helm-alive-p
321     (setq helm-el-package--show-only 'installed)
322     (helm-update)))
323 (put 'helm-el-package-show-installed 'helm-only t)
324
325 (defun helm-el-package-show-all ()
326   (interactive)
327   (with-helm-alive-p
328     (setq helm-el-package--show-only 'all)
329     (helm-update)))
330 (put 'helm-el-package-show-all 'helm-only t)
331
332 (defun helm-el-package-show-uninstalled ()
333   (interactive)
334   (with-helm-alive-p
335     (setq helm-el-package--show-only 'uninstalled)
336     (helm-update)))
337 (put 'helm-el-package-show-uninstalled 'helm-only t)
338
339 (defvar helm-el-package-map
340   (let ((map (make-sparse-keymap)))
341     (set-keymap-parent map helm-map)
342     (define-key map (kbd "M-I")   'helm-el-package-show-installed)
343     (define-key map (kbd "M-O")   'helm-el-package-show-uninstalled)
344     (define-key map (kbd "M-U")   'helm-el-package-show-upgrade)
345     (define-key map (kbd "M-B")   'helm-el-package-show-built-in)
346     (define-key map (kbd "M-A")   'helm-el-package-show-all)
347     (define-key map (kbd "C-c i") 'helm-el-run-package-install)
348     (define-key map (kbd "C-c r") 'helm-el-run-package-reinstall)
349     (define-key map (kbd "C-c d") 'helm-el-run-package-uninstall)
350     (define-key map (kbd "C-c u") 'helm-el-run-package-upgrade)
351     (define-key map (kbd "C-c U") 'helm-el-run-package-upgrade-all)
352     (define-key map (kbd "C-c @") 'helm-el-run-visit-homepage)
353     map))
354
355 (defvar helm-source-list-el-package nil)
356 (defclass helm-list-el-package-source (helm-source-in-buffer)
357   ((init :initform 'helm-el-package--init)
358    (get-line :initform 'buffer-substring)
359    (filtered-candidate-transformer :initform 'helm-el-package--transformer)
360    (action-transformer :initform 'helm-el-package--action-transformer)
361    (help-message :initform 'helm-el-package-help-message)
362    (keymap :initform helm-el-package-map)
363    (update :initform 'helm-el-package--update)
364    (candidate-number-limit :initform 9999)
365    (action :initform '(("Describe package" . helm-el-package-describe)
366                        ("Visit homepage" . helm-el-package-visit-homepage)))
367    (group :initform 'helm-el-package)))
368
369 (defun helm-el-package--action-transformer (actions candidate)
370   (let* ((pkg-desc (get-text-property 0 'tabulated-list-id candidate))
371          (status (package-desc-status pkg-desc))
372          (pkg-name (package-desc-name pkg-desc))
373          (built-in (and (package-built-in-p pkg-name)
374                         (not (member status '("available" "new"
375                                               "installed" "dependency")))))
376          (acts (if helm-el-package--upgrades
377                    (append actions '(("Upgrade all packages"
378                                       . helm-el-package-upgrade-all-action)))
379                    actions)))
380     (cond (built-in '(("Describe package" . helm-el-package-describe)))
381           ((and (package-installed-p pkg-name)
382                 (cdr (assq pkg-name helm-el-package--upgrades))
383                 (member status '("installed" "dependency")))
384            (append '(("Upgrade package(s)" . helm-el-package-upgrade)
385                      ("Uninstall package(s)" . helm-el-package-uninstall))
386                    acts))
387           ((and (package-installed-p pkg-name)
388                 (cdr (assq pkg-name helm-el-package--upgrades))
389                 (string= status "available"))
390            (append '(("Upgrade package(s)" . helm-el-package-upgrade))
391                    acts))
392           ((and (package-installed-p pkg-name)
393                 (or (null (package-built-in-p pkg-name))
394                     (and (package-built-in-p pkg-name)
395                          (assq pkg-name package-alist))))
396            (append acts '(("Reinstall package(s)" . helm-el-package-reinstall)
397                           ("Recompile package(s)" . helm-el-package-recompile)
398                           ("Uninstall package(s)" . helm-el-package-uninstall))))
399           (t (append acts '(("Install packages(s)" . helm-el-package-install)))))))
400
401 (defun helm-el-package--update ()
402   (setq helm-el-package--initialized-p nil))
403
404 (defun helm-el-package-recompile (_pkg)
405   (cl-loop for p in (helm-marked-candidates)
406            for pkg-desc = (get-text-property 0 'tabulated-list-id p)
407            for name = (package-desc-name pkg-desc) 
408            for dir = (package-desc-dir pkg-desc)
409            do (if (fboundp 'async-byte-recompile-directory)
410                   (async-byte-recompile-directory dir)
411                   (when (y-or-n-p (format "Really recompile `%s' while already loaded ?" name))
412                     (byte-recompile-directory dir 0 t)))))
413
414 (defun helm-el-package-reinstall (_pkg)
415   (cl-loop for p in (helm-marked-candidates)
416            for pkg-desc = (get-text-property 0 'tabulated-list-id p)
417            for name = (package-desc-name pkg-desc)
418            do (if (boundp 'package-selected-packages)
419                   (with-no-warnings
420                     (package-delete pkg-desc 'force 'nosave)
421                     ;; pkg-desc contain the description
422                     ;; of the installed package just removed
423                     ;; and is BTW no more valid.
424                     ;; Use the entry in package-archive-content
425                     ;; which is the non--installed package entry.
426                     ;; For some reason `package-install'
427                     ;; need a pkg-desc (package-desc-p) for the build-in
428                     ;; packages already installed, the name (as symbol)
429                     ;; fails with such packages.
430                     (package-install
431                      (cadr (assq name package-archive-contents)) t))
432                   (package-delete pkg-desc)
433                   (package-install name))))
434
435 (defun helm-el-run-package-reinstall ()
436   (interactive)
437   (with-helm-alive-p
438     (helm-exit-and-execute-action 'helm-el-package-reinstall)))
439 (put 'helm-el-run-package-reinstall 'helm-only t)
440
441 ;;;###autoload
442 (defun helm-list-elisp-packages (arg)
443   "Preconfigured helm for listing and handling emacs packages."
444   (interactive "P")
445   (when arg (setq helm-el-package--initialized-p nil))
446   (unless helm-source-list-el-package
447     (setq helm-source-list-el-package
448           (helm-make-source "list packages" 'helm-list-el-package-source)))
449   (helm :sources 'helm-source-list-el-package
450         :truncate-lines helm-el-truncate-lines
451         :full-frame t
452         :buffer "*helm list packages*"))
453
454 ;;;###autoload
455 (defun helm-list-elisp-packages-no-fetch (arg)
456   "Preconfigured helm for emacs packages.
457
458 Same as `helm-list-elisp-packages' but don't fetch packages on remote.
459 Called with a prefix ARG always fetch packages on remote."
460   (interactive "P")
461   (let ((helm-el-package--initialized-p (null arg)))
462     (helm-list-elisp-packages nil)))
463
464 (provide 'helm-elisp-package)
465
466 ;;; helm-elisp-package.el ends here