[Emacs-diffs] trunk r115528: Support filtering by keywords in package listings.

[Teodor Zlatanov]

------------------------------------------------------------
revno: 115528
revision-id: address@hidden
parent: address@hidden
committer: Ted Zlatanov <address@hidden>
branch nick: quickfixes
timestamp: Sat 2013-12-14 14:55:19 -0500
message:
  Support filtering by keywords in package listings.
  
  * emacs-lisp/package.el (package-built-in-p): Support both
  built-in and the package.el converted package descriptions.
  (package-show-package-list): Allow keywords.
  (package-keyword-button-action): Use it instead of
  `finder-list-matches'.
  (package-menu-filter-interactive): Interactive filtering (by
  keyword) function.
  (package-menu--generate): Support keywords and change keymappings
  and headers when they are given.
  (package--has-keyword-p): Helper function.
  (package-menu--refresh): Use it.
  (package--mapc): Helper function.
  (package-all-keywords): Use it.
  (package-menu-mode-map): Set up menu items and keybindings to
  provide a filtering UI.
modified:
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/emacs-lisp/package.el     package.el-20100617020707-ybavz666awsxwin6-2

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2013-12-14 18:04:09 +0000
+++ b/lisp/ChangeLog    2013-12-14 19:55:19 +0000
@@ -1,5 +1,23 @@
 2013-12-14  Teodor Zlatanov  <address@hidden>
 
+       * emacs-lisp/package.el (package-built-in-p): Support both
+       built-in and the package.el converted package descriptions.
+       (package-show-package-list): Allow keywords.
+       (package-keyword-button-action): Use it instead of
+       `finder-list-matches'.
+       (package-menu-filter-interactive): Interactive filtering (by
+       keyword) function.
+       (package-menu--generate): Support keywords and change keymappings
+       and headers when they are given.
+       (package--has-keyword-p): Helper function.
+       (package-menu--refresh): Use it.
+       (package--mapc): Helper function.
+       (package-all-keywords): Use it.
+       (package-menu-mode-map): Set up menu items and keybindings to
+       provide a filtering UI.
+
+2013-12-14  Teodor Zlatanov  <address@hidden>
+
        * net/gnutls.el (gnutls-verify-error): New defcustom to control
        the behavior when a certificate fails validation.  Defaults to
        old behavior: never abort, just warn.

=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el        2013-12-14 16:02:39 +0000
+++ b/lisp/emacs-lisp/package.el        2013-12-14 19:55:19 +0000
@@ -524,13 +524,15 @@
   "Return true if PACKAGE is built-in to Emacs.
 Optional arg MIN-VERSION, if non-nil, should be a version list
 specifying the minimum acceptable version."
-  (let ((bi (assq package package--builtin-versions)))
-    (cond
-     (bi (version-list-<= min-version (cdr bi)))
-     (min-version nil)
-     (t
-      (require 'finder-inf nil t) ; For `package--builtins'.
-      (assq package package--builtins)))))
+  (if (package-desc-p package) ;; was built-in and then was converted
+      (eq 'builtin (package-desc-dir package))
+    (let ((bi (assq package package--builtin-versions)))
+      (cond
+       (bi (version-list-<= min-version (cdr bi)))
+       (min-version nil)
+       (t
+        (require 'finder-inf nil t) ; For `package--builtins'.
+        (assq package package--builtins))))))
 
 (defun package--from-builtin (bi-desc)
   (package-desc-create :name (pop bi-desc)
@@ -1528,10 +1530,9 @@
       (revert-buffer nil t)
       (goto-char (point-min)))))
 
