[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/repology fa5dcd3 4/4: Fix compilation issues plus a few
|
From: |
Stefan Monnier |
|
Subject: |
[elpa] externals/repology fa5dcd3 4/4: Fix compilation issues plus a few more changes |
|
Date: |
Sat, 16 Jan 2021 16:01:14 -0500 (EST) |
branch: externals/repology
commit fa5dcd3f6f6e6592658d6517da427c7750cbcb0a
Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
Fix compilation issues plus a few more changes
* repology-license.el: Build list of gentoo free licenses dynamically.
(repology--license-identifiers-url:gentoo)
(repology--license-categories:gentoo): New vars.
(repology--license-identifiers:gentoo): Default to nil.
(repology--license-get-identifiers:gentoo): New function.
(repology--license-gentoo:peek): Remove unuse arg.
(repology--license-check:gentoo): Handle absence of license info.
(repology--license-check): Rename from `repology--license-free-p`.
* repology.el: Shuffle the code so it's better organized.
Add a few temporary messages to keep the user entertained.
(repology-request): Rename from `repology--request`.
(repology--check-freedom): New command.
(repology--main-prompt): New const.
(repology--select-key): New function.
(repology): Use them.
---
repology-license.el | 202 +++++-----
repology.el | 1054 ++++++++++++++++++++++++++-------------------------
2 files changed, 643 insertions(+), 613 deletions(-)
diff --git a/repology-license.el b/repology-license.el
index 5e76f63..d3bae5c 100644
--- a/repology-license.el
+++ b/repology-license.el
@@ -29,6 +29,15 @@
;; In order to see the results of each vote, and possibly debug the
;; process, you can set `repology-license-debug' to a non-nil value.
+;;; Code:
+
+(declare-function repology-request "repology" (url &optional extra-headers))
+(declare-function repology-package-field "repology" (package field))
+(declare-function repology-project-name "repology" (project))
+(declare-function repology-package-p "repology" (object))
+(declare-function repology-project-p "repology" (object))
+(declare-function repology-project-packages "repology" (project))
+
;;; Constants
(defconst repology-license-reference-repositories
@@ -53,10 +62,13 @@ This is a list of triplets (REPO SUBREPO PREDICATE) where:
SUBREPO is a regexp matching a sub-repository or nil;
PREDICATE is either a boolean or a function called with one string argument.
-When PREDICATE is a function, it must return a non-nil value if the argument
-is a free license according to the repository. If PREDICATE is t, we trust
-the repository to provide only free software. Conversely, PREDICATE is nil
-when the repository is known to reference only non-free software.
+When PREDICATE is a function, a return value of t means the argument is a free
+license according to the repository, whereas nil means it is non-free. Any
+other value means the repository cannot decide, and pass.
+
+If PREDICATE is t, we trust the repository to provide only free software.
+Conversely, PREDICATE is nil when the repository is known to reference only
+non-free software.
A repository with a PREDICATE function is expected to have the following
properties:
@@ -68,13 +80,22 @@ properties:
(defconst repology-license-poll-threshold 0.5
"Ratio of votes above which a package is declared to be free.")
+(defconst repology--license-identifiers-url:gentoo
+ "https://gitweb.gentoo.org/repo/gentoo.git/plain/profiles/license_groups";
+ "URL referencing Gentoo free license identifiers.")
+
+(defconst repology--license-categories:gentoo
+ '("GPL-COMPATIBLE" "FSF-APPROVED" "OSI-APPROVED" "MISC-FREE"
+ "FSF-APPROVED-OTHER" "MISC-FREE-DOCS")
+ "List of free license categories according to Gentoo.")
+
;;; Tools
(defun repology--license-interpret-vote (free votes)
"Return freedom vote result as a boolean.
FREE is the number of \"Free\" votes. VOTES is the total number of votes."
(and (> votes 0)
- (>= (/ (float free) votes) repology-license-poll-threshold)))
+ (> (/ (float free) votes) repology-license-poll-threshold)))
;;; Reference Repository: Fedora
@@ -83,82 +104,43 @@ FREE is the number of \"Free\" votes. VOTES is the total
number of votes."
See URL \
`https://docs.fedoraproject.org/en-US/packaging-guidelines/LicensingGuidelines/'"
(let ((case-fold-search t)
- ;; Anything in Fedora is free, unless its license contains the
- ;; following.
+ ;; Anything in Fedora is considered to be free, unless its
+ ;; license contains the following.
(non-free-license-re
(rx word-start "Redistributable, no modification permitted"
word-end)))
(not (string-match non-free-license-re license))))
;;; Reference Repository: Gentoo
-(defconst repology--license-identifiers:gentoo
- (list
- ;; GPL-COMPATIBLE
- "AGPL-3" "AGPL-3+" "Apache-2.0" "Apache-2.0-with-LLVM-exceptions"
- "Artistic-2" "Boost-1.0" "BSD" "BSD-2" "CC0-1.0" "CeCILL-2"
- "Clarified-Artistic" "Clear-BSD" "ECL-2.0" "FTL"
- "gcc-runtime-library-exception-3.1" "GPL-1" "GPL-1+" "GPL-2" "GPL-2+"
"GPL-3"
- "GPL-3+" "GPL-2-with-classpath-exception" "GPL-2-with-exceptions"
- "GPL-2-with-font-exception" "GPL-2-with-linking-exception"
- "GPL-2-with-MySQL-FLOSS-exception" "GPL-2+-with-openssl-exception"
- "GPL-3+-with-cuda-exception" "GPL-3+-with-cuda-openssl-exception"
- "GPL-3-with-font-exception" "GPL-3+-with-opencl-exception"
- "GPL-3+-with-opencl-openssl-exception" "GPL-3-with-openssl-exception"
- "Transmission-OpenSSL-exception" "UPX-exception" "HPND" "IJG" "ISC" "LGPL-2"
- "LGPL-2+" "LGPL-2.1" "LGPL-2.1+" "LGPL-3" "LGPL-3+"
- "LGPL-2-with-linking-exception" "LGPL-2.1-with-linking-exception"
- "LGPL-3-with-linking-exception" "Nokia-Qt-LGPL-Exception-1.1" "libgcc"
- "libstdc++" "metapackage" "MIT" "MPL-2.0" "OPENLDAP" "PSF-2" "PSF-2.2"
- "PSF-2.3" "PSF-2.4" "public-domain" "PYTHON" "qwt" "Ruby" "Ruby-BSD"
- "SGI-B-2.0" "Sleepycat" "tanuki-community" "unicode" "Unlicense" "UoI-NCSA"
- "vim" "W3C" "WTFPL-2" "wxWinLL-3.1" "ZLIB" "ZPL"
- ;; FSF-APPROVED
- "AFL-2.1" "AFL-3.0" "Apache-1.0" "Apache-1.1" "APSL-2" "BSD-4" "CDDL" "CNRI"
- "CPAL-1.0" "CPL-1.0" "EPL-1.0" "EPL-2.0" "EUPL-1.1" "gnuplot" "IBM"
- "LPPL-1.2" "MPL-1.0" "MPL-1.1" "Ms-PL" "NPL-1.1" "openssl" "OSL-1.1"
- "OSL-2.0" "OSL-2.1" "PHP-3.01" "QPL" "QPL-1.0" "Zend-2.0"
- ;; OSI-APPROVED
- "AFL-3.0" "AGPL-3" "AGPL-3" "Apache-1.1" "Apache-2.0" "APL-1.0" "APSL-2"
- "Artistic" "Artistic-2" "Boost-1.0" "BSD" "BSD-2" "CDDL" "CNRI" "CPAL-1.0"
- "CPL-1.0" "ECL-2.0" "EPL-1.0" "EPL-2.0" "EUPL-1.1" "GPL-1" "GPL-2" "GPL-2"
- "GPL-3" "GPL-3" "HPND" "IBM" "IPAfont" "ISC" "LGPL-2" "LGPL-2.1" "LGPL-2.1"
- "LGPL-3" "LGPL-3" "LPPL-1.3c" "MIT" "MPL-1.0" "MPL-1.1" "MPL-2.0" "Ms-PL"
- "nethack" "NOSA" "OFL-1.1" "OSL-2.1" "PHP-3" "PHP-3.01" "POSTGRESQL"
"PSF-2"
- "QPL" "Sleepycat" "UoI-NCSA" "W3C" "Watcom-1.0" "wxWinLL-3" "ZLIB" "ZPL"
- ;; MISC-FREE
- "Allegro" "alternate" "AMPAS" "bea.ri.jsr173" "BEER-WARE" "boehm-gc" "BSD-1"
- "BSD-with-attribution" "BSD-with-disclosure" "buddy" "bufexplorer.vim"
- "BZIP2" "canfep" "CAOSL" "CDDL-Schily" "CeCILL-C" "CLX" "CMake" "CPL-0.5"
- "CRACKLIB" "Crypt-IDEA" "DES" "docbook" "dom4j" "DUMB-0.9.3"
- "eGenixPublic-1.1" "ElementTree" "Emacs" "ErlPL-1.1" "FastCGI" "feh"
- "File-MMagic" "Flashpix" "FLEX" "flexmock" "FLTK" "freetts" "FVWM" "gd"
- "gsm" "HTML-Tidy" "htmlc" "iASL" "icu" "IDPL" "imagemagick" "Info-ZIP"
- "inner-net" "Interbase-1.0" "ipadic" "ipx-utils" "Ispell" "JasPer2.0" "JDOM"
- "JNIC" "JOVE" "Khronos-CLHPP" "LambdaMOO" "LIBGLOSS" "libmng" "libpng"
- "libpng2" "libtiff" "LLVM-Grant" "LPPL-1.3" "LPPL-1.3b" "lsof"
- "Mail-Sendmail" "mapm-4.9.5" "matplotlib" "Mini-XML" "minpack"
- "MIT-with-advertising" "mm" "mpich2" "NCSA-HDF" "netcat" "NEWLIB" "ngrep"
- "Old-MIT" "openafs-krb5-a" "Openwall" "otter" "PCRE" "perforce" "photopc"
- "PHP-2.02" "pngcrush" "pngnq" "Princeton" "psutils" "qmail-nelson" "rc"
- "rdisc" "regexp-UofT" "repoze" "RSA" "rwpng" "scanlogd" "Sendmail"
- "Sendmail-Open-Source" "shrimp" "SMAIL" "Snd" "SNIA" "SSLeay" "Subversion"
- "SVFL" "symlinks" "tablelist" "tcltk" "tcp_wrappers_license" "TeX"
- "TeX-other-free" "the-Click-license" "Time-Format" "Time-modules" "tm-align"
- "torque-2.5" "totd" "Toyoda" "UCAR-Unidata" "URT" "VTK" "w3m" "x2x" "xbatt"
- "xboing" "XC" "Xdebug" "xtrs" "xvt" "YaTeX" "yuuji" "ZSH"
- ;; FSF-APPROVED-OTHER.
- "Arphic" "CC-BY-2.0" "CC-BY-2.5" "CC-BY-3.0" "CC-BY-4.0" "CC-BY-SA-2.0"
- "CC-BY-SA-2.5" "CC-BY-SA-3.0" "CC-BY-SA-4.0" "FDL-1.1" "FDL-1.1+" "FDL-1.2"
- "FDL-1.2+" "FDL-1.3" "FDL-1.3+" "FreeArt" "GPL-1" "GPL-1+" "GPL-2" "GPL-2+"
- "GPL-3" "GPL-3+" "IPAfont" "OFL" "OFL-1.1" "OPL"
- ;; MISC-FREE-DOCS.
- "BitstreamVera" "CC-PD" "CC-BY-SA-1.0" "CC-SA-1.0" "LDP-1" "LDP-1a"
- "man-pages" "man-pages-posix" "man-pages-posix-2013" "MaxMind2"
"mplus-fonts"
- "myspell-en_CA-KevinAtkinson" "quake1-textures" "Texinfo-manual"
- "UbuntuFontLicense-1.0" "Unicode_Fonts_for_Ancient_Scripts" "vlgothic"
- "wxWinFDL-3")
- "List of identifiers considered as free licenses by Gentoo
-See URL `https://wiki.gentoo.org/wiki/License_groups'.")
+(defvar repology--license-identifiers:gentoo nil
+ "List of identifiers considered as free licenses by Gentoo.
+See URL `https://wiki.gentoo.org/wiki/License_groups'.
+This list is populated with `repology--license-get-identifiers:gentoo'.")
+
+(defun repology--license-get-identifiers:gentoo ()
+ "Return list of free license identifiers according to Gentoo."
+ (unless repology--license-identifiers:gentoo
+ (with-temp-message "Repology: Fetching license identifiers for Gentoo..."
+ (let ((request
+ (repology-request repology--license-identifiers-url:gentoo)))
+ (pcase (plist-get request :reason)
+ ("OK"
+ (let ((identifiers nil))
+ (with-temp-buffer
+ (insert (plist-get request :body))
+ (dolist (category repology--license-categories:gentoo)
+ (goto-char 1)
+ (when (re-search-forward (concat "^" category " +"))
+ (let ((line (buffer-substring (point) (line-end-position))))
+ (setq identifiers
+ (nconc (split-string line) identifiers)))))
+ (dolist (category repology--license-categories:gentoo)
+ (setq identifiers (delete (concat "@" category)
identifiers))))
+ (setq repology--license-identifiers:gentoo identifiers)))
+ (_
+ (message
+ "Repology: Cannot fetch Gentoo licenses. \
+Ignoring repository")))))))
(defun repology--license-gentoo:skip-whitespace ()
"Skip past the whitespace at point."
@@ -172,8 +154,8 @@ See URL `https://wiki.gentoo.org/wiki/License_groups'.")
"Advance N characters forward."
(forward-char n))
-(defun repology--license-gentoo:peek (&optional n)
- "Advance N characters forward."
+(defun repology--license-gentoo:peek ()
+ "Return the character at point."
(following-char))
(defun repology--license-gentoo:and ()
@@ -234,15 +216,17 @@ See URL `https://wiki.gentoo.org/wiki/License_groups'.")
(defun repology--license-check:gentoo (license)
"Return a non-nil value if LICENSE is free, according to Gentoo."
- (with-temp-buffer
- (insert license)
- (goto-char 1)
- (repology--license-gentoo:skip-whitespace)
- (let ((value (not (eobp)))) ;blank string check
- (while (and value (/= (repology--license-gentoo:peek) 0))
- (unless (repology--license-gentoo:read-next)
- (setq value nil)))
- value)))
+ (if (null (repology--license-get-identifiers:gentoo))
+ 'pass ;no license to check
+ (with-temp-buffer
+ (insert license)
+ (goto-char 1)
+ (repology--license-gentoo:skip-whitespace)
+ (let ((value (not (eobp)))) ;blank string check
+ (while (and value (/= (repology--license-gentoo:peek) 0))
+ (unless (repology--license-gentoo:read-next)
+ (setq value nil)))
+ value))))
;;; Reference Repository: OpenSUSE (OSS)
@@ -250,8 +234,8 @@ See URL `https://wiki.gentoo.org/wiki/License_groups'.")
"Return a non-nil value if LICENSE is free, according to OpenSUSE (OSS).
See URL `https://en.opensuse.org/openSUSE:Packaging_guidelines#Licensing'."
(let ((case-fold-search t)
- ;; Anything in Fedora is free, unless its license contains the
- ;; following.
+ ;; Anything in OSS sub-repository from OpenSUSE is considered
+ ;; to be free, unless its license contains the following.
(non-free-license-re
(rx word-start "SUSE-Firmware" word-end)))
(not (string-match non-free-license-re license))))
@@ -295,7 +279,7 @@ from reference repositories in PROJECT."
;;; Main Function
(defun repology--license-find-reference-repository (package)
"Return the reference repository containing PACKAGE, or nil.
-Return value is a triplet per `repology-license-reference-repositories'."
+Return value is a triplet from `repology-license-reference-repositories'."
(let ((repo (repology-package-field package 'repo))
(subrepo (repology-package-field package 'subrepo)))
(seq-find (pcase-lambda (`(,r ,s ,_))
@@ -304,33 +288,38 @@ Return value is a triplet per
`repology-license-reference-repositories'."
(and subrepo (string-match s subrepo)))))
repology-license-reference-repositories)))
-(defun repology--license-free-p (package &optional repository)
- "Return a non-nil value when PACKAGE is free.
-A package is free when any reference repository can attest it uses only free
-licenses. When optional argument REPOSITORY is non-nil, use it as a
reference."
+(defun repology--license-check (package repository)
+ "Check if PACKAGE is free according to REPOSITORY.
+REPOSITORY is an element from `repology-license-reference-repositories'.
+PACKAGE is free when REPOSITORY can attest it uses only free licenses."
(pcase (or repository (repology--license-find-reference-repository package))
- ('nil nil)
(`(,_ ,_ ,(and (pred functionp) p))
(seq-every-p p (repology-package-field package 'licenses)))
(`(,_ ,_ ,boolean) boolean)
(other (error "Wrong repository definition: %S" other))))
(defun repology-free-p (datum)
- "Return a non-nil value when DATUM is free.
-
-DATUM is a project or a package.
+ "Return t when project or package DATUM is free.
A package is free when any reference repository can attest it uses only free
licenses. See `repology-license-reference-repositories' for a list of such
-repositories.
+repositories. If the package does not belong to any of these repositories,
+or if there is not enough information to decide, return `unknown'. Otherwise,
+return nil.
A project is free if the ratio of free packages among the packages from
reference repositories is above `repology-license-poll-threshold'.
-A project without any package from these repositories is declared as non-free.
+In any other case, return nil. In particular, a project without any package
+from reference repositories is declared non-free.
-Of course, it is not a legal statement, merely an indicator."
+Of course, it is not a legal statement, merely an indication."
(pcase datum
- ((pred repology-package-p) (repology--license-free-p datum))
+ ((pred repology-package-p)
+ (pcase (repology--license-find-reference-repository datum)
+ ('nil 'unknown)
+ (repository
+ (let ((decision (repology--license-check datum repository)))
+ (if (booleanp decision) decision 'unknown)))))
((pred repology-project-p)
(let ((votes 0)
(yes 0)
@@ -343,11 +332,12 @@ Of course, it is not a legal statement, merely an
indicator."
(unless (member repository voters)
(cl-incf votes)
(push repository voters) ;a repository votes only once
- (let ((free (repology--license-free-p package repository)))
- (when free (cl-incf yes))
- (when repology-license-debug
- (push (repology--license-debug-line package free)
- reports)))))))
+ (let ((free (repology--license-check package repository)))
+ (when (booleanp free) ;has repository an opinion?
+ (when free (cl-incf yes))
+ (when repology-license-debug
+ (push (repology--license-debug-line package free)
+ reports))))))))
;; Maybe display vote reports as debugging information.
(when repology-license-debug
(repology--license-debug-display datum reports yes votes))
diff --git a/repology.el b/repology.el
index 1df64e4..30e0930 100644
--- a/repology.el
+++ b/repology.el
@@ -34,9 +34,10 @@
;; Projects-related requests are limited to `repology-projects-limit'.
;; All requests are cached during `repology-cache-duration' seconds.
;;
-;; By default, projects including packages with a known non-free license
-;; are not included in the search results. You can control this behavior
-;; with the variable `repology-free-only-projects'.
+;; By default, only projects recognized as free are included in the search
+;; results. You can control this behavior with the variable
+;; `repology-free-only-projects'. The function `repology-free-p' is
responsible
+;; for guessing if a project, or a package, is free or not.
;; You can then access data from those various objects using dedicated
;; accessors. See, for example, `repology-project-name',
@@ -51,7 +52,7 @@
;; `repology-display-packages-columns',`repology-display-projects-columns',
;; and `repology-display-problems-columns'). When projects or packages
;; are displayed, pressing <RET> gives you more information about the item
-;; at point.
+;; at point, whereas pressing <F> reports their "freedom" status.
;; For example, the following expression displays all outdated projects
;; named after "emacs" and containing a package in GNU Guix repository
@@ -105,12 +106,12 @@ objects of the column."
(funcall ,predicate s1 s2)))))
-;;; Constants
+;;; Upstream Constants
(defconst repology-base-url "https://repology.org/api/v1/";
"Base URL for Repology API.")
(defconst repology-statistics-url
"https://repology.org/repositories/statistics";
- "Base URL for \"Statistics\" page in Repology website.
+ "URL for \"Statistics\" page in Repology website.
It is used as a source for all known repositories.")
(defconst repology-package-all-fields
@@ -127,37 +128,6 @@ It is used as a source for all known repositories.")
"Maximum number of projects Repology API can return.
See URL `https://repology.org/api'.")
-(defconst repology-project-filters-parameters
- `((:search "Name search (e.g. emacs): " nil)
- (:maintainer "Maintainer (e.g. foo@bar.com): " nil)
- (:category "Category (e.g. games): " nil)
- (:inrepo "In repository: " repology--query-repository)
- (:notinrepo "Not in repository: " repology--query-repository)
- (:repos "Repositories (e.g. 1 or 2- or 3-5): " nil)
- (:families "Families (e.g. 1 or 2- or 3-5): " nil)
- (:repos_newest "Repositories newest (e.g. 1 or 2- or 3-5): " nil)
- (:families_newest "Families newest (e.g. 1 or 2- or 3-5): " nil)
- (:newest "Newest? " repology--query-y-or-n-p)
- (:outdated "Outdated? " repology--query-y-or-n-p)
- (:problematic "Problematic? " repology--query-y-or-n-p)
- (:vulnerable "Potentially vulnerable? " repology--query-y-or-n-p)
- (:has_related "Has related? " repology--query-y-or-n-p))
- "Association list between project filters and query data.
-Each entry is a triplet (FILTER PROMPT QUERY) where FILTER is a keyword, PROMPT
-is a string, and QUERY is a function used to prompt the user, or nil.
-When setting the value of FILTER interactively, QUERY is called with
-two arguments, PROMPT and an initial value. It must return a string. If QUERY
-is nil, `read-string' is used.")
-
-(defconst repology-version-zero-component '(1 . 0)
- "Version component representing 0 or any missing component.")
-
-(defconst repology-version-pre-keywords '("alpha" "beta" "rc" "pre")
- "List of pre-release keywords in version strings.")
-
-(defconst repology-version-post-keywords '("patch" "post" "pl" "errata")
- "List of post-release keywords in version strings.")
-
;;; Configuration
(defgroup repology nil
@@ -297,401 +267,51 @@ predicates like `repology-compare-texts',
`repology-compare-numbers', or
`repology-compare-versions' in order to build SORT values."
:type '(choice
(repeat
- (list :tag "Column definition"
- (string :tag "Column name")
- function
- (integer :tag "Width")
- (choice (const :tag "Do not sort" nil)
- (const :tag "Sort" t)
- (function :tag "Custom sort predicate"))))
- (function :tag "Function describing columns")))
-
-
-;;; Internal variables
-(defconst repology--project-filters
- (mapcar #'car repology-project-filters-parameters)
- "List of known filters for projects.
-Other keywords are ignored when building the query string.")
-
-(defvar repology--cache (make-hash-table :test #'equal)
- "Hash table used to cache request to Repology API.
-Keys are triplets of arguments for `repology--get'. Values are
-cons cells like (TIME . REQUEST-RESULT).")
-
-(defvar repology--repositories nil
- "List of repositories known to Repology.
-The list is populated by `repology-list-repositories'. Call that function
-instead of using this variable.")
-
-
-;;; Internal functions
-(defun repology--cache-key (action value start)
- "Return a cache key for current query.
-See `repology--get' for precision about ACTION, VALUE, and START."
- (list action
- (if (not (eq action 'projects)) value
- ;; VALUE is a p-list. Sort it in a fixed order so p-lists
- ;; sorted differently are cached the same way. Also ignore
- ;; unknown filters.
- (let ((normalized nil))
- (dolist (prop repology--project-filters)
- (when (plist-member value prop)
- (setq normalized
- (plist-put normalized prop (plist-get value prop)))))
- normalized))
- start))
-
-(defun repology--cache-get (key)
- "Return cached value associated to KEY, or nil.
-If the cached value is too old according to `repology-cache-duration',
-reset the cache and return nil."
- (pcase (gethash key repology--cache)
- (`(,time . ,value)
- ;; Check if cached value is still valid.
- (if (> repology-cache-duration (time-to-seconds (time-since time)))
- value
- ;; Time is over: reset cache and return nil.
- (remhash key repology--cache)))
- (_ nil)))
-
-(defun repology--cache-put (key value)
- "Cache KEY with VALUE."
- (puthash key (cons (current-time) value) repology--cache))
-
-(defun repology--parse-json (json-string)
- "Parse a JSON string and returns an object.
-JSON objects become alists and JSON arrays become lists."
- (if (null json-string)
- nil
- (let ((json-object-type 'alist)
- (json-array-type 'list))
- (condition-case err
- (json-read-from-string json-string)
- (json-readtable-error
- (message "%s: Could not parse string into an object. See %S"
- (error-message-string err)
- json-string))))))
-
-(defun repology--build-query-string (filters)
- "Build a filter string from a given FILTERS plist."
- (let ((query nil))
- (dolist (keyword repology--project-filters)
- (let ((value (plist-get filters keyword)))
- (when value
- (let ((key (substring (symbol-name keyword) 1)))
- (push (format "%s=%s"
- (url-hexify-string key)
- (url-hexify-string value))
- query)))))
- (if (null query) ""
- (concat "?" (mapconcat #'identity query "&")))))
-
-(defun repology--build-url (action value start)
- "Build a URL from an ACTION symbol.
-Value is a plist if ACTION is `projects', or a string otherwise."
- (concat repology-base-url
- (symbol-name action)
- "/"
- (pcase action
- ('project value)
- ('repository (concat value "/problems"))
- ('projects
- (concat (and start (concat start "/"))
- (repology--build-query-string value)))
- (_ (error "Unknown action: %S" action)))))
-
-(defun repology--request (url &optional extra-headers)
- "Perform a raw HTTP request on URL.
-EXTRA-HEADERS is an assoc list of headers/contents to send with
-the request."
- (let* ((url-request-method "GET")
- (url-request-extra-headers extra-headers)
- (process-buffer (url-retrieve-synchronously url)))
- (unwind-protect
- (with-current-buffer process-buffer
- (goto-char (point-min))
- (let* ((status-line-regexp
- (rx bol
- (one-or-more (not (any " "))) " "
- (group (in "1-5") (= 2 digit)) " "
- (group (one-or-more (in "A-Z" "a-z" " ")))
- eol))
- (status
- (and (looking-at status-line-regexp)
- (list :code (string-to-number (match-string 1))
- :reason (match-string 2))))
- (header nil)
- (body nil))
- (forward-line)
- (while (looking-at "^\\([^:]+\\): \\(.*\\)")
- (push (match-string 1) header)
- (push (match-string 2) header)
- (forward-line))
- (forward-line)
- (unless (eobp)
- (setq body (buffer-substring (point) (point-max))))
- (append status (list :header (nreverse header) :body body))))
- (kill-buffer process-buffer))))
-
-(defun repology--get (action value start)
- "Perform an HTTP GET request to Repology.
-
-ACTION is a symbol. If it is `projects', VALUE is a plist and START a string.
-Otherwise, VALUE is a string, and START is nil.
-
-Information is returned as parsed JSON."
- (let ((key (repology--cache-key action value start)))
- (or (repology--cache-get key)
- (let ((request (repology--request
- (repology--build-url action value start)
- '(("Content-Type" . "application/json")))))
- (pcase (plist-get request :reason)
- ("OK"
- (let ((body (repology--parse-json (plist-get request :body))))
- (repology--cache-put key body)
- ;; Information from `projects' is a list of projects,
- ;; so, we can also cache each of them for a future
- ;; project lookup.
- (when (eq action 'projects)
- (dolist (project body)
- (let ((key (repology--cache-key
- 'project (repology-project-name project) nil))
- (packages (repology-project-packages project)))
- (repology--cache-put key packages))))
- ;; Return information.
- body))
- (status
- (error "Cannot retrieve information: %S" status)))))))
-
-(defun repology--value-to-string (value)
- "Change VALUE object into a string suitable for display."
- (pcase value
- (`nil "-")
- ((pred listp)
- (mapconcat (lambda (e) (format "%s" e))
- (seq-uniq value)
- " "))
- (_
- (format "%s" value))))
-
-(defun repology--package-status-face (package)
- "Return face associated to status from PACKAGE."
- (let ((status (repology-package-field package 'status)))
- (alist-get status repology-status-faces 'default nil #'equal)))
-
-(defun repology--make-display (data buffer-name mode format-descriptors)
- "Display DATA in a buffer named after BUFFER-NAME string.
-DATA is displayed in a major mode derived from `tabulated-list-mode', and set
-by function MODE. Each entry is identified by the element from DATA, and
-formatted according to FORMAT-DESCRIPTORS function. This function is called
-with one argument: an element from DATA."
- (let ((buffer (get-buffer-create buffer-name)))
- (with-current-buffer buffer
- (funcall mode)
- (setq tabulated-list-entries
- (mapcar (lambda (datum)
- (list datum
- (apply #'vector
- (funcall format-descriptors datum))))
- data))
- (tabulated-list-print))
- (pop-to-buffer buffer)))
-
-(defun repology--show-current-package ()
- "Display packages associated to project at point."
- (interactive)
- (repology-display-package (tabulated-list-get-id)))
-
-(defun repology--show-current-project ()
- "Display packages associated to project at point."
- (interactive)
- (repology-display-packages
- (repology-project-packages (tabulated-list-get-id))))
-
-(defvar repology--display-projects-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map (kbd "RET") 'repology--show-current-project)
- map)
- "Local keymap for `repology--display-projects-mode' buffers.")
-
-(defvar repology--display-packages-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map tabulated-list-mode-map)
- (define-key map (kbd "RET") 'repology--show-current-package)
- map)
- "Local keymap for `repology--display-packages-mode' buffers.")
-
-(defun repology--columns-to-header (specs)
- "Return vector of column names according to SPECS.
-SPECS is an association list. Each entry has the form (NAME _ WIDTH SORT)
-where NAME, WIDTH and SORT are of the expected type in
`tabulated-list-format'."
- (apply #'vector
- (mapcar (lambda (format)
- (pcase format
- (`(,name ,_ ,width ,sort) (list name width sort))
- (other
- (user-error "Invalid package column format: %S" other))))
- specs)))
-
-(define-derived-mode repology--display-package-mode tabulated-list-mode
- "Repology/Package"
- "Major mode used to display packages returned by Repology API.
-\\{tabulated-list-mode-map}"
- (setq tabulated-list-format [("Field" 15 t) ("Value" 0 t)])
- (tabulated-list-init-header))
-
-(define-derived-mode repology--display-packages-mode tabulated-list-mode
- "Repology/Packages"
- "Major mode used to display packages returned by Repology API.
-\\{repology--display-packages-mode-map}"
- (setq tabulated-list-format
- (repology--columns-to-header repology-display-packages-columns))
- (tabulated-list-init-header))
-
-(define-derived-mode repology--display-projects-mode tabulated-list-mode
- "Repology/Project"
- "Major mode used to display projects returned by Repology API.
-\\{repology--display-projects-mode-map}"
- (setq tabulated-list-format
- (repology--columns-to-header repology-display-projects-columns))
- (tabulated-list-init-header))
-
-(define-derived-mode repology--display-problems-mode tabulated-list-mode
- "Repology/Problems"
- "Major mode used to display problems returned by Repology API.
-\\{tabulated-list-mode-map}"
- (setq tabulated-list-format
- (repology--columns-to-header repology-display-problems-columns))
- (tabulated-list-init-header))
-
-(defun repology--column-to-descriptor (datum specs &optional symbol-handler)
- "Return list of descriptors for DATUM according to SPECS.
-
-DATUM is a package, a problem, or a project. SPECS is an association
-list. Each entry has the form (_ VALUE _ _).
-
-VALUE is a function called with DATUM as its sole argument. When VALUE is
-a symbol, and optional argument SYMBOL-HANDLER is a function, SYMBOL-HANDLER
-is called with two arguments: DATUM and VALUE. In any case, the return value
-is then turned into a string and displayed."
- (mapcar (lambda (spec)
- (pcase spec
- ;; Contents as a function.
- (`(,_ ,(and (pred functionp) f) ,_ ,_)
- (repology--value-to-string (funcall f datum)))
- ;; Contents as a symbol.
- ((and (guard symbol-handler)
- `(,_ ,(and (pred symbolp) field) ,_ ,_))
- (repology--value-to-string (funcall symbol-handler datum
field)))
- ;; Invalid contents.
- (other (user-error "Invalid format type: %S" other))))
- specs))
-
-(defun repology--format-field-descriptors (field)
- "Format an entry from FIELD.
-Format follows `repology-display-packages-columns' specifications.
-Return a list of descriptors."
- (pcase field
- (`(,name . ,value)
- (list (symbol-name name)
- (repology--value-to-string value) ))
- (_
- (error "Invalid field: %S" field))))
-
-(defun repology--format-package-descriptors (package)
- "Format an entry from PACKAGE.
-Format follows `repology-display-packages-columns' specifications.
-Return a list of descriptors."
- (repology--column-to-descriptor package
- repology-display-packages-columns
- #'repology-package-field))
-
-(defun repology--format-project-descriptors (project)
- "Format an entry for PROJECT.
-Format follows `repology-display-packages-columns' specifications.
-Return a list of descriptors."
- (repology--column-to-descriptor project repology-display-projects-columns))
-
-
-(defun repology--format-problem-descriptors (problem)
- "Format an entry from PROBLEM.
-Format follows `repology-display-problems-columns' specifications.
-Return a list of descriptors."
- (repology--column-to-descriptor problem
- repology-display-problems-columns
- #'repology-problem-field))
-
-(defun repology--query-y-or-n-p (prompt _)
- "Ask user a \"y or n\" question, displaying PROMPT.
-Return \"on\" or \"off\"."
- (if (y-or-n-p prompt) "on" "off"))
-
-(defun repology--query-repository (prompt initial)
- "Ask user an existing repository by its full name, displaying PROMPT.
-INITIAL is the initial input. Return a repository internal name."
- (repology-repository-name
- (completing-read prompt (repology-list-repositories t) nil t initial)))
-
-(defun repology--query-filter-value (filter initial)
- "Ask user for FILTER value.
-FILTER is a project filter, as a keyword. INITIAL is a string inserted as
-a first suggestion, or nil. Return the answer as a string."
- (pcase (assq filter repology-project-filters-parameters)
- (`nil
- (error "Unknown filter: %S" filter))
- (`(,_ ,prompt nil)
- (read-string prompt initial))
- (`(,_ ,prompt ,(and (pred functionp) collection))
- (funcall collection prompt initial))
- (other
- (error "Invalid value: %S" other))))
+ (list :tag "Column definition"
+ (string :tag "Column name")
+ function
+ (integer :tag "Width")
+ (choice (const :tag "Do not sort" nil)
+ (const :tag "Sort" t)
+ (function :tag "Custom sort predicate"))))
+ (function :tag "Function describing columns")))
-(defun repology--string-to-version (s)
- "Return version associated to string S.
-Version is a list of components (RANK . VALUE) suitable for comparison, with
-the function `repology-compare-versions'."
- (let ((split nil))
- ;; Explode string into numeric and alphabetic components.
- ;; Intermediate SPLIT result is in reverse order.
- (let ((regexp (rx (or (group (one-or-more digit)) (one-or-more alpha))))
- (start 0))
- (while (string-match regexp s start)
- (let ((component (match-string 0 s)))
- (push (if (match-beginning 1) ;numeric component?
- (string-to-number component)
- ;; Version comparison ignores case.
- (downcase component))
- split))
- (setq start (match-end 0))))
- ;; Attach ranks to components. NUMERIC-FLAG is used to catch
- ;; trailing alphabetic components, which get a special rank.
- ;; However, if there is no numeric component, no alphabetic
- ;; component ever gets this rank, hence the initial value.
- (let ((numeric-flag (seq-every-p #'stringp split))
- (result nil))
- (dolist (component split)
- (let ((rank
- (cond
- ;; 0 gets "zero" (1) rank.
- ((equal 0 component) 1)
- ;; Other numeric components get "nonzero" (3) rank.
- ((wholenump component) 3)
- ;; Pre-release keywords get "pre_release" (0) rank.
- ((member component repology-version-pre-keywords) 0)
- ;; Post-release keywords get "post_release" (2) rank.
- ((member component repology-version-post-keywords) 2)
- ;; Alphabetic components after the last numeric
- ;; component get the "letter_suffix" (4) rank.
- ((not numeric-flag) 4)
- ;; Any other alphabetic component is "pre_release".
- (t 0))))
- (when (wholenump component) (setq numeric-flag t))
- (push (cons rank component) result)))
- result)))
+
+;;; Global Internal Variables
+(defconst repology-project-filters-parameters
+ `((:search "Name search (e.g. emacs): " nil)
+ (:maintainer "Maintainer (e.g. foo@bar.com): " nil)
+ (:category "Category (e.g. games): " nil)
+ (:inrepo "In repository: " repology--query-repository)
+ (:notinrepo "Not in repository: " repology--query-repository)
+ (:repos "Repositories (e.g. 1 or 2- or 3-5): " nil)
+ (:families "Families (e.g. 1 or 2- or 3-5): " nil)
+ (:repos_newest "Repositories newest (e.g. 1 or 2- or 3-5): " nil)
+ (:families_newest "Families newest (e.g. 1 or 2- or 3-5): " nil)
+ (:newest "Newest? " repology--query-y-or-n-p)
+ (:outdated "Outdated? " repology--query-y-or-n-p)
+ (:problematic "Problematic? " repology--query-y-or-n-p)
+ (:vulnerable "Potentially vulnerable? " repology--query-y-or-n-p)
+ (:has_related "Has related? " repology--query-y-or-n-p))
+ "Association list between project filters and query data.
+Each entry is a triplet (FILTER PROMPT QUERY) where FILTER is a keyword, PROMPT
+is a string, and QUERY is a function used to prompt the user, or nil.
+When setting the value of FILTER interactively, QUERY is called with
+two arguments, PROMPT and an initial value. It must return a string. If QUERY
+is nil, `read-string' is used.")
+
+(defconst repology--project-filters
+ (mapcar #'car repology-project-filters-parameters)
+ "List of known filters for projects.
+Other keywords are ignored when building the query string.")
;;; Utilities
+(defvar repology--repositories nil
+ "List of repositories known to Repology.
+The list is populated by `repology-list-repositories'. Call that function
+instead of using this variable.")
+
(defun repology-package-p (object)
"Return t if OBJECT is a package."
(and (consp object)
@@ -854,28 +474,29 @@ following ones:
Return a list of strings. When option argument FULL-NAME is non-nil, list
the repositories with their full name instead of their internal name."
(unless repology--repositories
- (let ((request (repology--request repology-statistics-url)))
- (pcase (plist-get request :reason)
- ("OK"
- (let ((body (plist-get request :body))
- (repositories nil)
- (start 0))
- (while (string-match "id=\"\\(.+?\\)\"" body start)
- (setq start (match-end 0))
- (let* ((repo (match-string 1 body))
- (regexp
- (rx "href=\"/repository/"
- (+? anychar)
- "\">"
- (group (+? anychar))
- "<"))
- (true-name
- (and (string-match regexp body start)
- (match-string 1 body))))
- (push (cons repo true-name) repositories)))
- (setq repology--repositories (nreverse repositories))))
- (status
- (error "Cannot retrieve information: %S" status)))))
+ (with-temp-message "Repology: Fetching list of repositories..."
+ (let ((request (repology-request repology-statistics-url)))
+ (pcase (plist-get request :reason)
+ ("OK"
+ (let ((body (plist-get request :body))
+ (repositories nil)
+ (start 0))
+ (while (string-match "id=\"\\(.+?\\)\"" body start)
+ (setq start (match-end 0))
+ (let* ((repo (match-string 1 body))
+ (regexp
+ (rx "href=\"/repository/"
+ (+? anychar)
+ "\">"
+ (group (+? anychar))
+ "<"))
+ (true-name
+ (and (string-match regexp body start)
+ (match-string 1 body))))
+ (push (cons repo true-name) repositories)))
+ (setq repology--repositories (nreverse repositories))))
+ (status
+ (error "Cannot retrieve information: %S" status))))))
(mapcar (if full-name #'cdr #'car) repology--repositories))
(defun repology-refresh-repositories ()
@@ -910,40 +531,240 @@ Return t if S1 is less than S2. Case is ignored."
Return t if S1 is less than S2."
(< (string-to-number s1) (string-to-number s2)))
-(defun repology-compare-versions (s1 s2)
- "Compare package versions associated to strings S1 and S2.
+
+;;; Version Comparison
+(defconst repology-version-zero-component '(1 . 0)
+ "Version component representing 0 or any missing component.")
+
+(defconst repology-version-pre-keywords '("alpha" "beta" "rc" "pre")
+ "List of pre-release keywords in version strings.")
+
+(defconst repology-version-post-keywords '("patch" "post" "pl" "errata")
+ "List of post-release keywords in version strings.")
+
+(defun repology--string-to-version (s)
+ "Return version associated to string S.
+Version is a list of components (RANK . VALUE) suitable for comparison, with
+the function `repology-compare-versions'."
+ (let ((split nil))
+ ;; Explode string into numeric and alphabetic components.
+ ;; Intermediate SPLIT result is in reverse order.
+ (let ((regexp (rx (or (group (one-or-more digit)) (one-or-more alpha))))
+ (start 0))
+ (while (string-match regexp s start)
+ (let ((component (match-string 0 s)))
+ (push (if (match-beginning 1) ;numeric component?
+ (string-to-number component)
+ ;; Version comparison ignores case.
+ (downcase component))
+ split))
+ (setq start (match-end 0))))
+ ;; Attach ranks to components. NUMERIC-FLAG is used to catch
+ ;; trailing alphabetic components, which get a special rank.
+ ;; However, if there is no numeric component, no alphabetic
+ ;; component ever gets this rank, hence the initial value.
+ (let ((numeric-flag (seq-every-p #'stringp split))
+ (result nil))
+ (dolist (component split)
+ (let ((rank
+ (cond
+ ;; 0 gets "zero" (1) rank.
+ ((equal 0 component) 1)
+ ;; Other numeric components get "nonzero" (3) rank.
+ ((wholenump component) 3)
+ ;; Pre-release keywords get "pre_release" (0) rank.
+ ((member component repology-version-pre-keywords) 0)
+ ;; Post-release keywords get "post_release" (2) rank.
+ ((member component repology-version-post-keywords) 2)
+ ;; Alphabetic components after the last numeric
+ ;; component get the "letter_suffix" (4) rank.
+ ((not numeric-flag) 4)
+ ;; Any other alphabetic component is "pre_release".
+ (t 0))))
+ (when (wholenump component) (setq numeric-flag t))
+ (push (cons rank component) result)))
+ result)))
+
+(defun repology-compare-versions (s1 s2)
+ "Compare package versions associated to strings S1 and S2.
+
+Return t if version S1 is lower than version S2.
+
+See URL `https://github.com/repology/libversion/blob/master/doc/ALGORITHM.md'."
+ (let ((v1 (repology--string-to-version s1))
+ (v2 (repology--string-to-version s2)))
+ (catch :less?
+ (while (or v1 v2)
+ (pcase-let ((`(,r1 . ,v1)
+ (or (pop v1) repology-version-zero-component))
+ (`(,r2 . ,v2)
+ (or (pop v2) repology-version-zero-component)))
+ (cond
+ ;; First compare ranks, then values.
+ ((/= r1 r2) (throw :less? (< r1 r2)))
+ ;; Components are equal. Try next component.
+ ((equal v1 v2) nil)
+ ;; Numeric components are compared... numerically.
+ ((= r1 3) (throw :less? (< v1 v2)))
+ ;; Alphabetic components are compared by case insensitively
+ ;; comparing their first letters.
+ (t (throw :less?
+ (string-lessp (substring v1 0 1) (substring v2 0 1)))))))
+ ;; Strings S1 and S2 represent equal versions.
+ nil)))
+
+
+;;; Search functions
+(defvar repology--cache (make-hash-table :test #'equal)
+ "Hash table used to cache requests to Repology API.
+Keys are triplets of arguments for `repology--get'. Values are
+cons cells like (TIME . REQUEST-RESULT).")
+
+(defun repology--cache-key (action value start)
+ "Return a cache key for current query.
+See `repology--get' for precision about ACTION, VALUE, and START."
+ (list action
+ (if (not (eq action 'projects)) value
+ ;; VALUE is a p-list. Sort it in a fixed order so p-lists
+ ;; sorted differently are cached the same way. Also ignore
+ ;; unknown filters.
+ (let ((normalized nil))
+ (dolist (prop repology--project-filters)
+ (when (plist-member value prop)
+ (setq normalized
+ (plist-put normalized prop (plist-get value prop)))))
+ normalized))
+ start))
+
+(defun repology--cache-get (key)
+ "Return cached value associated to KEY, or nil.
+If the cached value is too old according to `repology-cache-duration',
+reset the cache and return nil."
+ (pcase (gethash key repology--cache)
+ (`(,time . ,value)
+ ;; Check if cached value is still valid.
+ (if (> repology-cache-duration (time-to-seconds (time-since time)))
+ value
+ ;; Time is over: reset cache and return nil.
+ (remhash key repology--cache)))
+ (_ nil)))
+
+(defun repology--cache-put (key value)
+ "Cache KEY with VALUE."
+ (puthash key (cons (current-time) value) repology--cache))
+
+(defun repology--parse-json (json-string)
+ "Parse a JSON string and returns an object.
+JSON objects become alists and JSON arrays become lists."
+ (if (null json-string)
+ nil
+ (let ((json-object-type 'alist)
+ (json-array-type 'list))
+ (condition-case err
+ (json-read-from-string json-string)
+ (json-readtable-error
+ (message "%s: Could not parse string into an object. See %S"
+ (error-message-string err)
+ json-string))))))
+
+(defun repology--build-query-string (filters)
+ "Build a filter string from a given FILTERS plist."
+ (let ((query nil))
+ (dolist (keyword repology--project-filters)
+ (let ((value (plist-get filters keyword)))
+ (when value
+ (let ((key (substring (symbol-name keyword) 1)))
+ (push (format "%s=%s"
+ (url-hexify-string key)
+ (url-hexify-string value))
+ query)))))
+ (if (null query) ""
+ (concat "?" (mapconcat #'identity query "&")))))
+
+(defun repology--build-url (action value start)
+ "Build a URL from an ACTION symbol.
+Value is a plist if ACTION is `projects', or a string otherwise."
+ (concat repology-base-url
+ (symbol-name action)
+ "/"
+ (pcase action
+ ('project value)
+ ('repository (concat value "/problems"))
+ ('projects
+ (concat (and start (concat start "/"))
+ (repology--build-query-string value)))
+ (_ (error "Unknown action: %S" action)))))
+
+(defun repology-request (url &optional extra-headers)
+ "Perform a raw HTTP request on URL.
+EXTRA-HEADERS is an assoc list of headers/contents to send with
+the request."
+ (let* ((url-request-method "GET")
+ (url-request-extra-headers extra-headers)
+ (process-buffer (url-retrieve-synchronously url t)))
+ (unwind-protect
+ (with-current-buffer process-buffer
+ (goto-char (point-min))
+ (let* ((status-line-regexp
+ (rx bol
+ (one-or-more (not (any " "))) " "
+ (group (in "1-5") (= 2 digit)) " "
+ (group (one-or-more (in "A-Z" "a-z" " ")))
+ eol))
+ (status
+ (and (looking-at status-line-regexp)
+ (list :code (string-to-number (match-string 1))
+ :reason (match-string 2))))
+ (header nil)
+ (body nil))
+ (forward-line)
+ (while (looking-at "^\\([^:]+\\): \\(.*\\)")
+ (push (match-string 1) header)
+ (push (match-string 2) header)
+ (forward-line))
+ (forward-line)
+ (unless (eobp)
+ (setq body (buffer-substring (point) (point-max))))
+ (append status (list :header (nreverse header) :body body))))
+ (kill-buffer process-buffer))))
+
+(defun repology--get (action value start)
+ "Perform an HTTP GET request to Repology API.
-Return t if version S1 is lower than version S2.
+ACTION is a symbol. If it is `projects', VALUE is a plist and START a string.
+Otherwise, VALUE is a string, and START is nil.
-See URL `https://github.com/repology/libversion/blob/master/doc/ALGORITHM.md'."
- (let ((v1 (repology--string-to-version s1))
- (v2 (repology--string-to-version s2)))
- (catch :less?
- (while (or v1 v2)
- (pcase-let ((`(,r1 . ,v1)
- (or (pop v1) repology-version-zero-component))
- (`(,r2 . ,v2)
- (or (pop v2) repology-version-zero-component)))
- (cond
- ;; First compare ranks, then values.
- ((/= r1 r2) (throw :less? (< r1 r2)))
- ;; Components are equal. Try next component.
- ((equal v1 v2) nil)
- ;; Numeric components are compared... numerically.
- ((= r1 3) (throw :less? (< v1 v2)))
- ;; Alphabetic components are compared by case insensitively
- ;; comparing their first letters.
- (t (throw :less?
- (string-lessp (substring v1 0 1) (substring v2 0 1)))))))
- ;; Strings S1 and S2 represent equal versions.
- nil)))
+Information is returned as parsed JSON."
+ (let ((key (repology--cache-key action value start)))
+ (or (repology--cache-get key)
+ (let ((request
+ (repology-request
+ (repology--build-url action value start)
+ '(("Content-Type" . "application/json")))))
+ (pcase (plist-get request :reason)
+ ("OK"
+ (let ((body (repology--parse-json (plist-get request :body))))
+ (repology--cache-put key body)
+ ;; Information from `projects' is a list of projects,
+ ;; so, we can also cache each of them for a future
+ ;; project lookup.
+ (when (eq action 'projects)
+ (dolist (project body)
+ (let ((key (repology--cache-key
+ 'project (repology-project-name project) nil))
+ (packages (repology-project-packages project)))
+ (repology--cache-put key packages))))
+ ;; Return information.
+ body))
+ (status
+ (error "Cannot retrieve information: %S" status)))))))
-
-;;; Search functions
(defun repology-lookup-project (name)
"List packages for project NAME.
NAME is a string. Return a list of packages."
- (repology--get 'project name nil))
+ (with-temp-message
+ (format-message "Repology: Requesting information about `%s'..." name)
+ (repology--get 'project name nil)))
(defun repology-search-projects (&rest filters)
"Retrieve results of an advanced search in Repology.
@@ -1001,41 +822,217 @@ Return a list of projects. Projects with a known
non-free license are removed
from output, unless `repology-free-only-projects' is nil."
(let ((result nil)
(name nil))
- (catch :exit
- (while t
- (let ((request (repology--get 'projects filters name)))
- (setq result (append result (cdr request)))
- (cond
- ;; Too many matches: drop those above limit and exit.
- ((<= repology-projects-limit (length result))
- (setq result (seq-subseq result 0 repology-projects-limit))
- (throw :exit nil))
- ;; Matches exhausted: exit and return result.
- ((> repology-projects-hard-limit (length request))
- (throw :exit result))
- ;; Resume search starting from an imaginary project located
- ;; right after the last project found, alphabetically.
- (t
- (setq name
- (pcase (last request)
- (`(,(and (pred repology-project-p) project))
- (concat (repology-project-name project) "-"))
- (other (error "Invalid request result: %S" other)))))))))
- ;; Trim non-free projects.
- (if (not repology-free-only-projects)
- result
- (seq-filter (lambda (project) (repology-free-p project))
- result))))
+ (with-temp-message "Repology: Querying API..."
+ (catch :exit
+ (while t
+ (let ((request (repology--get 'projects filters name)))
+ (setq result (append result request))
+ (cond
+ ;; Too many matches: drop those above limit and exit.
+ ((<= repology-projects-limit (length result))
+ (setq result (seq-subseq result 0 repology-projects-limit))
+ (throw :exit nil))
+ ;; Matches exhausted: exit and return result.
+ ((> repology-projects-hard-limit (length request))
+ (throw :exit result))
+ ;; Resume search starting from an imaginary project
+ ;; located right after the last project found,
+ ;; alphabetically. This is done by appending an hyphen to
+ ;; the name of the last project found.
+ (t
+ (setq name
+ (pcase (last request)
+ (`(,(and (pred repology-project-p) project))
+ (concat (repology-project-name project) "-"))
+ (other (error "Invalid request result: %S"
other))))))))))
+ ;; Possibly keep only non projects.
+ (if repology-free-only-projects
+ (with-temp-message "Repology: Filtering out non-free projects..."
+ (seq-filter (lambda (project) (repology-free-p project))
+ result))
+ result)))
(defun repology-report-problems (repository)
"List problems related to REPOSITORY.
REPOSITORY is a string. Return a list of problems."
(unless (member repository (repology-list-repositories))
(user-error "Unknown repository: %S" repository))
- (repology--get 'repository repository nil))
+ (with-temp-message
+ (message "Repology: Fetching problems reports about %s"
+ (repology-repository-full-name repository))
+ (repology--get 'repository repository nil)))
;;; Display functions
+(defvar repology--display-projects-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map (kbd "RET") 'repology--show-current-project)
+ (define-key map (kbd "F") 'repology--check-freedom)
+ map)
+ "Local keymap for `repology--display-projects-mode' buffers.")
+
+(defvar repology--display-packages-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map tabulated-list-mode-map)
+ (define-key map (kbd "RET") 'repology--show-current-package)
+ (define-key map (kbd "F") 'repology--check-freedom)
+ map)
+ "Local keymap for `repology--display-packages-mode' buffers.")
+
+(defun repology--show-current-package ()
+ "Display packages associated to package at point."
+ (interactive)
+ (repology-display-package (tabulated-list-get-id)))
+
+(defun repology--check-freedom ()
+ "Check if package or project at point is free."
+ (interactive)
+ (message "Freedom status: %s"
+ (pcase (repology-free-p (tabulated-list-get-id))
+ ('unknown (propertize "Unknown" 'face 'shadow))
+ ('nil (propertize "Non-Free" 'face 'warning))
+ (_ (propertize "Free" 'face 'highlight)))))
+
+(defun repology--show-current-project ()
+ "Display packages associated to project at point."
+ (interactive)
+ (repology-display-packages
+ (repology-project-packages (tabulated-list-get-id))))
+
+(define-derived-mode repology--display-package-mode tabulated-list-mode
+ "Repology/Package"
+ "Major mode used to display packages returned by Repology API.
+\\{tabulated-list-mode-map}"
+ (setq tabulated-list-format [("Field" 15 t) ("Value" 0 t)])
+ (tabulated-list-init-header))
+
+(define-derived-mode repology--display-packages-mode tabulated-list-mode
+ "Repology/Packages"
+ "Major mode used to display packages returned by Repology API.
+\\{repology--display-packages-mode-map}"
+ (setq tabulated-list-format
+ (repology--columns-to-header repology-display-packages-columns))
+ (tabulated-list-init-header))
+
+(define-derived-mode repology--display-projects-mode tabulated-list-mode
+ "Repology/Projects"
+ "Major mode used to display projects returned by Repology API.
+\\{repology--display-projects-mode-map}"
+ (setq tabulated-list-format
+ (repology--columns-to-header repology-display-projects-columns))
+ (tabulated-list-init-header))
+
+(define-derived-mode repology--display-problems-mode tabulated-list-mode
+ "Repology/Problems"
+ "Major mode used to display problems returned by Repology API.
+\\{tabulated-list-mode-map}"
+ (setq tabulated-list-format
+ (repology--columns-to-header repology-display-problems-columns))
+ (tabulated-list-init-header))
+
+(defun repology--value-to-string (value)
+ "Change VALUE object into a string suitable for display."
+ (pcase value
+ (`nil "-")
+ ((pred listp)
+ (mapconcat (lambda (e) (format "%s" e))
+ (seq-uniq value)
+ " "))
+ (_
+ (format "%s" value))))
+
+(defun repology--package-status-face (package)
+ "Return face associated to status from PACKAGE."
+ (let ((status (repology-package-field package 'status)))
+ (alist-get status repology-status-faces 'default nil #'equal)))
+
+(defun repology--make-display (data buffer-name mode format-descriptors)
+ "Display DATA in a buffer named after BUFFER-NAME string.
+DATA is displayed in a major mode derived from `tabulated-list-mode', and set
+by function MODE. Each entry is identified by the element from DATA, and
+formatted according to FORMAT-DESCRIPTORS function. This function is called
+with one argument: an element from DATA."
+ (let ((buffer (get-buffer-create buffer-name)))
+ (with-current-buffer buffer
+ (funcall mode)
+ (setq tabulated-list-entries
+ (mapcar (lambda (datum)
+ (list datum
+ (apply #'vector
+ (funcall format-descriptors datum))))
+ data))
+ (tabulated-list-print))
+ (pop-to-buffer buffer)))
+
+(defun repology--columns-to-header (specs)
+ "Return vector of column names according to SPECS.
+SPECS is an association list. Each entry has the form (NAME _ WIDTH SORT)
+where NAME, WIDTH and SORT are of the expected type in
`tabulated-list-format'."
+ (apply #'vector
+ (mapcar (lambda (format)
+ (pcase format
+ (`(,name ,_ ,width ,sort) (list name width sort))
+ (other
+ (user-error "Invalid package column format: %S" other))))
+ specs)))
+
+(defun repology--column-to-descriptor (datum specs &optional symbol-handler)
+ "Return list of descriptors for DATUM according to SPECS.
+
+DATUM is a package, a problem, or a project. SPECS is an association
+list. Each entry has the form (_ VALUE _ _).
+
+VALUE is a function called with DATUM as its sole argument. When VALUE is
+a symbol, and optional argument SYMBOL-HANDLER is a function, SYMBOL-HANDLER
+is called with two arguments: DATUM and VALUE. In any case, the return value
+is then turned into a string and displayed."
+ (mapcar (lambda (spec)
+ (pcase spec
+ ;; Contents as a function.
+ (`(,_ ,(and (pred functionp) f) ,_ ,_)
+ (repology--value-to-string (funcall f datum)))
+ ;; Contents as a symbol.
+ ((and (guard symbol-handler)
+ `(,_ ,(and (pred symbolp) field) ,_ ,_))
+ (repology--value-to-string (funcall symbol-handler datum
field)))
+ ;; Invalid contents.
+ (other (user-error "Invalid format type: %S" other))))
+ specs))
+
+(defun repology--format-field-descriptors (field)
+ "Format an entry from FIELD.
+Format follows `repology-display-packages-columns' specifications.
+Return a list of descriptors."
+ (pcase field
+ (`(,name . ,value)
+ (list (symbol-name name)
+ (repology--value-to-string value) ))
+ (_
+ (error "Invalid field: %S" field))))
+
+(defun repology--format-package-descriptors (package)
+ "Format an entry from PACKAGE.
+Format follows `repology-display-packages-columns' specifications.
+Return a list of descriptors."
+ (repology--column-to-descriptor package
+ repology-display-packages-columns
+ #'repology-package-field))
+
+(defun repology--format-project-descriptors (project)
+ "Format an entry for PROJECT.
+Format follows `repology-display-packages-columns' specifications.
+Return a list of descriptors."
+ (repology--column-to-descriptor project repology-display-projects-columns))
+
+(defun repology--format-problem-descriptors (problem)
+ "Format an entry from PROBLEM.
+Format follows `repology-display-problems-columns' specifications.
+Return a list of descriptors."
+ (repology--column-to-descriptor problem
+ repology-display-problems-columns
+ #'repology-problem-field))
+
(defun repology-display-projects-default (_ selected)
"Return columns format rules appropriate for projects display.
SELECTED is a selected repository, i.e., the value of `:inrepo' filter,
@@ -1109,6 +1106,47 @@ Columns are displayed according to
`repology-display-problems-columns'."
;;; Interactive query
+(defconst repology--main-prompt
+ (format-message
+ "Action: [S]earch projects [L]ookup project \
+\[R]eport repository problems (`q' to quit)")
+ "Main prompt used if `repology' UI.")
+
+(defun repology--select-key (allowed-keys msg)
+ "Keep requesting user to press a key until it belongs to ALLOWED-KEYS.
+ALLOWED-KEYS is a list of characters. MSG is the message used as the prompt."
+ (let ((key (read-char msg)))
+ (while (not (memq key allowed-keys))
+ (message "Invalid key")
+ (sit-for 0.5)
+ (setq key (read-char msg)))
+ key))
+
+(defun repology--query-y-or-n-p (prompt _)
+ "Ask user a \"y or n\" question, displaying PROMPT.
+Return \"on\" or \"off\"."
+ (if (y-or-n-p prompt) "on" "off"))
+
+(defun repology--query-repository (prompt initial)
+ "Ask user an existing repository by its full name, displaying PROMPT.
+INITIAL is the initial input. Return a repository internal name."
+ (repology-repository-name
+ (completing-read prompt (repology-list-repositories t) nil t initial)))
+
+(defun repology--query-filter-value (filter initial)
+ "Ask user for FILTER value.
+FILTER is a project filter, as a keyword. INITIAL is a string inserted as
+a first suggestion, or nil. Return the answer as a string."
+ (pcase (assq filter repology-project-filters-parameters)
+ (`nil
+ (error "Unknown filter: %S" filter))
+ (`(,_ ,prompt nil)
+ (read-string prompt initial))
+ (`(,_ ,prompt ,(and (pred functionp) collection))
+ (funcall collection prompt initial))
+ (other
+ (error "Invalid value: %S" other))))
+
;;;###autoload
(defun repology ()
"Query Repology interactively.
@@ -1130,8 +1168,7 @@ This function interacts with Repology API in three ways.
You can:
displayed by selecting \"limit\" from the list of properties. The default
value is `repology-projects-limit'."
(interactive)
- (pcase (read-char "Action: [S]earch projects [L]ookup project \
-\[R]eport repository problems")
+ (pcase (repology--select-key '(?s ?S ?l ?L ?r ?R ?q ?Q)
repology--main-prompt)
((or ?r ?R)
(repology-display-problems
(repology-report-problems
@@ -1176,7 +1213,10 @@ This function interacts with Repology API in three ways.
You can:
(apply #'repology-search-projects query))
;; Selected repository, or nil.
(plist-get query :inrepo))))
- (_ (user-error "Unknown answer. Aborting"))))
+ ((or ?q ?Q)
+ (message "Repology: Quitting"))
+ (_
+ (error "This should not happen"))))
(provide 'repology)