unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#38424: [PATCH] Add new filter functions to Package Menu
@ 2019-11-29 12:31 Stefan Kangas
  2019-11-30 12:18 ` Eli Zaretskii
  0 siblings, 1 reply; 9+ messages in thread
From: Stefan Kangas @ 2019-11-29 12:31 UTC (permalink / raw)
  To: 38424

[-- Attachment #1: Type: text/plain, Size: 373 bytes --]

The attached patches adds new commands to filter the "*Packages*"
buffer by version, status and archive.  (The first patch only adds new
version list comparison predicates, something I needed to simplify the
second patch.)

I meant to sent this earlier, but got too busy with real life.  I hope
that it's not too late to make it into Emacs 27.

Best regards,
Stefan Kangas

[-- Attachment #2: 0001-Add-version-comparison-predicates-for-and.patch --]
[-- Type: text/x-patch, Size: 5845 bytes --]

From a27410cd2ef7558fc66842dab3454be44d816b62 Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
Date: Tue, 12 Nov 2019 02:01:22 +0100
Subject: [PATCH 1/2] Add version comparison predicates for > and >=

* lisp/subr.el (version-list->, version-list->=, version>)
(version>=): New functions.

* test/lisp/subr-tests.el (subr-test-version-list-<)
(subr-test-version-list->, subr-test-version-list-=)
(subr-test-version-list-<=, subr-test-version-list->=): New tests.
---
 lisp/subr.el            | 39 +++++++++++++++++++++++++++++++++++++--
 test/lisp/subr-tests.el | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+), 2 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index c1614c2e03..0e03392561 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -5568,6 +5568,14 @@ version-list-<
    ;; l1 null and l2 not null     ==> l2 length > l1 length
    (t  (< 0 (version-list-not-zero l2)))))
 
+(defun version-list-> (l1 l2)
+  "Return t if L1, a list specification of a version, is higher than L2.
+
+Note that a version specified by the list (1) is equal to (1 0),
+\(1 0 0), (1 0 0 0), etc.  That is, the trailing zeros are insignificant.
+Also, a version given by the list (1) is higher than (1 -1), which in
+turn is higher than (1 -2), which is higher than (1 -3)."
+  (not (version-list-<= l1 l2)))
 
 (defun version-list-= (l1 l2)
   "Return t if L1, a list specification of a version, is equal to L2.
@@ -5589,7 +5597,6 @@ version-list-=
    ;; l1 null and l2 not null ==> l2 length > l1 length
    (t  (zerop (version-list-not-zero l2)))))
 
-
 (defun version-list-<= (l1 l2)
   "Return t if L1, a list specification of a version, is lower or equal to L2.
 
@@ -5610,6 +5617,15 @@ version-list-<=
    ;; l1 null and l2 not null ==> l2 length > l1 length
    (t  (<= 0 (version-list-not-zero l2)))))
 
+(defun version-list->= (l1 l2)
+  "Return t if L1, a list specification of a version, is higher or equal to L2.
+
+Note that a version specified by the list (1) is equal to (1 0),
+\(1 0 0), (1 0 0 0), etc.  That is, the trailing zeros are insignificant.
+Also, a version given by the list (1) is higher than (1 -1), which in
+turn is higher than (1 -2), which is higher than (1 -3)."
+  (not (version-list-< l1 l2)))
+
 (defun version-list-not-zero (lst)
   "Return the first non-zero element of LST, which is a list of integers.
 
@@ -5621,7 +5637,6 @@ version-list-not-zero
     ;; there is no element different of zero
     0))
 
-
 (defun version< (v1 v2)
   "Return t if version V1 is lower (older) than V2.
 
@@ -5652,6 +5667,26 @@ version=
 Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
   (version-list-= (version-to-list v1) (version-to-list v2)))
 
+(defun version> (v1 v2)
+  "Return t if version V1 is higher than V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc.  That is, the trailing \".0\"s are insignificant.  Also, version
+string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
+which is higher than \"1alpha\", which is higher than \"1snapshot\".
+Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+  (not (version-list-<= (version-to-list v1) (version-to-list v2))))
+
+(defun version>= (v1 v2)
+  "Return t if version V1 is higher or equal to V2.
+
+Note that version string \"1\" is equal to \"1.0\", \"1.0.0\", \"1.0.0.0\",
+etc.  That is, the trailing \".0\"s are insignificant.  Also, version
+string \"1\" is higher (newer) than \"1pre\", which is higher than \"1beta\",
+which is higher than \"1alpha\", which is higher than \"1snapshot\".
+Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions."
+  (not (version-list-< (version-to-list v1) (version-to-list v2))))
+
 (defvar package--builtin-versions
   ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions.
   (purecopy `((emacs . ,(version-to-list emacs-version))))
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index b3c04cdc9a..f9cdcc4a8b 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -244,6 +244,42 @@ subr-test-version-parsing
               (error-message-string (should-error (version-to-list "beta22_8alpha3")))
               "Invalid version syntax: `beta22_8alpha3' (must start with a number)"))))
 