-(autoload 'finder-list-matches "finder")
 (defun package-keyword-button-action (button)
   (let ((pkg-keyword (button-get button 'package-keyword)))
-    (finder-list-matches pkg-keyword)))
+    (package-show-package-list t (list pkg-keyword))))
 
 (defun package-make-button (text &rest props)
   (let ((button-text (if (display-graphic-p) text (concat "[" text "]")))
@@ -1557,6 +1558,7 @@
     (define-key map "i" 'package-menu-mark-install)
     (define-key map "U" 'package-menu-mark-upgrades)
     (define-key map "r" 'package-menu-refresh)
+    (define-key map "f" 'package-menu-filter-interactive)
     (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
     (define-key map "x" 'package-menu-execute)
     (define-key map "h" 'package-menu-quick-help)
@@ -1565,6 +1567,9 @@
     (define-key menu-map [mq]
       '(menu-item "Quit" quit-window
                  :help "Quit package selection"))
+    (define-key menu-map [mf]
+      '(menu-item "Filter" package-menu-filter-interactive
+                 :help "Filter package selection (q to go back)"))
     (define-key menu-map [s1] '("--"))
     (define-key menu-map [mn]
       '(menu-item "Next" next-line
@@ -1677,9 +1682,10 @@
                                             "installed"
                                           "unsigned"))))))))
 
-(defun package-menu--refresh (&optional packages)
+(defun package-menu--refresh (&optional packages keywords)
   "Re-populate the `tabulated-list-entries'.
-PACKAGES should be nil or t, which means to display all known packages."
+PACKAGES should be nil or t, which means to display all known packages.
+KEYWORDS should be nil or a list of keywords."
   ;; Construct list of (PKG-DESC . STATUS).
   (unless packages (setq packages t))
   (let (info-list name)
@@ -1688,12 +1694,14 @@
       (setq name (car elt))
       (when (or (eq packages t) (memq name packages))
         (dolist (pkg (cdr elt))
-          (package--push pkg (package-desc-status pkg) info-list))))
+          (when (package--has-keyword-p pkg keywords)
+            (package--push pkg (package-desc-status pkg) info-list)))))
 
     ;; Built-in packages:
     (dolist (elt package--builtins)
       (setq name (car elt))
       (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+                 (package--has-keyword-p (package--from-builtin elt) keywords)
                  (or package-list-unversioned
                      (package--bi-desc-version (cdr elt)))
                 (or (eq packages t) (memq name packages)))
@@ -1705,20 +1713,89 @@
       (when (or (eq packages t) (memq name packages))
         (dolist (pkg (cdr elt))
           ;; Hide obsolete packages.
-          (unless (package-installed-p (package-desc-name pkg)
-                                       (package-desc-version pkg))
+          (when (and (not (package-installed-p (package-desc-name pkg)
+                                               (package-desc-version pkg)))
+                     (package--has-keyword-p pkg keywords))
             (package--push pkg (package-desc-status pkg) info-list)))))
 
     ;; Print the result.
     (setq tabulated-list-entries
           (mapcar #'package-menu--print-info info-list))))
 
-(defun package-menu--generate (remember-pos packages)
+(defun package-all-keywords ()
+  "Collect all package keywords"
+  (let (keywords)
+    (package--mapc (lambda (desc)
+                     (let* ((extras (and desc (package-desc-extras desc)))
+                            (desc-keywords (cdr (assoc :keywords extras))))
+                       (setq keywords (append keywords desc-keywords)))))
+    keywords))
+
+(defun package--mapc (function &optional packages)
+  "Call FUNCTION for all known PACKAGES.
+PACKAGES can be nil or t, which means to display all known
+packages, or a list of packages.
+
+Built-in packages are converted with `package--from-builtin'."
+  (unless packages (setq packages t))
+  (let (name)
+    ;; Installed packages:
+    (dolist (elt package-alist)
+      (setq name (car elt))
+      (when (or (eq packages t) (memq name packages))
+        (mapc function (cdr elt))))
+
+    ;; Built-in packages:
+    (dolist (elt package--builtins)
+      (setq name (car elt))
+      (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
+                 (or package-list-unversioned
+                     (package--bi-desc-version (cdr elt)))
+                (or (eq packages t) (memq name packages)))
+        (funcall function (package--from-builtin elt))))
+
+    ;; Available and disabled packages:
+    (dolist (elt package-archive-contents)
+      (setq name (car elt))
+      (when (or (eq packages t) (memq name packages))
+        (dolist (pkg (cdr elt))
+          ;; Hide obsolete packages.
+          (unless (package-installed-p (package-desc-name pkg)
+                                       (package-desc-version pkg))
+        (funcall function pkg)))))))
+
+(defun package--has-keyword-p (desc &optional keywords)
+  "Test if package DESC has any of the given KEYWORDS.
+When none are given, the package matches."
+  (if keywords
+      (let* ((extras (and desc (package-desc-extras desc)))
+             (desc-keywords (cdr (assoc :keywords extras)))
+             found)
+        (dolist (k keywords)
+          (when (and (not found)
+                     (member k desc-keywords))
+            (setq found t)))
+        found)
+    t))
+
+(defun package-menu--generate (remember-pos packages &optional keywords)
   "Populate the Package Menu.
  If REMEMBER-POS is non-nil, keep point on the same entry.
 PACKAGES should be t, which means to display all known packages,
-or a list of package names (symbols) to display."
-  (package-menu--refresh packages)
+or a list of package names (symbols) to display.
+
+With KEYWORDS given, only packages with those keywords are
+shown."
+  (package-menu--refresh packages keywords)
+  (setf (car (aref tabulated-list-format 0))
+        (if keywords
+            (let ((filters (mapconcat 'identity keywords ",")))
+              (concat "Package[" filters "]"))
+          "Package"))
+  (if keywords
+      (define-key package-menu-mode-map "q" 'package-show-package-list)
+    (define-key package-menu-mode-map "q" 'quit-window))
+  (tabulated-list-init-header)
   (tabulated-list-print remember-pos))
 
 (defun package-menu--print-info (pkg)
@@ -2014,18 +2091,27 @@
 (defalias 'package-list-packages 'list-packages)
 
 ;; Used in finder.el
-(defun package-show-package-list (packages)
+(defun package-show-package-list (&optional packages keywords)
   "Display PACKAGES in a *Packages* buffer.
 This is similar to `list-packages', but it does not fetch the
 updated list of packages, and it only displays packages with
-names in PACKAGES (which should be a list of symbols)."
+names in PACKAGES (which should be a list of symbols).
+
+When KEYWORDS are given, only packages with those KEYWORDS are
+shown."
+  (interactive)
   (require 'finder-inf nil t)
   (let ((buf (get-buffer-create "*Packages*")))
     (with-current-buffer buf
       (package-menu-mode)
-      (package-menu--generate nil packages))
+      (package-menu--generate nil packages keywords))
     (switch-to-buffer buf)))
 
+(defun package-menu-filter-interactive (keyword)
+  "Filter the *Packages* buffer."
+  (interactive (list (completing-read "Keyword: " (package-all-keywords))))
+  (package-show-package-list t (list keyword)))
+
 (defun package-list-packages-no-fetch ()
   "Display a list of packages.
 Does not fetch the updated list of packages before displaying.