Libguestfs - Apr 2019 - [supermin PATCH 5/5] utils: remove unused 'compare_architecture' function

This patch series fixes the way supermin sorts the list of installed
packages when resolving a name, picking the right package for the host
architecture.

Pino Toscano (5):
  rpm: do not unpack parameters
  rpm: fix version comparison
  rpm: query the RPM architecture
  rpm: fix package sorting (RHBZ#1696822)
  utils: remove unused 'compare_architecture' function

 src/librpm-c.c | 10 ++++++++++
 src/librpm.ml  |  1 +
 src/librpm.mli |  3 +++
 src/ph_rpm.ml  | 44 ++++++++++++++++++++++++++++++++++++++------
 src/utils.ml   | 27 ---------------------------
 src/utils.mli  |  3 ---
 6 files changed, 52 insertions(+), 36 deletions(-)

-- 
2.20.1

They will be used as parameters again soon.

This has no behaviour changes.
---
 src/ph_rpm.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/ph_rpm.ml b/src/ph_rpm.ml
index 3ff5c94..6769e7b 100644
--- a/src/ph_rpm.ml
+++ b/src/ph_rpm.ml
@@ -144,10 +144,10 @@ let rpm_package_of_string str       * interested in the
highest version with the best
      * architecture.
      *)
-    let cmp { version = v1; arch = a1 } { version = v2; arch = a2 } -      let
i = rpm_vercmp v2 v1 in
+    let cmp pkg1 pkg2 +      let i = rpm_vercmp pkg2.version pkg1.version in
       if i <> 0 then i
-      else compare_architecture a2 a1
+      else compare_architecture pkg2.arch pkg1.arch
     in
     let rpms = List.sort cmp rpms in
     List.hd rpms
-- 
2.20.1

When comparing two RPMs, also the epoch, and the release must be taken
into account.  Hence, add a new helper to get the EVR string of a
package, and use it when sorting each list of installed packages.

The mapping is done to avoid recreating the EVR strings at every
comparison.
---
 src/ph_rpm.ml | 29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/src/ph_rpm.ml b/src/ph_rpm.ml
index 6769e7b..a8bcf7c 100644
--- a/src/ph_rpm.ml
+++ b/src/ph_rpm.ml
@@ -136,21 +136,44 @@ let rpm_of_pkg, pkg_of_rpm = get_memo_functions ()
 (* Memo of rpm_package_of_string. *)
 let rpmh = Hashtbl.create 13
 
+let rpm_to_evr_string rpm +  (* In RPM < 4.11 query commands that use the
epoch number in the
+   * package name did not work.
+   *
+   * For example:
+   * RHEL 6 (rpm 4.8.0):
+   *   $ rpm -q tar-2:1.23-11.el6.x86_64
+   *   package tar-2:1.23-11.el6.x86_64 is not installed
+   * Fedora 20 (rpm 4.11.2):
+   *   $ rpm -q tar-2:1.26-30.fc20.x86_64
+   *   tar-1.26-30.fc20.x86_64
+   *
+   *)
+  let is_rpm_lt_4_11 +    !rpm_major < 4 || (!rpm_major = 4 &&
!rpm_minor < 11) in
+
+  if is_rpm_lt_4_11 || rpm.epoch = 0 then
+    sprintf "%s-%s" rpm.version rpm.release
+  else
+    sprintf "%d:%s-%s"
+      rpm.epoch rpm.version rpm.release
+
 let rpm_package_of_string str    let query rpm      let rpms = Array.to_list
(rpm_installed (get_rpm ()) rpm) in
+    let rpms = List.map (fun rpm -> (rpm, rpm_to_evr_string rpm)) rpms in
     (* RPM will return multiple hits when either multiple versions or
      * multiple arches are installed at the same time.  We are only
      * interested in the highest version with the best
      * architecture.
      *)
-    let cmp pkg1 pkg2 -      let i = rpm_vercmp pkg2.version pkg1.version in
+    let cmp (pkg1, evr1) (pkg2, evr2) +      let i = rpm_vercmp evr2 evr2 in
       if i <> 0 then i
       else compare_architecture pkg2.arch pkg1.arch
     in
     let rpms = List.sort cmp rpms in
-    List.hd rpms
+    fst (List.hd rpms)
   in
 
   try
-- 
2.20.1

Query the RPM library for the current architecture of RPM, storing it
for later use, and printing it to the debug output.
---
 src/librpm-c.c | 10 ++++++++++
 src/librpm.ml  |  1 +
 src/librpm.mli |  3 +++
 src/ph_rpm.ml  |  8 ++++++--
 4 files changed, 20 insertions(+), 2 deletions(-)

diff --git a/src/librpm-c.c b/src/librpm-c.c
index 75ca4d7..2e2f048 100644
--- a/src/librpm-c.c
+++ b/src/librpm-c.c
@@ -132,6 +132,16 @@ supermin_rpm_vercmp (value av, value bv)
   return Val_int (rpmvercmp (String_val (av), String_val (bv)));
 }
 