+(ert-deftest subr-test-version-list-< ()
+  (should (version-list-< '(0) '(1)))
+  (should (version-list-< '(0 9) '(1 0)))
+  (should (version-list-< '(1 -1) '(1 0)))
+  (should (version-list-< '(1 -2) '(1 -1)))
+  (should (not (version-list-< '(1) '(0))))
+  (should (not (version-list-< '(1 1) '(1 0))))
+  (should (not (version-list-< '(1) '(1 0))))
+  (should (not (version-list-< '(1 0) '(1 0 0)))))
+
+(ert-deftest subr-test-version-list-> ()
+  (should (version-list-> '(1 0) '(0 9)))
+  (should (version-list-> '(1) '(1 -1)))
+  (should (version-list-> '(1) '(0)))
+  (should (version-list-> '(1 1) '(1 0)))
+  (should (not (version-list-> '(0) '(1))))
+  (should (not (version-list-> '(1) '(1 0))))
+  (should (not (version-list-> '(1 0) '(1 0 0)))))
+
+(ert-deftest subr-test-version-list-= ()
+  (should (version-list-= '(1) '(1)))
+  (should (version-list-= '(1 0) '(1)))
+  (should (not (version-list-= '(0) '(1)))))
+
+(ert-deftest subr-test-version-list-<= ()
+  (should (version-list-<= '(0) '(1)))
+  (should (version-list-<= '(1) '(1)))
+  (should (version-list-<= '(1 0) '(1)))
+  (should (not (version-list-<= '(1) '(0)))))
+
+(ert-deftest subr-test-version-list->= ()
+  (should (version-list->= '(1) '(0)))
+  (should (version-list->= '(1) '(1)))
+  (should (version-list->= '(1 0) '(1)))
+  (should (not (version-list->= '(0) '(1)))))
+
 (defun subr-test--backtrace-frames-with-backtrace-frame (base)
   "Reference implementation of `backtrace-frames'."
   (let ((idx 0)
-- 
2.20.1


[-- Attachment #3: 0002-Add-new-filter-functions-to-Package-Menu.patch --]
[-- Type: text/x-patch, Size: 27756 bytes --]

From 2c98f9ca12daaf40b35c86801fc0137975bde312 Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
Date: Tue, 5 Nov 2019 15:48:48 +0100
Subject: [PATCH 2/2] Add new filter functions to Package Menu

* lisp/emacs-lisp/package.el (package-menu-filter-by-version)
(package-menu-filter-by-status, package-menu-filter-by-archive):
New filter functions.
(package-menu--filter-by): New helper function.
(package-menu-filter-by-keyword, package-menu-filter-by-name): Use
above helper function.
(package-menu-mode-menu):
(package-menu-mode-map): Update menu to include new filter functions.
* doc/emacs/package.texi (Package Menu): Document it.
* etc/NEWS: Announce it.

(package-menu--refresh): Remove t as synonym for nil in first
argument.  Doc fix.
(list-packages, package-menu-mode, package-keyword-button-action):
Update calls to above.
(package-menu-filter-clear): Update calls to above and rename from
'package-menu-clear-filter'.
(package-menu--display): New function.
(package-menu--generate): Simplify.

* test/lisp/emacs-lisp/package-tests.el (with-package-menu-test):
New macro.
(package-test-update-listing, package-test-list-filter-by-name):
Use above macro.
(package-test-list-filter-clear): Rename from
'package-test-list-clear-filter' and use above macro.
(package-test-list-filter-by-archive)
(package-test-list-filter-by-keyword)
(package-test-list-filter-by-status)
(package-test-list-filter-by-version): New tests.
---
 doc/emacs/package.texi                |  63 ++++---
 etc/NEWS                              |  23 ++-
 lisp/emacs-lisp/package.el            | 249 +++++++++++++++++++-------
 test/lisp/emacs-lisp/package-tests.el | 103 +++++++----
 4 files changed, 319 insertions(+), 119 deletions(-)

diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
index 1c0f853427..afc18e5611 100644
--- a/doc/emacs/package.texi
+++ b/doc/emacs/package.texi
@@ -157,27 +157,6 @@ Package Menu
 list of available packages from the package archive again, and
 redisplays the package list.
 
-@item / k
-@kindex / k @r{(Package Menu)}
-@findex package-menu-filter-by-keyword
-Filter the package list by keyword
-(@code{package-menu-filter-by-keyword}).  This prompts for a keyword
-(e.g., @samp{games}), then shows only the packages that relate to that
-keyword.
-
-@item / n
-@kindex / n @r{(Package Menu)}
-@findex package-menu-filter-by-name
-Filter the package list by name (@code{package-menu-filter-by-name}).
-This prompts for a string, then shows only the packages whose names
-match a regexp with that value.
-
-@item / /
-@kindex / / @r{(Package Menu)}
-@findex package-menu-clear-filter
-Clear filter currently applied to the package list
-(@code{package-menu-clear-filter}).
-
 @item H
 @kindex H @r{(Package Menu)}
 @findex package-menu-hide-package
@@ -189,6 +168,48 @@ Package Menu
 @findex package-menu-toggle-hiding
 Toggle visibility of old versions of packages and also of versions
 from lower-priority archives (@code{package-menu-toggle-hiding}).
+
+@item / a
+@kindex / a @r{(Package Menu)}
+@findex package-menu-filter-by-archive
+Filter package list by archive (@code{package-menu-filter-by-archive}).
+This prompts for a package archive (e.g., @samp{gnu}), then shows only
+packages from that archive.
+
+@item / k
+@kindex / k @r{(Package Menu)}
+@findex package-menu-filter-by-keyword
+Filter package list by keyword (@code{package-menu-filter-by-keyword}).
+This prompts for a keyword (e.g., @samp{games}), then shows only
+packages with that keyword.
+
+@item / n
+@kindex / n @r{(Package Menu)}
+@findex package-menu-filter-by-name
+Filter package list by name (@code{package-menu-filter-by-name}).
+This prompts for a regular expression, then shows only packages
+with names matching that regexp.
+
+@item / s
+@kindex / s @r{(Package Menu)}
+@findex package-menu-filter-by-status
+Filter package list by status (@code{package-menu-filter-by-status}).
+This prompts for one or more statuses (e.g., @samp{available}), then
+shows only packages with matching status.
+
+@item / v
+@kindex / v @r{(Package Menu)}
+@findex package-menu-filter-by-version
+Filter package list by version (@code{package-menu-filter-by-version}).
+This prompts first for one of the qualifiers @samp{<}, @samp{>} or
+@samp{=}, and then a package version, and shows packages that has a
+lower, equal or higher version than the one specified.
+
+@item / /
+@kindex / / @r{(Package Menu)}
+@findex package-menu-filter-clear
+Clear filter currently applied to the package list
+(@code{package-menu-filter-clear}).
 @end table
 
 @noindent
diff --git a/etc/NEWS b/etc/NEWS
index cb73e46358..2a3b6f2c1e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1199,14 +1199,21 @@ early init file.
 *** New function 'package-activate-all'.
 
 +++
-*** New functions for filtering packages list.
-A new function has been added which allows users to filter the
-packages list by name: 'package-menu-filter-by-name'.  By default, it
-is bound to '/ n'.  Additionally, the function
-'package-menu-fiter-by-keyword' has been renamed from
-'package-menu-filter'.  Its keybinding has also been changed to '/ k'
-(from 'f').  To clear any of the two filters, the user can now call
-the 'package-menu-clear-filter' function, bound to '/ /' by default.
+*** New functions for filtering the package list.
+The new key bindings are as follows:
+
+key             binding
+---             -------
+/ a             package-menu-filter-by-archive
+/ k             package-menu-filter-by-keyword
+/ n             package-menu-filter-by-name
+/ s             package-menu-filter-by-status
+/ v             package-menu-filter-by-version
+/ /             package-menu-filter-clear
+
+The function that was previously named 'package-menu-filter' has been
+renamed to 'package-menu-filter-by-keyword'.  It is no longer bound to
+'f' in the package buffer, but instead to '/ n' as shown above.
 
 ---
 *** Imenu support has been added to 'package-menu-mode'.
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 56e160232d..6274766ef7 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2644,7 +2644,7 @@ package-keyword-button-action
 Used for the `action' property of buttons in the buffer created by
 `describe-package'."
   (let ((pkg-keyword (button-get button 'package-keyword)))
-    (package-show-package-list t (list pkg-keyword))))
+    (package-show-package-list nil (list pkg-keyword))))
 
 (defun package-make-button (text &rest properties)
   "Insert button labeled TEXT with button PROPERTIES at point.
@@ -2690,15 +2690,18 @@ package-menu-mode-map
     (define-key map "i" 'package-menu-mark-install)
     (define-key map "U" 'package-menu-mark-upgrades)
     (define-key map "r" 'revert-buffer)
-    (define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
-    (define-key map (kbd "/ n") 'package-menu-filter-by-name)
-    (define-key map (kbd "/ /") 'package-menu-clear-filter)
     (define-key map "~" 'package-menu-mark-obsolete-for-deletion)
     (define-key map "x" 'package-menu-execute)
     (define-key map "h" 'package-menu-quick-help)
     (define-key map "H" #'package-menu-hide-package)
     (define-key map "?" 'package-menu-describe-package)
     (define-key map "(" #'package-menu-toggle-hiding)
+    (define-key map (kbd "/ /") 'package-menu-filter-clear)
+    (define-key map (kbd "/ a") 'package-menu-filter-by-archive)
+    (define-key map (kbd "/ k") 'package-menu-filter-by-keyword)
+    (define-key map (kbd "/ n") 'package-menu-filter-by-name)
+    (define-key map (kbd "/ s") 'package-menu-filter-by-status)
+    (define-key map (kbd "/ v") 'package-menu-filter-by-version)
     map)
   "Local keymap for `package-menu-mode' buffers.")
 
@@ -2725,9 +2728,12 @@ package-menu-mode-menu
 
     "--"
     ("Filter Packages"
+     ["Filter by Archive" package-menu-filter-by-archive :help "Filter packages by archive"]
      ["Filter by Keyword" package-menu-filter-by-keyword :help "Filter packages by keyword"]
      ["Filter by Name" package-menu-filter-by-name :help "Filter packages by name"]
-     ["Clear Filter" package-menu-clear-filter :help "Clear package list filter"])
+     ["Filter by Status" package-menu-filter-by-status :help "Filter packages by status"]
+     ["Filter by Version" package-menu-filter-by-version :help "Filter packages by version"]
+     ["Clear Filter" package-menu-filter-clear :help "Clear package list filter"])
 
     ["Hide by Regexp" package-menu-hide-package :help "Permanently hide all packages matching a regexp"]
     ["Display Older Versions" package-menu-toggle-hiding
@@ -2761,7 +2767,7 @@ package-menu-mode
           ("Description" 0 package-menu--description-predicate)])
   (setq tabulated-list-padding 2)
   (setq tabulated-list-sort-key (cons "Status" nil))
-  (add-hook 'tabulated-list-revert-hook #'package-menu--refresh nil t)
+  (add-hook 'tabulated-list-revert-hook #'package-menu--refresh)
   (tabulated-list-init-header)
   (setq revert-buffer-function 'package-menu--refresh-contents)
   (setf imenu-prev-index-position-function
@@ -2927,17 +2933,19 @@ package-hidden-regexps
   :type '(repeat (regexp :tag "Hide packages with name matching")))
 
 (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.
-KEYWORDS should be nil or a list of keywords."
+  "Re-populate `tabulated-list-entries' with all known packages.
+With optional argument PACKAGES, a list of package
+names (symbols), add only packages with matching names.
+
+With optional argument KEYWORDS, a list of keywords as symbols,
+add only packages with matching keywords."
   ;; Construct list of (PKG-DESC . STATUS).
-  (unless packages (setq packages t))
   (let ((hidden-names (mapconcat #'identity package-hidden-regexps "\\|"))
         info-list)
     ;; Installed packages:
     (dolist (elt package-alist)
       (let ((name (car elt)))
-        (when (or (eq packages t) (memq name packages))
+        (when (or (not packages) (memq name packages))
           (dolist (pkg (cdr elt))
             (when (package--has-keyword-p pkg keywords)
               (push pkg info-list))))))
@@ -2950,7 +2958,7 @@ package-menu--refresh
           (when (and (package--has-keyword-p pkg keywords)
                      (or package-list-unversioned
                          (package--bi-desc-version (cdr elt)))
-                     (or (eq packages t) (memq name packages)))
+                     (or (not packages) (memq name packages)))
             (push pkg info-list)))))
 
     ;; Available and disabled packages:
@@ -2959,7 +2967,7 @@ package-menu--refresh
     (dolist (elt package-archive-contents)
       (let ((name (car elt)))
         ;; To be displayed it must be in PACKAGES;
-        (when (and (or (eq packages t) (memq name packages))
+        (when (and (or (not packages) (memq name packages))
                    ;; and we must either not be hiding anything,
                    (or (not package-menu--hide-packages)
                        (not package-hidden-regexps)
@@ -2970,7 +2978,7 @@ package-menu--refresh
             (when (package--has-keyword-p pkg keywords)
               (push pkg info-list))))))
 
-    ;; Print the result.
+    ;; Set `tabulated-list-entries'.
     (tabulated-list-init-header)
     (setq tabulated-list-entries
           (mapcar #'package-menu--print-info-simple info-list))))
@@ -3031,23 +3039,30 @@ package--has-keyword-p
         found)
     t))
 
-(defun package-menu--generate (remember-pos packages &optional keywords)
-  "Populate the Package Menu.
+(defun package-menu--display (remember-pos suffix)
+  "Display 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.
 
-With KEYWORDS given, only packages with those keywords are
-shown."
-  (package-menu--refresh packages keywords)
+If SUFFIX is non-nil, append that to \"Package\" for the first
+column in the header line."
   (setf (car (aref tabulated-list-format 0))
-        (if keywords
-            (let ((filters (mapconcat #'identity keywords ",")))
-              (concat "Package[" filters "]"))
+        (if suffix
+            (concat "Package[" suffix "]")
           "Package"))
   (tabulated-list-init-header)
   (tabulated-list-print remember-pos))
 
+(defun package-menu--generate (remember-pos &optional packages keywords)
+  "Populate and display the Package Menu.
+If REMEMBER-POS is non-nil, keep point on the same entry.
+
+Arguments PACKAGES and KEYWORDS are like `package-menu--refresh'."
+  (package-menu--refresh packages keywords)
+  (package-menu--display remember-pos
+                  (when keywords
+                    (let ((filters (mapconcat #'identity keywords ",")))
+                      (concat "Package[" filters "]")))))
+
 (defun package-menu--print-info (pkg)
   "Return a package entry suitable for `tabulated-list-entries'.
 PKG has the form (PKG-DESC . STATUS).
@@ -3655,7 +3670,7 @@ list-packages
 
       ;; If we're not async, this would be redundant.
       (when package-menu-async
-        (package-menu--generate nil t)))
+        (package-menu--generate nil)))
     ;; The package menu buffer has keybindings.  If the user types
     ;; `M-x list-packages', that suggests it should become current.
     (switch-to-buffer buf)))
@@ -3683,51 +3698,164 @@ package-show-package-list
         (select-window win)
       (switch-to-buffer buf))))
 
+(defun package-menu--filter-by (predicate suffix)
+  "Filter \"*Packages*\" buffer by PREDICATE, and add DESC to header.
+PREDICATE is a function which will be called with one argument, a
+`package-desc' object, and returns t if that object should be
+listed in the Package Menu.
+
+SUFFIX is passed on to `package-menu--display' and is added to
+the header line of the first column."
+  ;; Update `tabulated-list-entries' so that it contains all
+  ;; packages before searching.
+  (package-menu--refresh)
+  (let (found-entries)
+    (dolist (entry tabulated-list-entries)
+      (when (funcall predicate (car entry))
+        (push entry found-entries)))
+    (if found-entries
+        (progn
+          (setq tabulated-list-entries found-entries)
+          (package-menu--display t suffix))
+      (user-error "No packages found"))))
+
+(defun package-menu-filter-by-archive (archive)
+  "Filter the \"*Packages*\" buffer by ARCHIVE.
+Display only packages from package archive ARCHIVE.
+
+When called interactively, prompt for ARCHIVE, which can be a
+comma-separated string.  If ARCHIVE is empty, show all packages.
+
+When called from Lisp, ARCHIVE can be a string or a list of
+strings.  If ARCHIVE is nil or the empty string, show all
+packages."
+  (interactive (list (completing-read-multiple
+                      "Filter by archive (comma separated): "
+                      (mapcar #'car package-archives))))
+  (package--ensure-package-menu-mode)
+  (let ((re (if (listp archive)
+                (regexp-opt archive)
+              archive)))
+    (package-menu--filter-by (lambda (pkg-desc)
+                        (let ((pkg-archive (package-desc-archive pkg-desc)))
+                          (and pkg-archive
+                               (string-match-p re pkg-archive))))
+                      (concat "archive:" (if (listp archive)
+                                             (string-join archive ",")
+                                           archive)))))
+
 (defun package-menu-filter-by-keyword (keyword)
   "Filter the \"*Packages*\" buffer by KEYWORD.
-Show only those items that relate to the specified KEYWORD.
-
-KEYWORD can be a string or a list of strings.  If it is a list, a
-package will be displayed if it matches any of the keywords.
-Interactively, it is a list of strings separated by commas.
-
-KEYWORD can also be used to filter by status or archive name by
-using keywords like \"arc:gnu\" and \"status:available\".
-Statuses available include \"incompat\", \"available\",
-\"built-in\" and \"installed\"."
-  (interactive
-   (list (completing-read-multiple
-          "Keywords (comma separated): " (package-all-keywords))))
+Display only packages with specified KEYWORD.
+
+When called interactively, prompt for KEYWORD, which can be a
+comma-separated string.  If KEYWORD is empty, show all packages.
+
+When called from Lisp, KEYWORD can be a string or a list of
+strings.  If KEYWORD is nil or the empty string, show all
+packages."
+  (interactive (list (completing-read-multiple
+                      "Keywords (comma separated): "
+                      (package-all-keywords))))
+  (when (stringp keyword)
+    (setq keyword (list keyword)))
   (package--ensure-package-menu-mode)
-  (package-show-package-list t (if (stringp keyword)
-                                   (list keyword)
-                                 keyword)))
+  (if (not keyword)
+      (package-menu--generate t)
+    (package-menu--filter-by (lambda (pkg-desc)
+                        (package--has-keyword-p pkg-desc keyword))
+                      (concat "keyword:" (string-join keyword ",")))))
 
 (defun package-menu-filter-by-name (name)
-  "Filter the \"*Packages*\" buffer by NAME.
-Show only those items whose name matches the regular expression
-NAME.  If NAME is nil or the empty string, show all packages."
-  (interactive (list (read-from-minibuffer "Filter by name (regexp): ")))
+  "Filter the \"*Packages*\" buffer by NAME regexp.
+Display only packages with name that matches regexp NAME.
+
+When called interactively, prompt for NAME.
+
+If NAME is nil or the empty string, show all packages."
+  (interactive (list (read-regexp "Filter by name (regexp)")))
   (package--ensure-package-menu-mode)
   (if (or (not name) (string-empty-p name))
-      (package-show-package-list t nil)
-    ;; Update `tabulated-list-entries' so that it contains all
-    ;; packages before searching.
-    (package-menu--refresh t nil)
-    (let (matched)
-      (dolist (entry tabulated-list-entries)
-        (let* ((pkg-name (package-desc-name (car entry))))
-          (when (string-match name (symbol-name pkg-name))
-            (push pkg-name matched))))
-      (if matched
-          (package-show-package-list matched nil)
-        (user-error "No packages found")))))
-
-(defun package-menu-clear-filter ()
+      (package-menu--generate t)
+    (package-menu--filter-by (lambda (pkg-desc)
+                        (string-match-p name (symbol-name
+                                              (package-desc-name pkg-desc))))
+                      (format "name:%s" name))))
+
+(defun package-menu-filter-by-status (status)
+  "Filter the \"*Packages*\" buffer by STATUS.
+Display only packages with specified STATUS.
+
+When called interactively, prompt for STATUS, which can be a
+comma-separated string.  If STATUS is empty, show all packages.
+
+When called from Lisp, STATUS can be a string or a list of
+strings.  If STATUS is nil or the empty string, show all
+packages."
+  (interactive (list (completing-read "Filter by status: "
+                                      '("avail-obso"
+                                        "available"
+                                        "built-in"
+                                        "dependency"
+                                        "disabled"
+                                        "external"
+                                        "held"
+                                        "incompat"
+                                        "installed"
+                                        "new"
+                                        "unsigned"))))
+  (package--ensure-package-menu-mode)
+  (if (or (not status) (string-empty-p status))
+      (package-menu--generate t)
+    (package-menu--filter-by (lambda (pkg-desc)
+                        (string-match-p status (package-desc-status pkg-desc)))
+                      (format "status:%s" status))))
+
+(defun package-menu-filter-by-version (version predicate)
+  "Filter the \"*Packages*\" buffer by VERSION and PREDICATE.
+Display only packages with a matching version.
+
+When called interactively, prompt for one of the qualifiers `<',
+`>' or `=', and a package version.  Show only packages that has a
+lower (`<'), equal (`=') or higher (`>') version than the
+specified one.
+
+When called from Lisp, VERSION should be a version string and
+PREDICATE should be the symbol `=', `<' or `>'.
+
+If VERSION is nil or the empty string, show all packages."
+  (interactive (let ((choice (intern
+                              (char-to-string
+                               (read-char-choice
+                                "Filter by version? [Type =, <, > or q] "
+                                '(?< ?> ?= ?q))))))
+                 (if (eq choice 'q)
+                     '(quit nil)
+                   (list (read-from-minibuffer
+                          (concat "Filter by version ("
+                                  (cond ((eq choice '=) "= equal to")
+                                        ((eq choice '<) "< less than")
+                                        ((eq choice '>) "> greater than"))
+                                  "): "))
+                         choice))))
+  (unless (equal predicate 'quit)
+    (if (or (not version) (string-empty-p version))
+        (package-menu--generate t)
+      (package-menu--filter-by
+       (let ((fun (cond ((eq predicate '=) 'version-list-=)
+                        ((eq predicate '<) 'version-list-<)
+                        ((eq predicate '>) 'version-list->)
+                        (t (error "Unknown predicate: %s" predicate))))
+             (ver (version-to-list version)))
+         (lambda (pkg-desc)
+           (funcall fun (package-desc-version pkg-desc) ver)))
+       (format "versions:%s%s" predicate version)))))
+
+(defun package-menu-filter-clear ()
   "Clear any filter currently applied to the \"*Packages*\" buffer."
   (interactive)
   (package--ensure-package-menu-mode)
-  (package-menu--generate t t))
+  (package-menu--generate t))
 
 (defun package-list-packages-no-fetch ()
   "Display a list of packages.
@@ -3770,6 +3898,7 @@ package-get-version
             (or (lm-header "package-version")
                 (lm-header "version")))))))))
 
+\f
 ;;;; Quickstart: precompute activation actions for faster start up.
 
 ;; Activating packages via `package-initialize' is costly: for N installed
diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el
index 828c456842..07f772d730 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -349,43 +349,86 @@ package-test-install-multifile
           (goto-char (point-min))
           (should (re-search-forward re nil t)))))))
 
+\f
+;;; Package Menu tests
+
+(defmacro with-package-menu-test (&rest body)
+  "Set up Package Menu (\"*Packages*\") buffer for testing."
+  (declare (indent 0) (debug (([&rest form]) body)))
+  `(with-package-test ()
+     (let ((buf (package-list-packages)))
+       (unwind-protect
+           (progn ,@body)
+         (kill-buffer buf)))))
+
 (ert-deftest package-test-update-listing ()
   "Ensure installed package status is updated."
-  (with-package-test ()
-    (let ((buf (package-list-packages)))
-      (search-forward-regexp "^ +simple-single")
-      (package-menu-mark-install)
-      (package-menu-execute)
-      (run-hooks 'post-command-hook)
-      (should (package-installed-p 'simple-single))
-      (switch-to-buffer "*Packages*")
-      (goto-char (point-min))
-      (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
-      (goto-char (point-min))
-      (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t))
-      (kill-buffer buf))))
+  (with-package-menu-test
+    (search-forward-regexp "^ +simple-single")
+    (package-menu-mark-install)
+    (package-menu-execute)
+    (run-hooks 'post-command-hook)
+    (should (package-installed-p 'simple-single))
+    (switch-to-buffer "*Packages*")
+    (goto-char (point-min))
+    (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t))
+    (goto-char (point-min))
+    (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t))))
+
+(ert-deftest package-test-list-filter-by-archive ()
+  "Ensure package list is filtered correctly by archive version."
+  (with-package-menu-test
+    ;; TODO: Add another package archive to test filtering, because
+    ;;       the testing environment currently only has one.
+    (package-menu-filter-by-archive "gnu")
+    (goto-char (point-min))
+    (should (looking-at "^\\s-+multi-file"))
+    (should (= (count-lines (point-min) (point-max)) 4))
+    (should-error (package-menu-filter-by-archive "non-existent archive"))))
+
+(ert-deftest package-test-list-filter-by-keyword ()
+  "Ensure package list is filtered correctly by package keyword."
+  (with-package-menu-test
+    (package-menu-filter-by-keyword "frobnicate")
+    (goto-char (point-min))
+    (should (re-search-forward "^\\s-+simple-single" nil t))
+    (should (= (count-lines (point-min) (point-max)) 1))
+    (should-error (package-menu-filter-by-keyword "non-existent-keyword"))))
 
 (ert-deftest package-test-list-filter-by-name ()
   "Ensure package list is filtered correctly by package name."
-  (with-package-test ()
-    (let ((buf (package-list-packages)))
+  (with-package-menu-test ()
+    (package-menu-filter-by-name "tetris")
+    (goto-char (point-min))
+    (should (re-search-forward "^\\s-+tetris" nil t))
+    (should (= (count-lines (point-min) (point-max)) 1))))
+
+(ert-deftest package-test-list-filter-by-status ()
+  "Ensure package list is filtered correctly by package status."
+  (with-package-menu-test
+    (package-menu-filter-by-status "available")
+    (goto-char (point-min))
+    (should (re-search-forward "^\\s-+multi-file" nil t))
+    (should (= (count-lines (point-min) (point-max)) 4))
+    ;; No installed packages in default environment.
+    (should-error (package-menu-filter-by-status "installed"))))
+
+(ert-deftest package-test-list-filter-by-version ()
+  "Ensure package list is filtered correctly by package version."
+  (with-package-menu-test
+    (package-menu-filter-by-version "1.1" '=)
+    (goto-char (point-min))
+    (should (looking-at "^\\s-+simple-two-depend"))
+    (should (= (count-lines (point-min) (point-max)) 2))))
+
+(ert-deftest package-test-list-filter-clear ()
+  "Ensure package list filter is cleared correctly."
+  (with-package-menu-test
+    (let ((num-packages (count-lines (point-min) (point-max))))
       (package-menu-filter-by-name "tetris")
-      (goto-char (point-min))
-      (should (re-search-forward "^\\s-+tetris" nil t))
       (should (= (count-lines (point-min) (point-max)) 1))
-      (kill-buffer buf))))
-
-(ert-deftest package-test-list-clear-filter ()
-  "Ensure package list filter is cleared correctly."
-  (with-package-test ()
-    (let ((buf (package-list-packages)))
-      (let ((num-packages (count-lines (point-min) (point-max))))
-        (should (> num-packages 1))
-        (package-menu-filter-by-name "tetris")
-        (should (= (count-lines (point-min) (point-max)) 1))
-        (package-menu-clear-filter)
-        (should (= (count-lines (point-min) (point-max)) num-packages)))
-      (kill-buffer buf))))
+      (package-menu-filter-clear)
+      (should (= (count-lines (point-min) (point-max)) num-packages)))))
 
 (ert-deftest package-test-update-archives ()
   "Test updating package archives."
-- 
2.20.1


^ permalink raw reply related	[flat|nested] 9+ messages in thread
end of thread, other threads:[~2020-02-05 12:36 UTC | newest]

Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-11-29 12:31 bug#38424: [PATCH] Add new filter functions to Package Menu Stefan Kangas
2019-11-30 12:18 ` Eli Zaretskii
2019-12-01 11:12   ` Stefan Kangas
2019-12-01 11:16     ` Stefan Kangas
2019-12-01 18:12       ` Eli Zaretskii
2019-12-01 18:11     ` Eli Zaretskii
2020-01-25  1:37       ` Stefan Kangas
2020-01-31 13:54         ` Eli Zaretskii
2020-02-05 12:36           ` Stefan Kangas

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).