Add new filter commands to Package Menu (Bug#38424)

* lisp/emacs-lisp/package.el (package-menu-filter-by-version)
(package-menu-filter-by-status, package-menu-filter-by-archive):
New filter commands.
(package-menu--filter-by): New helper function.
(package-menu-filter-by-keyword, package-menu-filter-by-name): Use
the above helper function.
(package-menu-mode-menu):
(package-menu-mode-map): Update menu to include new filter commands.
* doc/emacs/package.texi (Package Menu): Document the new commands and
re-arrange the sort order of commands to be closer to the one in
describe-major-mode.
* etc/NEWS: Announce the new commands.

* lisp/emacs-lisp/package.el (package-menu--display): New function
extracted from....
(package-menu--generate): ...here.

* test/lisp/emacs-lisp/package-tests.el (with-package-menu-test):
New macro.
(package-test-update-listing, package-test-list-filter-by-name)
(package-test-list-filter-clear): 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-=)
(package-test-list-filter-by-version-<)
(package-test-list-filter-by-version->): New tests.
(package-test-filter-by-version): New helper function.

4 files changed, 319 insertions, 94 deletions

diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi
index 1cac7f9b4b6..360fc980e4a 100644
--- a/doc/emacs/package.texi
+++ b/doc/emacs/package.texi
@@ -151,27 +151,6 @@ Refresh the package list (@code{revert-buffer}).  This fetches the
 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
@@ -183,6 +162,48 @@ Permanently hide packages that match a regexp
 @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 093b54bdd46..6ab6a8aab3b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -120,6 +120,20 @@ like cell phones, tablets or cameras.
 *** Pcase 'map' pattern added keyword symbols abbreviation.
 A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym',
 equivalent to '(map (:sym sym))'.
+** Package
+
++++
+*** New functions to filter the package list.
+The filter command 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
 
 
 * New Modes and Packages in Emacs 28.1
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index a9508c1bdc5..f14ef7919ea 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2679,15 +2679,18 @@ either a full name or nil, and EMAIL is a valid email address."
     (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-clear-filter)
+    (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.")
 
@@ -2714,8 +2717,11 @@ either a full name or nil, and EMAIL is a valid email address."
 
     "--"
     ("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"]
+     ["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-clear-filter :help "Clear package list filter"])
 
     ["Hide by Regexp" package-menu-hide-package :help "Permanently hide all packages matching a regexp"]
@@ -3021,22 +3027,31 @@ When none are given, the package matches."
         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.
+
+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 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.
 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)
-  (setf (car (aref tabulated-list-format 0))
-        (if keywords
-            (let ((filters (mapconcat #'identity keywords ",")))
-              (concat "Package[" filters "]"))
-          "Package"))
-  (tabulated-list-init-header)
-  (tabulated-list-print remember-pos))
+  (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'.
@@ -3673,45 +3688,160 @@ shown."
         (select-window win)
       (switch-to-buffer buf))))
 
+(defun package-menu--filter-by (predicate suffix)
+  "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX 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 t nil)
+  (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 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")))))
+      (package-menu--generate t 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 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 ("
+                                  (pcase choice
+                                    ('= "= equal to")
+                                    ('< "< less than")
+                                    ('> "> greater than"))
+                                  "): "))
+                         choice))))
+  (unless (equal predicate 'quit)
+    (if (or (not version) (string-empty-p version))
+        (package-menu--generate t t)
+      (package-menu--filter-by
+       (let ((fun (pcase predicate
+                    ('= 'version-list-=)
+                    ('< 'version-list-<)
+                    ('> '(lambda (a b) (not (version-list-<= a b))))
+                    (_ (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-clear-filter ()
   "Clear any filter currently applied to the \"*Packages*\" buffer."
@@ -3760,6 +3890,7 @@ The return value is a string (or nil in case we can't find it)."
             (or (lm-header "package-version")
                 (lm-header "version")))))))))
 
+
 ;;;; 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 7d354d6ecde..adf917aef46 100644
--- a/test/lisp/emacs-lisp/package-tests.el
+++ b/test/lisp/emacs-lisp/package-tests.el
@@ -349,43 +349,102 @@ Must called from within a `tar-mode' buffer."
           (goto-char (point-min))
           (should (re-search-forward re nil t)))))))
 
+
+;;; 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)))
-      (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))))
+  (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 ()
+  (with-package-menu-test
+    (should-error (package-menu-filter-by-version "1.1" 'unknown-symbol)))  )
+
+(defun package-test-filter-by-version (version predicate name)
+  (with-package-menu-test
+    (package-menu-filter-by-version version predicate)
+    (goto-char (point-min))
+    ;; We just check that the given package is included in the
+    ;; listing.  One could be more ambitious.
+    (should (re-search-forward name))))
+
+(ert-deftest package-test-list-filter-by-version-= ()
+  "Ensure package list is filtered correctly by package version (=)."
+  (package-test-filter-by-version "1.1" '= "^\\s-+simple-two-depend"))
+
+(ert-deftest package-test-list-filter-by-version-< ()
+  "Ensure package list is filtered correctly by package version (<)."
+  (package-test-filter-by-version "1.2" '< "^\\s-+simple-two-depend"))
+
+(ert-deftest package-test-list-filter-by-version-> ()
+  "Ensure package list is filtered correctly by package version (>)."
+  (package-test-filter-by-version "1.0" '> "^\\s-+simple-two-depend"))
 
 (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))))
+  (with-package-menu-test
+    (let ((num-packages (count-lines (point-min) (point-max))))
+      (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)))))
 
 (ert-deftest package-test-update-archives ()
   "Test updating package archives."