Publishing my code to deal with RPM packages.

diff --git a/character-classes.lisp b/character-classes.lisp
new file mode 100644 (file)
index 0000000..65baec8
--- /dev/null
+++ b/character-classes.lisp
@@ -0,0 +1,30 @@
+#+xcvb (module (:depends-on ("pkgdcl")))
+
+(in-package :rpm)
+
+;; TODO: move this to FARE-UTILS or somewhere else???
+
+(defun ascii-char-p (x)
+  (and (characterp x) (<= 0 (char-code x) 127)))
+
+(defun ascii-uppercase-letter-p (x)
+  (char<= #\A x #\Z))
+
+(defun ascii-lowercase-letter-p (x)
+  (char<= #\a x #\z))
+
+(defun ascii-letter-p (x)
+  (or (ascii-uppercase-letter-p x) (ascii-lowercase-letter-p x)))
+
+(defun ascii-digit-p (x)
+  (char<= #\0 x #\9))
+
+(defun ascii-alphanumeric-p (x)
+  (or (ascii-letter-p x) (ascii-digit-p x)))
+
+(defun ascii-non-alphanumeric-p (x)
+  (not (ascii-alphanumeric-p x)))
+
+(defun ascii-alphanumeric-or-underscore-p (x)
+  (or (ascii-alphanumeric-p x)
+      (eql x #\_)))

diff --git a/pkgdcl.lisp b/pkgdcl.lisp
new file mode 100644 (file)
index 0000000..541eb91
--- /dev/null
+++ b/pkgdcl.lisp
@@ -0,0 +1,14 @@
+#+xcvb (module ())
+
+(in-package :cl)
+
+(defpackage :rpm
+  (:use :inferior-shell)
+  (:export
+   #:parse-rpm-versioned-name
+   #:rpm-versioned-name-basename #:rpm-versioned-name-version
+   #:parse-rpm-pathname
+   #:rpm-pathname-packagename #:rpm-pathname-version
+   #:rpm-version=
+   #:rpm-version<= #:rpm-version< #:rpm-version>= #:rpm-version>
+   #:rpms-installed #:rpms-to-update))

diff --git a/rpm.asd b/rpm.asd
new file mode 100644 (file)
index 0000000..3d846ee
--- /dev/null
+++ b/rpm.asd
@@ -0,0 +1,8 @@
+;;; -*- Lisp -*-
+
+(defsystem :rpm
+  :depends-on (:inferior-shell)
+  :components
+  ((:file "pkgdcl")
+   (:file "version" :depends-on ("pkgdcl"))
+   (:file "rpm" :depends-on ("pkgdcl"))))

diff --git a/upgrade.lisp b/upgrade.lisp
new file mode 100644 (file)
index 0000000..d2e5dc4
--- /dev/null
+++ b/upgrade.lisp
@@ -0,0 +1,39 @@
+#+xcvb (module (:depends-on ("pkgdcl")))
+
+(in-package :rpm)
+
+(defun hash-rpm-versioned-names-by-name (rpm-list)
+  (loop :with hash = (make-hash-table :test 'equal)
+    :for rpm :in rpm-list
+    :do (setf (gethash (parse-rpm-versioned-name rpm) hash) rpm)
+    :finally (return hash)))
+
+(defun hash-rpm-pathnames-by-packagename (rpm-list)
+  (loop :with hash = (make-hash-table :test 'equal)
+    :for rpm :in rpm-list
+    :do (setf (gethash (rpm-pathname-packagename rpm) hash) rpm)
+    :finally (return hash)))
+
+(defun rpms-installed (&key (packagenames t) host)
+  (run/lines
+   `(pipe (rpm -qa)
+          ,@(unless (eq packagenames t)
+              `((egrep ("^(" ,@(loop :for (name . more) :on packagenames
+                                 :collect name :when more :collect "|")
+                             ")-[^-]+-[^-]+$")))))
+   :host host))
+
+(defun rpms-to-update (desired-rpms &key
+                       host (test 'rpm-version<=))
+  (loop
+    :with packagenames = (mapcar 'rpm-pathname-packagename desired-rpms)
+    :with installed-rpms = (rpms-installed :packagenames packagenames :host host)
+    :with hash = (hash-rpm-versioned-names-by-name installed-rpms)
+    :for desired-rpm :in desired-rpms
+    :for name = (rpm-pathname-packagename desired-rpm)
+    :for installed-rpm = (gethash name hash)
+    :for desired-version = (rpm-pathname-version desired-rpm)
+    :for installed-version = (when installed-rpm
+                               (rpm-versioned-name-version installed-rpm))
+    :unless (funcall test desired-version installed-version)
+    :collect desired-rpm))

diff --git a/version.lisp b/version.lisp
new file mode 100644 (file)
index 0000000..80c3683
--- /dev/null
+++ b/version.lisp
@@ -0,0 +1,165 @@
+#+xcvb (module (:depends-on ("character-classes")))
+
+(in-package :qwalitee)
+
+(named-readtables:in-readtable :λ-standard)
+
+(defun valid-rpm-version-component-p (string &key start end)
+  (and
+   (find-if #'ascii-digit-p string :start start :end end)
+   (not (find-if (λ (x) (find x "-~/")) string :start start :end end))
+   (not (search ".." string :start2 start :end2 end))))
+
+(defun valid-rpm-architecture-component-p (string &key start end)
+  (and
+   (find-if #'ascii-letter-p string :start start :end end)
+   (not (find-if-not 'ascii-alphanumeric-or-underscore-p
+                     string :start start :end end))))
+
+(defun parse-rpm-versioned-name (string &key (start 0) (end (length string)))
+  (flet ((err () (error "No valid RPM version in package name ~S" string))
+         (split-at (n) (values (subseq string start n)
+                               (subseq string (1+ n) end))))
+    (let ((pos (position #\- string :from-end t :start start :end end)))
+      (unless (and pos (valid-rpm-version-component-p
+                        string :start (1+ pos) :end end))
+        (err))
+      (let ((pos2 (position #\- string :from-end t :start start :end pos)))
+        (split-at (if (and pos2
+                           (valid-rpm-version-component-p
+                            string :start (1+ pos2) :end pos))
+                      pos2 pos))))))
+
+(defun rpm-versioned-name-basename (string)
+  (nth-value 0 (parse-rpm-versioned-name string)))
+
+(defun rpm-versioned-name-version (string)
+  (nth-value 1 (parse-rpm-versioned-name string)))
+
+(defun parse-rpm-pathname (pathname)
+  (with-nesting ()
+    (let* ((pathname (pathname pathname))
+           (directory (pathname-directory-pathname pathname))
+           (type (pathname-type pathname))
+           (basename (pathname-name pathname))
+           (dotpos (position #\. basename :from-end t))))
+    (progn
+      (assert (equal type "rpm"))
+      (assert dotpos)
+      (assert (valid-rpm-architecture-component-p basename :start (1+ dotpos))))
+    (let ((architecture (subseq basename (1+ dotpos)))))
+    (multiple-value-bind (name version)
+        (parse-rpm-versioned-name basename :end dotpos))
+    (values directory name version architecture)))
+
+(defun rpm-pathname-packagename (pathname)
+  (nth-value 1 (parse-rpm-pathname pathname)))
+
+(defun rpm-pathname-version (pathname)
+  (nth-value 2 (parse-rpm-pathname pathname)))
+
+;; For version comparison, I followed
+;; https://twiki.cern.ch/twiki/bin/view/Main/RPMAndDebVersioning
+
+(defun parse-rpm-version-component (v)
+  "Given a version or release component of a RPM, parse it into a list
+of numbers and letters, e.g. \"0.99p7\" => (0 99 \"p\" 7)"
+  (loop :with r = () :with l = () :with len = (length v) :with i = 0
+    :while (< i len) :do
+    (flet ((handle-component (predicate push)
+             (when (and (< i len) (funcall predicate (char v i)))
+               (let ((j (or (position-if-not predicate v :start (1+ i)) len)))
+                 (when push (push (funcall push (subseq v i j)) l))
+                 (setf i j)))))
+      (handle-component #'ascii-letter-p #'parse-integer)
+      (handle-component #'ascii-digit-p #'identity)
+      (handle-component #'ascii-non-alphanumeric-p nil))
+    :finally (return (reverse l))))
+
+(defun compare-rpm-version-chunks (ch1 ch2)
+  "Given the first chunks of two respective version numbers,
+return the symbol < = > depending on which of predicates hold,
+or nil is none does"
+  (check-type ch1 (or integer string))
+  (check-type ch2 (or integer string))
+  (cond
+    ((and (integerp ch1) (integerp ch2))
+     (cond
+       ((< ch1 ch2) '<)
+       ((> ch1 ch2) '>)
+       (t '=)))
+    ;; RPM: integer block beats alphanumeric, so 1.4.1 > 1.4p8
+    ((integerp ch1)
+     '>)
+    ((integerp ch2)
+     '<)
+    (t
+     (cond
+       ((string< ch1 ch2) '<)
+       ((string> ch1 ch2) '>)
+       (t '=)))))
+
+(defun compare-rpm-version-components (v1 v2)
+  (let ((l1 (parse-rpm-version-component v1))
+        (l2 (parse-rpm-version-component v2)))
+    (loop :with l1 = (parse-rpm-version-component v1)
+      :with l2 = (parse-rpm-version-component v2)
+      :while (and l1 l2) :do
+      (let ((r (compare-rpm-version-chunks (pop l1) (pop l2))))
+        (ecase r
+          ((< > nil) (return r))
+          ((=) nil)))
+      :finally
+      (cond
+        (l1 (return '>))
+        (l2 (return '<))
+        (t (return '=))))))
+
+(defun parse-rpm-version (x)
+  (block nil
+    (cl-ppcre:register-groups-bind (epoch version release)
+        ("^(?:([0-9]+):)?([^-/~]+)(?:-([^-/~]+))?$" x) ;; also .. forbidden
+      (return (values (if (emptyp epoch) 0 (parse-integer epoch))
+                      version release)))
+    (error "bad rpm version ~S" x)))
+
+(defun compare-rpm-versions (v1 v2)
+  (multiple-value-bind (epoch1 version1 release1)
+      (parse-rpm-version v1)
+    (multiple-value-bind (epoch2 version2 release2)
+        (parse-rpm-version v2)
+      (cond
+        ((> epoch1 epoch2)
+         '>)
+        ((< epoch1 epoch2)
+         '<)
+        (t
+         (let ((r (compare-rpm-version-components version1 version2)))
+           (ecase r
+             ((< > nil) r)
+             ((=) (compare-rpm-version-components release1 release2)))))))))
+
+(defun rpm-version<= (v1 v2)
+  (ecase (compare-rpm-versions v1 v2)
+    ((< =) t)
+    ((>) nil)))
+
+(defun rpm-version>= (v1 v2)
+  (ecase (compare-rpm-versions v1 v2)
+    ((> =) t)
+    ((<) nil)))
+
+(defun rpm-version< (v1 v2)
+  (ecase (compare-rpm-versions v1 v2)
+    ((<) t)
+    ((> =) nil)))
+
+(defun rpm-version> (v1 v2)
+  (ecase (compare-rpm-versions v1 v2)
+    ((>) t)
+    ((< =) nil)))
+
+(defun rpm-version= (v1 v2)
+  (ecase (compare-rpm-versions v1 v2)
+    ((=) t)
+    ((< >) nil)))