branch: externals/repology
commit c8e1dc440bb15cb0515f13d43a12564d8f505aeb
Author: Nicolas Goaziou <m...@nicolasgoaziou.fr>
Commit: Nicolas Goaziou <m...@nicolasgoaziou.fr>
New "repology-utils.el" file containing generic tools
* repology-utils.el: New file.
* repology-license.el:
* repology.el (repology--repositories):
(repology-package-p):
(repology-project-p):
(repology-project-name):
(repology-project-packages):
(repology-project-newest-version):
(repology-project-outdated-versions):
(repology-package-field):
(repology-package-repository-full-name):
(repology-package-colorized-status):
(repology-package-colorized-version):
(repology-problem-field):
(repology-list-repositories):
(repology-refresh-repositories):
(repology-repository-name):
(repology-repository-full-name):
(repology-display-sort-column):
(repology-compare-texts):
(repology-compare-numbers):
(repology-version-zero-component):
(repology-version-pre-keywords):
(repology-version-post-keywords):
(repology--string-to-version):
(repology-compare-versions):
(repology-request): Move to new file.
---
repology-license.el | 8 +-
repology-utils.el | 403 ++++++++++++++++++++++++++++++++++++++++++++++++++++
repology.el | 375 ++----------------------------------------------
3 files changed, 414 insertions(+), 372 deletions(-)
diff --git a/repology-license.el b/repology-license.el
index 12f5235..261098d 100644
--- a/repology-license.el
+++ b/repology-license.el
@@ -30,13 +30,7 @@
;; 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))
+(require 'repology-utils)
;;; Constants
diff --git a/repology-utils.el b/repology-utils.el
new file mode 100644
index 0000000..d7ec127
--- /dev/null
+++ b/repology-utils.el
@@ -0,0 +1,403 @@
+;;; repology-utils.el --- Utilitaries for Repology -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2021 Free Software Foundation, Inc.
+
+;; Author: Nicolas Goaziou <m...@nicolasgoaziou.fr>
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides various tools used throughout the code base. It
+;; includes accessors and predicates for packages, projects and problems
+;; objects. It also provides functions useful in configuration variables.
+;; Eventually, it implements `repology-request'.
+
+;;; Code:
+
+
+;;; Macro
+
+;; XXX: We need it to be a macro because it is required early, e.g.,
+;; in `repology-display-packages-columns'.
+(defmacro repology-display-sort-column (name predicate)
+ "Return a function comparing entries in column NAME.
+NAME is a string. Compare entries using function PREDICATE, called on two
+objects of the column."
+ `(lambda (e1 e2)
+ (let ((column
+ ;; Find column's number
+ (or (seq-position tabulated-list-format
+ ,name
+ (pcase-lambda (`(,n . ,_) s) (equal n s)))
+ (error "Invalid column name %S" ,name))))
+ (let ((s1 (elt (cadr e1) column))
+ (s2 (elt (cadr e2) column)))
+ (funcall ,predicate s1 s2)))))
+
+
+;;; Packages
+(defun repology-package-p (object)
+ "Return t if OBJECT is a package."
+ (and (consp object)
+ ;; Mandatory fields.
+ (stringp (alist-get 'repo object))
+ (stringp (or (alist-get 'name object)
+ (alist-get 'srcname object)
+ (alist-get 'binname object)))
+ (stringp (alist-get 'version object))))
+
+(defun repology-package-field (package field)
+ "Return PACKAGE's FIELD.
+
+FIELD is a symbol among:
+
+`repo'
+ name of repository for this package
+
+`subrepo'
+ name of subrepository (if applicable; for example, main or contrib or
+ non-free for Debian)
+
+`name', `srcname', `binname'
+ package name(s) as used in repository - generic one and/or source package
+ name and/or binary package name, whichever is applicable
+
+`visiblename'
+ package name as shown to the user by Repology
+
+`version'
+ package version (sanitized, as shown by Repology)
+
+`origversion'
+ package version as in repository
+
+`status'
+ package status, one of \"newest\", \"devel\", \"unique\", \"outdated\", \
+\"legacy\",
+ \"rolling\", \"noscheme\", \"incorrect\", \"untrusted\", \"ignored\"
+
+`summary'
+ one-line description of the package
+
+`categories'
+ list of package categories
+
+`licenses'
+ list of package licenses
+
+`maintainers'
+ list of package maintainers
+
+`www'
+ list of package webpages
+
+`downloads'
+ list of package downloads
+
+Mandatory fields are `repo', `visiblename', and `version'; all other fields
+are optional."
+ (unless (memq field repology-package-all-fields)
+ (user-error "Unknown field: %S" field))
+ (alist-get field package))
+
+(defun repology-package-repository-full-name (package)
+ "Return PACKAGE repository's full name.
+Return PACKAGE's repository internal name if the full name is unknown."
+ (let ((repo (repology-package-field package 'repo)))
+ ;; Since `repology-list-repositories' may fail, e.g., due to
+ ;; connectivity issues, ensure something is returned anyway, in
+ ;; this case, the repository internal name.
+ (or (ignore-errors (repology-repository-full-name repo))
+ repo)))
+
+(defun repology-package-colorized-status (package)
+ "Return colorized status string for PACKAGE.
+The version string is emphasized according to PACKAGE's status.
+Return nil if PACKAGE has no status field."
+ (let ((status (repology-package-field package 'status)))
+ (and (stringp status)
+ (propertize status 'face (repology--package-status-face package)))))
+
+(defun repology-package-colorized-version (package)
+ "Return colorized version string for PACKAGE.
+The version string is emphasized according to PACKAGE's status.
+See `repology-status-faces'."
+ (propertize (repology-package-field package 'version)
+ 'face
+ (repology--package-status-face package)))
+
+
+;;; Projects
+(defun repology-project-p (object)
+ "Return t if OBJECT is a project."
+ (pcase object
+ (`(,(pred symbolp) . ,packages)
+ (seq-every-p #'repology-package-p packages))
+ (_ nil)))
+
+(defun repology-project-name (project)
+ "Return PROJECT's name, as a string."
+ (unless (repology-project-p project)
+ (user-error "No valid project provided"))
+ (symbol-name (car project)))
+
+(defun repology-project-packages (project)
+ "Return list of packages associated to PROJECT."
+ (unless (repology-project-p project)
+ (user-error "No valid project provided"))
+ (cdr project))
+
+(defun repology-project-newest-version (project)
+ "Return newest version string for packages in PROJECT, or nil."
+ (let ((newest
+ (seq-find (lambda (package)
+ (equal "newest" (repology-package-field package 'status)))
+ (repology-project-packages project))))
+ (and newest (repology-package-field newest 'version))))
+
+(defun repology-project-outdated-versions (project)
+ "Return a list of outdated versions for packages in PROJECT, or nil.
+Versions are sorted in descending order."
+ (let ((outdated
+ (seq-filter
+ (lambda (package)
+ (equal "outdated"
+ (repology-package-field package 'status)))
+ (repology-project-packages project))))
+ (sort (mapcar (lambda (p) (repology-package-field p 'version))
+ outdated)
+ ;; Return versions in decreasing order.
+ (lambda (s1 s2) (repology-compare-versions s2 s1)))))
+
+
+;;; Problems
+(defun repology-problem-field (problem field)
+ "Return PROBLEM's FIELD.
+
+FIELD is a symbol. Repology API does not define an exhaustive list of
+allowed symbols. However, it currently supports, among others, the
+following ones:
+
+`repo'
+ repository name
+
+`visiblename'
+ package name as in Repology
+
+`effname'
+ repology project name
+
+`maintainer'
+ package maintainer associated with the problem; may be null; note that
+ if there are multiple package maintainers, problem is duplicated for
+ each one
+
+`type'
+ textual description of the problem"
+ (alist-get field problem))
+
+
+;;; Repositories
+(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-list-repositories (&optional full-name)
+ "Return repositories known to Repology.
+
+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
+ (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 ()
+ "Refresh list of repositories known to Repology."
+ (setq repology--repositories nil)
+ (repology-list-repositories))
+
+(defun repology-repository-name (full-name)
+ "Return name of repository named after string FULL-NAME.
+Raise an error if FULL-NAME is unknown to Repology."
+ (unless (member full-name (repology-list-repositories t))
+ (user-error "Unknown repository: %S" full-name))
+ (pcase (rassoc full-name repology--repositories)
+ (`(,(and (pred stringp) name) . ,_) name)
+ (_ (error "Corrupted repository list!"))))
+
+(defun repology-repository-full-name (repository)
+ "Return user-facing name for string REPOSITORY.
+Raise an error if REPOSITORY is unknown to Repology."
+ (unless (member repository (repology-list-repositories))
+ (user-error "Unknown repository: %S" repository))
+ (or (alist-get repository repology--repositories nil nil #'equal)
+ (error "Corrupted repository list!")))
+
+
+;;; Requests
+(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))))
+
+
+;;; Version Comparison
+
+;; This part implements version comparison as done by Repology's
+;; libversion. See
+;; <https://github.com/repology/libversion/blob/master/doc/ALGORITHM.md>.
+(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."
+ (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)))
+
+
+;;; Other Comparisons
+(defun repology-compare-texts (s1 s2)
+ "Compare strings S1 and S2 in collation order.
+Return t if S1 is less than S2. Case is ignored."
+ (string-collate-lessp s1 s2 nil t))
+
+(defun repology-compare-numbers (s1 s2)
+ "Compare strings S1 and S2 numerically.
+Return t if S1 is less than S2."
+ (< (string-to-number s1) (string-to-number s2)))
+
+
+(provide 'repology-utils)
+;;; repology-utils.el ends here
diff --git a/repology.el b/repology.el
index eab115ba..37c7ccb 100644
--- a/repology.el
+++ b/repology.el
@@ -81,30 +81,6 @@
;;; Code:
-(require 'json)
-(require 'tabulated-list)
-(require 'url)
-
-(require 'repology-license)
-
-
-;;; Macros
-;; XXX: It is a macro because we need it to be available in defcustoms.
-(defmacro repology-display-sort-column (name predicate)
- "Return a function comparing entries in column NAME.
-NAME is a string. Compare entries using function PREDICATE, called on two
-objects of the column."
- `(lambda (e1 e2)
- (let ((column
- ;; Find column's number
- (or (seq-position tabulated-list-format
- ,name
- (pcase-lambda (`(,n . ,_) s) (equal n s)))
- (error "Invalid column name %S" ,name))))
- (let ((s1 (elt (cadr e1) column))
- (s2 (elt (cadr e2) column)))
- (funcall ,predicate s1 s2)))))
-
;;; Upstream Constants
(defconst repology-base-url "https://repology.org/api/v1/";
@@ -129,6 +105,16 @@ It is used as a source for all known repositories.")
See URL `https://repology.org/api'.")
+;;; Load Libraries
+(require 'json)
+(require 'tabulated-list)
+(require 'url)
+
+;; These need to be loaded after upstream constants.
+(require 'repology-utils)
+(require 'repology-license)
+
+
;;; Configuration
(defgroup repology nil
"Repology API access from Emacs"
@@ -315,314 +301,6 @@ is nil, `read-string' is used.")
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)
- ;; Mandatory fields.
- (stringp (alist-get 'repo object))
- (stringp (or (alist-get 'name object)
- (alist-get 'srcname object)
- (alist-get 'binname object)))
- (stringp (alist-get 'version object))))
-
-(defun repology-project-p (object)
- "Return t if OBJECT is a project."
- (pcase object
- (`(,(pred symbolp) . ,packages)
- (seq-every-p #'repology-package-p packages))
- (_ nil)))
-
-(defun repology-project-name (project)
- "Return PROJECT's name, as a string."
- (unless (repology-project-p project)
- (user-error "No valid project provided"))
- (symbol-name (car project)))
-
-(defun repology-project-packages (project)
- "Return list of packages associated to PROJECT."
- (unless (repology-project-p project)
- (user-error "No valid project provided"))
- (cdr project))
-
-(defun repology-project-newest-version (project)
- "Return newest version string for packages in PROJECT, or nil."
- (let ((newest
- (seq-find (lambda (package)
- (equal "newest" (repology-package-field package 'status)))
- (repology-project-packages project))))
- (and newest (repology-package-field newest 'version))))
-
-(defun repology-project-outdated-versions (project)
- "Return a list of outdated versions for packages in PROJECT, or nil.
-Versions are sorted in descending order."
- (let ((outdated
- (seq-filter
- (lambda (package)
- (equal "outdated"
- (repology-package-field package 'status)))
- (repology-project-packages project))))
- (sort (mapcar (lambda (p) (repology-package-field p 'version))
- outdated)
- ;; Return versions in decreasing order.
- (lambda (s1 s2) (repology-compare-versions s2 s1)))))
-
-(defun repology-package-field (package field)
- "Return PACKAGE's FIELD.
-
-FIELD is a symbol among:
-
-`repo'
- name of repository for this package
-
-`subrepo'
- name of subrepository (if applicable; for example, main or contrib or
- non-free for Debian)
-
-`name', `srcname', `binname'
- package name(s) as used in repository - generic one and/or source package
- name and/or binary package name, whichever is applicable
-
-`visiblename'
- package name as shown to the user by Repology
-
-`version'
- package version (sanitized, as shown by Repology)
-
-`origversion'
- package version as in repository
-
-`status'
- package status, one of \"newest\", \"devel\", \"unique\", \"outdated\", \
-\"legacy\",
- \"rolling\", \"noscheme\", \"incorrect\", \"untrusted\", \"ignored\"
-
-`summary'
- one-line description of the package
-
-`categories'
- list of package categories
-
-`licenses'
- list of package licenses
-
-`maintainers'
- list of package maintainers
-
-`www'
- list of package webpages
-
-`downloads'
- list of package downloads
-
-Mandatory fields are `repo', `visiblename', and `version'; all other fields
-are optional."
- (unless (memq field repology-package-all-fields)
- (user-error "Unknown field: %S" field))
- (alist-get field package))
-
-(defun repology-package-repository-full-name (package)
- "Return PACKAGE repository's full name.
-Return PACKAGE's repository internal name if the full name is unknown."
- (let ((repo (repology-package-field package 'repo)))
- ;; Since `repology-list-repositories' may fail, e.g., due to
- ;; connectivity issues, ensure something is returned anyway, in
- ;; this case, the repository internal name.
- (or (ignore-errors (repology-repository-full-name repo))
- repo)))
-
-(defun repology-package-colorized-status (package)
- "Return colorized status string for PACKAGE.
-The version string is emphasized according to PACKAGE's status.
-Return nil if PACKAGE has no status field."
- (let ((status (repology-package-field package 'status)))
- (and (stringp status)
- (propertize status 'face (repology--package-status-face package)))))
-
-(defun repology-package-colorized-version (package)
- "Return colorized version string for PACKAGE.
-The version string is emphasized according to PACKAGE's status.
-See `repology-status-faces'."
- (propertize (repology-package-field package 'version)
- 'face
- (repology--package-status-face package)))
-
-(defun repology-problem-field (problem field)
- "Return PROBLEM's FIELD.
-
-FIELD is a symbol. Repology API does not define an exhaustive list of
-allowed symbols. However, it currently supports, among others, the
-following ones:
-
-`repo'
- repository name
-
-`visiblename'
- package name as in Repology
-
-`effname'
- repology project name
-
-`maintainer'
- package maintainer associated with the problem; may be null; note that
- if there are multiple package maintainers, problem is duplicated for
- each one
-
-`type'
- textual description of the problem"
- (alist-get field problem))
-
-(defun repology-list-repositories (&optional full-name)
- "Return repositories known to Repology.
-
-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
- (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 ()
- "Refresh list of repositories known to Repology."
- (setq repology--repositories nil)
- (repology-list-repositories))
-
-(defun repology-repository-name (full-name)
- "Return name of repository named after string FULL-NAME.
-Raise an error if FULL-NAME is unknown to Repology."
- (unless (member full-name (repology-list-repositories t))
- (user-error "Unknown repository: %S" full-name))
- (pcase (rassoc full-name repology--repositories)
- (`(,(and (pred stringp) name) . ,_) name)
- (_ (error "Corrupted repository list!"))))
-
-(defun repology-repository-full-name (repository)
- "Return user-facing name for string REPOSITORY.
-Raise an error if REPOSITORY is unknown to Repology."
- (unless (member repository (repology-list-repositories))
- (user-error "Unknown repository: %S" repository))
- (or (alist-get repository repology--repositories nil nil #'equal)
- (error "Corrupted repository list!")))
-
-(defun repology-compare-texts (s1 s2)
- "Compare strings S1 and S2 in collation order.
-Return t if S1 is less than S2. Case is ignored."
- (string-collate-lessp s1 s2 nil t))
-
-(defun repology-compare-numbers (s1 s2)
- "Compare strings S1 and S2 numerically.
-Return t if S1 is less than S2."
- (< (string-to-number s1) (string-to-number 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.
@@ -704,39 +382,6 @@ Value is a plist if ACTION is `projects', or a string
otherwise."
(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.
