emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/repology c8e1dc4 8/9: New "repology-utils.el" file cont


From: Nicolas Goaziou
Subject: [elpa] externals/repology c8e1dc4 8/9: New "repology-utils.el" file containing generic tools
Date: Mon, 18 Jan 2021 17:27:54 -0500 (EST)

branch: externals/repology
commit c8e1dc440bb15cb0515f13d43a12564d8f505aeb
Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
Commit: Nicolas Goaziou <mail@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 <mail@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.
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]