Libguestfs - Mar 2014 - [PATCH] supermin: dpkg: Handle multiarch setups correctly

---
 src/dpkg.ml | 39 +++++++++++++++++++++++++--------------
 1 file changed, 25 insertions(+), 14 deletions(-)

diff --git a/src/dpkg.ml b/src/dpkg.ml
index c0d3292..2662465 100644
--- a/src/dpkg.ml
+++ b/src/dpkg.ml
@@ -29,6 +29,10 @@ let dpkg_detect ()      Config.apt_get <>
"no" &&
     file_exists "/etc/debian_version"
 
+let dpkg_primary_arch +  let cmd = sprintf "%s --print-architecture"
Config.dpkg in
+  List.hd (run_command_get_lines cmd)
+
 let settings = ref no_settings
 
 let dpkg_init s = settings := s
@@ -58,17 +62,20 @@ let dpkg_package_of_string str          (quote str) in
     let lines = run_command_get_lines cmd in
 
-    (* AFAIK on Debian only a single package with a particular name
-     * may be installed (ie no multilib etc crap).  Hence:
-     *)
-    if List.length lines <> 1 then assert false;
-    let line = List.hd lines in
-    let line = string_split " " line in
-    match line with
-    | [ name; version; arch ] ->
-      assert (version <> "");
-      { name = name; version = version; arch = arch }
-    | xs -> assert false
+    let pkgs = List.map (
+      fun line ->
+        let line = string_split " " line in
+        match line with
+        | [ name; version; arch ] ->
+          assert (version <> "");
+          { name = name; version = version; arch = arch }
+        | xs -> assert false)
+      lines in
+
+    (* On multiarch setups, only consider the primary architecture *)
+    List.find
+      (fun pkg -> pkg.arch = dpkg_primary_arch || pkg.arch =
"all")
+      pkgs
 
   (* Check if a package is installed. *)
   and check_dpkg_installed name @@ -110,6 +117,10 @@ let dpkg_package_name pkg 
let dpkg = dpkg_of_pkg pkg in
   dpkg.name
 
+let dpkg_package_name_arch pkg +  let dpkg = dpkg_of_pkg pkg in
+  sprintf "%s:%s" dpkg.name dpkg.arch
+
 let dpkg_get_package_database_mtime ()    (lstat
"/var/lib/dpkg/status").st_mtime
 
@@ -137,9 +148,9 @@ let dpkg_get_all_requires pkgs  
 let dpkg_get_all_files pkgs    let cmd -    sprintf "%s -L %s | grep
'^/' | grep -v '^/.$' | sort -u"
-      Config.dpkg
-      (quoted_list (List.map dpkg_package_name
+    sprintf "%s --listfiles %s | grep '^/' | grep -v
'^/.$' | sort -u"
+      Config.dpkg_query
+      (quoted_list (List.map dpkg_package_name_arch
 		      (PackageSet.elements pkgs))) in
   let lines = run_command_get_lines cmd in
   List.map (
-- 
1.9.0

On Tue, Mar 04, 2014 at 06:35:27PM +0100, Hilko Bengen
wrote:
> ---
>  src/dpkg.ml | 39 +++++++++++++++++++++++++--------------
>  1 file changed, 25 insertions(+), 14 deletions(-)
> 
> diff --git a/src/dpkg.ml b/src/dpkg.ml
> index c0d3292..2662465 100644
> --- a/src/dpkg.ml
> +++ b/src/dpkg.ml
> @@ -29,6 +29,10 @@ let dpkg_detect () >      Config.apt_get <>
"no" &&
>      file_exists "/etc/debian_version"
>  
> +let dpkg_primary_arch > +  let cmd = sprintf "%s
--print-architecture" Config.dpkg in
> +  List.hd (run_command_get_lines cmd)
While this is not wrong, if the command returns no lines for some
reason it will cause a mysterious exception to escape which would be
hard to track down.  Users would have to know to set an environment
variable to enable stack traces.  Thus it is better to write this:

  let cmd = ... in
  let lines = run_command_get_lines cmd in
  match lines with
  | [] ->
    eprintf "supermin: dpkg: expecting %s to return some output\n"
cmd;
    exit 1
  | arch :: _ -> arch
> +    (* On multiarch setups, only consider the primary architecture *)
> +    List.find
> +      (fun pkg -> pkg.arch = dpkg_primary_arch || pkg.arch =
"all")
> +      pkgs
Again, this would let a mysterious exception escape if no matching
match is found.  Since this is an internal error, I guess we don't
need an error mesage, but using 'assert false' will cause the file &
line number to be printed, so something like this would be better:

  try
    List.find (fun pkg -> .....) pkgs
  with
    Not_found -> assert false

ACK with those changes.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
virt-top is 'top' for virtual machines.  Tiny program with many
powerful monitoring features, net stats, disk stats, logging, etc.
http://people.redhat.com/~rjones/virt-top