+value
+supermin_rpm_get_arch (value unit)
+{
+  const char *str;
+
+  rpmGetArchInfo (&str, NULL);
+
+  return caml_copy_string (str);
+}
+
 value
 supermin_rpm_open (value debugv)
 {
diff --git a/src/librpm.ml b/src/librpm.ml
index b6f9ff8..c987e21 100644
--- a/src/librpm.ml
+++ b/src/librpm.ml
@@ -20,6 +20,7 @@ external rpm_is_available : unit -> bool =
"supermin_rpm_is_available" "noalloc"
 
 external rpm_version : unit -> string = "supermin_rpm_version"
 external rpm_vercmp : string -> string -> int =
"supermin_rpm_vercmp" "noalloc"
+external rpm_get_arch : unit -> string = "supermin_rpm_get_arch"
 
 type t
 
diff --git a/src/librpm.mli b/src/librpm.mli
index 53b4b2c..c0d7bdf 100644
--- a/src/librpm.mli
+++ b/src/librpm.mli
@@ -28,6 +28,9 @@ val rpm_version : unit -> string
 val rpm_vercmp : string -> string -> int
 (** Compare two RPM version strings using RPM version compare rules. *)
 
+val rpm_get_arch : unit -> string
+(** The current main RPM architecture. *)
+
 type t
 (** The librpm handle. *)
 
diff --git a/src/ph_rpm.ml b/src/ph_rpm.ml
index a8bcf7c..e27d226 100644
--- a/src/ph_rpm.ml
+++ b/src/ph_rpm.ml
@@ -64,7 +64,7 @@ let ibm_powerkvm_detect ()      with Unix_error _ -> false
 
 let settings = ref no_settings
-let rpm_major, rpm_minor = ref 0, ref 0
+let rpm_major, rpm_minor, rpm_arch = ref 0, ref 0, ref ""
 let zypper_major, zypper_minor, zypper_patch = ref 0, ref 0, ref 0
 let t = ref None
 
@@ -93,7 +93,11 @@ let rec rpm_init s    if !settings.debug >= 1 then
     printf "supermin: rpm: detected RPM version %d.%d\n" major minor;
 
-  t := Some (rpm_open ~debug:!settings.debug)
+  t := Some (rpm_open ~debug:!settings.debug);
+
+  rpm_arch := rpm_get_arch ();
+  if !settings.debug >= 1 then
+    printf "supermin: rpm: detected RPM architecture %s\n" !rpm_arch
 
 and opensuse_init s    rpm_init s;
-- 
2.20.1

The sorting algorithm for RPMs sorted this way:
- before the packages with the higher versions
- among the packages with the version version, first noarch packages,
  then 64bit packages, and then 32bit packages
This was broken in at least two ways:
- the higher installed version may not be of the same host architecture
- if the host architecture is 32bit, and there is a 64bit package of a
  32bit installed one, the 64bit version was preferred

Instead:
- first sort by architecture, preferring noarch packages, and
  packages of the host architecture
- then sort by version

This way, the higher version of the host architecture is preferred,
otherwise the higher version of any foreign architecture is chosen.
---
 src/ph_rpm.ml | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/src/ph_rpm.ml b/src/ph_rpm.ml
index e27d226..dbe3bda 100644
--- a/src/ph_rpm.ml
+++ b/src/ph_rpm.ml
@@ -172,9 +172,14 @@ let rpm_package_of_string str       * architecture.
      *)
     let cmp (pkg1, evr1) (pkg2, evr2) -      let i = rpm_vercmp evr2 evr2 in
+      let weight_of_arch = function
+        | "noarch" -> 100
+        | a when a = !rpm_arch -> 50
+        | _ -> 0
+      in
+      let i = compare (weight_of_arch pkg2.arch) (weight_of_arch pkg1.arch) in
       if i <> 0 then i
-      else compare_architecture pkg2.arch pkg1.arch
+      else rpm_vercmp evr2 evr2
     in
     let rpms = List.sort cmp rpms in
     fst (List.hd rpms)
-- 
2.20.1

This was used only in the RPM package handler.
---
 src/utils.ml  | 27 ---------------------------
 src/utils.mli |  3 ---
 2 files changed, 30 deletions(-)

diff --git a/src/utils.ml b/src/utils.ml
index f85418f..b25df88 100644
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -172,33 +172,6 @@ and split_version = function
       ) in
     first :: split_version rest
 
-let compare_architecture a1 a2 -  let index_of_architecture = function
-    | "noarch" | "all" -> 100
-    | "i386" | "i486" | "i586" | "i686"
| "x86_32" | "x86-32" -> 32
-    | "x86_64" | "x86-64" | "amd64" -> 64
-    | "armel" | "armhf" -> 32
-    | "aarch64" -> 64
-    | a when string_prefix "armv5" a -> 32
-    | a when string_prefix "armv6" a -> 32
-    | a when string_prefix "armv7" a -> 32
-    | a when string_prefix "armv8" a -> 64
-    | "hppa" | "parisc" -> 32
-    | "hppa64" | "parisc64" -> 64
-    | "ppc" | "ppc32" -> 32
-    | a when string_prefix "ppc64" a -> 64
-    | "sparc" | "sparc32" -> 32
-    | "sparc64" -> 64
-    | "ia64" -> 64
-    | "s390" -> 32
-    | "s390x" -> 64
-    | "alpha" -> 64
-    | a ->
-      error "missing support for architecture '%s'\nIt may need to
be added to supermin."
-        a
-  in
-  compare (index_of_architecture a1) (index_of_architecture a2)
-
 (* Parse a size field, eg. "10G". *)
 let parse_size    let const_re = Str.regexp
"^\\([.0-9]+\\)\\([bKMG]\\)$" in
diff --git a/src/utils.mli b/src/utils.mli
index 7837dbb..b86586a 100644
--- a/src/utils.mli
+++ b/src/utils.mli
@@ -86,9 +86,6 @@ val filter_map : ('a -> 'b option) -> 'a
list -> 'b list
 val compare_version : string -> string -> int
   (** Compare two version-like strings. *)
 
-val compare_architecture : string -> string -> int
-  (** Compare two architecture strings. *)
-
 val parse_size : string -> int64
 (** Parse a size field, eg. [10G] *)
 
-- 
2.20.1

ACK series, thanks.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
Fedora Windows cross-compiler. Compile Windows programs, test, and
build Windows installers. Over 100 libraries supported.
http://fedoraproject.org/wiki/MinGW