drakclassic: rework to use perl-URPM directly instead of urpmi/urpmq.

This allows us to process all packages at once without having to
deal with package conflicts, so is both simpler and faster.

1 files changed, 166 insertions, 208 deletions

diff --git a/lib/MGA/DrakISO/BuildMedia.pm b/lib/MGA/DrakISO/BuildMedia.pm
index c1472c8..50849b8 100644
--- a/lib/MGA/DrakISO/BuildMedia.pm
+++ b/lib/MGA/DrakISO/BuildMedia.pm
@@ -28,6 +28,8 @@ use strict;
 use MDK::Common;
 use common;
 use URPM;
+use urpm;
+use urpm::media;
 
 use MGA::DrakISO::ClassicBuild;
 use MGA::DrakISO::Utils;
@@ -36,34 +38,30 @@ use MGA::DrakISO::Utils;
 # Global Variables
 ###############################################################################
 
-# This hash contains the currently enabled media in our urpmi chroot.
-# The hash key is the media name and the hash value is the media URL.
-my %media;
+# This object is used to access the urpmi database in our urpmi chroot.
+my $urpm;
 
-# This hash contains the currently selected packages. The hash key is
-# the package name and the hash value is the package class. A class of
-# 1 indicates a package that was explicitly selected, and a class of 2
-# indicates a package that was added as a dependency.
-my %package_class;
+# This hash contains all the packages available in the currently enabled media.
+# The hash key is the package name and the hash value is a hash containing the
+# following fields:
+#
+#   object      the URPM::Package object for the newest version/release
+#               of that package
+#
+#   class       undefined if the package is not selected
+#               set to 1 if the package was explicity selected
+#               set to 2 if the package was added as a dependency
+#
+my %package;
 
-# This hash contains the selected rpmsrate groups. The hash key is the
-# group name and the hash value is the threshold for selecting packages
-# in that group.
+# This hash contains the selected rpmsrate categories. The hash key is the
+# category name and the hash value is the threshold for selecting packages
+# in that category.
 my %group_threshold;
 
 # This array contains the list of packages the user has asked to be excluded.
 # Each array element is the name of a package.
-my @excluded_packages;
-
-# This hash contains the selected packages known to conflict with other
-# selected packages. It is optionally seeded from a list provided by the
-# user, and will be added to when we run a test installation and detect
-# conflicts. The hash key is the package name, and the hash value is just
-# set to 1.
-#
-# NOTE: This is only required because 'urpmq --requires-recursive' returns
-# an incomplete list of dependencies when there are package conflicts.
-my %known_conflicts;
+my @excluded;
 
 ###############################################################################
 # Main Code
@@ -72,14 +70,12 @@ my %known_conflicts;
 sub prepare_media {
     my ($build) = @_;
 
-    # Create a working directory to hold the output from urpmq/urpmi runs
-    # and any other log files we generate. Nothing in this directory is
-    # needed after we exit this function.
+    # Create a working directory to hold any temporary files we generate.
+    # Nothing in this directory is needed after we exit this function.
     mkdir_p($build->get_builddir('tmp'));
 
     prepare_urpmi_media($build);
-
-    get_known_conflicts($build);
+    get_available_packages($build);
 
     include_groups  ($build, $build->{group_include_lists});
     exclude_packages($build, $build->{group_exclude_lists});
@@ -91,9 +87,8 @@ sub prepare_media {
     exclude_packages($build, $build->{package_exclude_lists});
     update_dependencies($build);
 
-    handle_conflicts($build);
-
     build_installer_media($build);
+    check_installer_media($build);
 
     my $arch    = $build->{settings}{arch};
     my $version = $build->{settings}{version};
@@ -103,6 +98,10 @@ sub prepare_media {
 
     create_product_id($build, $arch_dir . '/product.id');
     create_index($build, $arch_dir . '/pkg-' . $version . '-' . $tag . '.idx');
+
+    undef $urpm;
+    undef %package;
+    undef @excluded;
 }
 
 ###############################################################################
@@ -112,6 +111,10 @@ sub prepare_media {
 sub prepare_urpmi_media {
     my ($build) = @_;
 
+    # This hash contains the enabled media in our urpmi chroot. The hash
+    # key is the media name and the hash value is the media URL.
+    my %media;
+
     # Get a list of the currently configured media in our urpmi root.
     my $list_file = $build->get_builddir('tmp') . '/media_url.lst';
     run_urpm($build, "urpmq", "--list-url > $list_file");
@@ -154,11 +157,30 @@ sub prepare_urpmi_media {
         next if $media_valid{$name};
         run_urpm($build, "urpmi.removemedia", $name);
     }
-
-    # Get a list of the available packages, for use later.
-    run_urpm($build, "urpmq", '--list > ' . $build->get_builddir('tmp') . '/pkg-available.lst');
 }            
 
+sub get_available_packages {
+    my ($build) = @_;
+
+    $urpm = urpm->new;
+
+    urpm::set_files($urpm, $build->get_system_root);
+    urpm::get_global_options($urpm);
+
+    $urpm->{info} = sub { };
+    $urpm->{log}  = sub { };
+
+    urpm::media::configure($urpm);
+
+    $urpm->traverse(sub {
+        my ($pkg) = @_;
+        my $name = $pkg->name();
+        if (!defined $package{$name} || $pkg->compare_pkg($package{$name}{object}) > 0) {
+            $package{$name}{object} = $pkg;
+        }
+    });
+}
+
 ###############################################################################
 # Package Group Selection
 ###############################################################################
@@ -178,10 +200,11 @@ sub include_groups {
             my ($name, $threshold) = split(' ', $entry);
             next if !$name; # skip pure comment lines
             if ($name =~ /^task-/) {
-                $package_class{$name} = 1;
+                $package{$name} or die "ERROR: $name is not available in the urpmi media\n";
+                $package{$name}{class} = 1;
             } else {
                 $threshold >= 1 && $threshold <= 6
-                  or die "Invalid threshold for $name on line $line_number of '$file'\n";
+                  or die "ERROR: invalid threshold for $name on line $line_number of '$file'\n";
                 $group_threshold{$name} = $threshold;
             }
         }
@@ -293,11 +316,15 @@ sub add_rated_packages {
             # Skip any packages that don't match the user's requirements.
             next if !any { defined $group_threshold{$_} && $rating >= $group_threshold{$_} } @flags;
 
-            # Add the package to our selected package list, setting the
-            # package class to 1 to indicate this is an explicitly selected
-            # package.
-            foreach my $pkg (split ' ', $remaining) {
-                $package_class{$pkg} = 1;
+            # For each package, set the package class to 1 to indicate it is
+            # an explicitly selected package.
+            foreach my $name (split ' ', $remaining) {
+                if (defined $package{$name}) {
+                    $package{$name}{class} = 1;
+                } else {
+                    # tolerate errors in the rpmsrate file
+                    print "INFO <rpmsrate>: $name is not available in the urpmi media\n";
+                }
             }
         }
     }
@@ -337,139 +364,49 @@ sub update_dependencies {
     print "Calculating dependencies\n" if $::verbose;
 
     # Remove any existing dependencies.
-    my @dependencies = grep { $package_class{$_} == 2 } keys %package_class;
-    delete @package_class{@dependencies};
+    my @dependencies = grep { $package{$_}{class} == 2 } keys %package;
+    delete $package{$_}{class} foreach @dependencies;
 
     # Calculate the dependencies and update the package list.
-    my @packages = keys %package_class;
-    my $skip_list = join(',', keys %known_conflicts, @excluded_packages);
-    add_dependencies_to_selected_packages($build, \@packages, $skip_list);
-}
-
-sub add_dependencies_to_selected_packages {
-    my ($build, $packages, $o_skip_list) = @_;
-
-    # Use urpmq to generate a new list of dependencies. Note that this list
-    # will include the original package list.
-    my $options = '--requires-recursive --no-recommends';
-    if ($o_skip_list) {
-        $options .= ' --skip ' . $o_skip_list;
-    }
-    my $list_file = $build->get_builddir('tmp') . '/packages.lst';
-    run_urpm($build, 'urpmq', join(' ', $options, @$packages, '>', $list_file));
-
-    # Add the new dependencies to our selected package list, setting the
-    # package class to 2 to indicate these are implicitly selected packages.
-    update_package_selection($build, $list_file, \&add_to_selected_packages, 2);
-    report_package_count();
-}
-
-###############################################################################
-# Package Conflict Handling
-###############################################################################
-
-sub get_known_conflicts {
-    my ($build) = @_;
-
-    my $arch = $build->{settings}{arch};
-
-    my $file = $build->{known_conflicts};
-    -f $file or return;
-
-    print "Reading known conflicts from $file\n" if $::verbose;
-    foreach my $line (cat_($file)) {
-        my ($data, $comment) = split('#', $line);
-        next if !$data; # skip pure comment lines
-        my ($head, $tail) = split(':', $data, 2);
-        if ($head && $tail) {
-            next if $head !~ /\s*$arch\s*/;
-            $data = $tail;
-        }
-        my @packages = split(' ', $data);
-        foreach my $pkg (@packages) {
-            $known_conflicts{$pkg} = 1;
-        }
-    }
-}
-
-sub handle_conflicts {
-    my ($build) = @_;
-
-    # Remove any existing dependencies.
-    my @dependencies = grep { $package_class{$_} == 2 } keys %package_class;
-    delete @package_class{@dependencies};
-
-    # Remove any known conflicts
-    my @conflicts = grep { $known_conflicts{$_} } keys %package_class;
-    delete @package_class{@conflicts};
-
-    my @packages = keys %package_class;
-    my $log_file = $build->get_builddir('tmp') . '/test-install.log';
-    my $skip_list = join(',', keys %known_conflicts, @excluded_packages);
-    my $error = check_for_conflicts($build, \@packages, $log_file, $skip_list);
-
-    return if !($error || %known_conflicts);
-
-    if ($error) {
-        print "Attempting to resolve package conflicts\n" if $::verbose;
-        my $tries = 0;
-        do {
-            if (++$tries > 5) {
-                die "ERROR: there are package conflicts or unsatisfied dependencies I can't resolve.\n"
-                  . "       See $log_file for details.\n";
-            }
-
-            my $conflicts_file = $build->get_builddir('tmp') . '/conflicts.lst';
-            system("grep 'conflicts\\\|unsatisfied' $log_file | awk '{ print \$1; }' | sort -u > $conflicts_file");
-
-            foreach my $pkg (cat_($conflicts_file)) {
-                chomp($pkg);
-                $pkg =~ s/^(\S+)-\d+(\.\d+)*-\d+\.mga\d+(\.\w+)+$/$1/;
-                print "  $pkg\n" if $::verbose > 1;
-                delete $package_class{$pkg};
-                $known_conflicts{$pkg} = 1;
-            }
-            @packages = keys %package_class;
-            $log_file = $build->get_builddir('tmp') . '/test-install-' . $tries . '.log';
-            $skip_list = join(',', keys %known_conflicts, @excluded_packages);
-        } while check_for_conflicts($build, \@packages, $log_file, $skip_list);
-        print "NOTE: some package conflicts were automatically resolved.\n";
-    }
-
-    update_dependencies($build);
-
-    my $errors = 0;
-    $skip_list = join(',', @excluded_packages);
-    foreach my $pkg (keys %known_conflicts) {
-        $error = check_for_conflicts($build, [ $pkg ], $log_file);
-        if ($error) {
-            print "ERROR: the $pkg package is not installable because:\n";
-            print "-- messages from urpmi ----------------------------\n";
-            system("cat $log_file");
-            print "---------------------------------------------------\n";
-            $errors++;
-        } else {
-            $package_class{$pkg} = 1;
-            add_dependencies_to_selected_packages($build, [ $pkg ], $skip_list);
+    my @search_list = grep { $package{$_}{class} == 1 } keys %package;
+    while (@search_list) {
+        foreach my $name (@search_list) {
+            my $pkg = $package{$name}{object};
+            my $parent_name = $pkg->name();
+            my @requires = $pkg->requires_nosense();
+            $urpm->traverse_tag('whatprovides', \@requires, sub {
+                my ($pkg) = @_;
+                my $name = $pkg->name();
+                # kernel and kmod packages embed the kernel version and release
+                # in the package name (and always have a version-release of 1-1)
+                # so we have to do a bit of fancy footwork here to ensure we
+                # only get the latest version of each package. Each kernel or
+                # kmod package has a 'latest' counterpart that just requires
+                # the latest version of that package. So unless we are
+                # satisfying the requirement of the 'latest' counterpart,
+                # we just change the provider name to that of the counterpart,
+                # which avoids pulling in any earlier versions of the package.
+                # Sadly the naming convention is different for kernel and for
+                # kmod packages, so we need to handle two variants.
+                if ($name =~ /^kernel-/) {
+                    my $latest_name = $name =~ s/-\d.*-\d+\.mga\d+/-latest/r;
+                    $name = $latest_name if $parent_name ne $latest_name;
+                }
+                if ($name =~ /-kernel-/) {
+                    my $latest_name = $name =~ s/-\d.*-(.*)-\d+\.mga\d+/-$1-latest/r;
+                    $name = $latest_name if $parent_name ne $latest_name;
+                }
+                return if member($name, @excluded);
+                $package{$name} or die "ERROR: $name is not available in the urpmi media\n";
+                $package{$name}{class} = 3 if !defined $package{$name}{class};
+            });
         }
+        # Any dependencies we haven't seen before need to be checked
+        # for further dependencies.
+        @search_list = grep { $package{$_}{class} == 3 } keys %package;
+        $package{$_}{class} = 2 foreach @search_list;
     }
-    if ($errors) {
-        $::force or die "ERROR: not all conflicts or dependencies could be resolved.\n";
-        print "NOTE: **** continuing due to --force option           ****\n";
-        print "NOTE: **** this ISO is not suitable for final release ****\n";
-    }
-}
-
-sub check_for_conflicts {
-    my ($build, $packages, $log_file, $o_skip_list) = @_;
-
-    my $what = @$packages == 1 ? $$packages[0] : 'all packages';
-    print "Checking for package conflicts and unsatisfied dependencies [$what]\n" if $::verbose > 1;
-    my $options = '-q --test --auto --no-recommends --ignoresize --no-verify-rpm';
-    if ($o_skip_list) {
-        $options .= ' --skip ' . $o_skip_list;
-    }
-    run_urpm($build, 'urpmi', join(' ', $options, @$packages, '>', $log_file), 'not-fatal');
+    report_package_count();
 }
 
 ###############################################################################
@@ -491,21 +428,21 @@ sub build_installer_media {
 
     print "  adding RPMs\n" if $::verbose > 1;
 
-    # Use urpmq to list the full source paths to the selected RPMs.
-    my @packages = keys %package_class;
-    my $rpms_file = $build->get_builddir('tmp') . '/rpms.lst';
-    run_urpm($build, 'urpmq', join(' ', '--newest --sources', @packages, '>', $rpms_file));
-
-    # Add them to the appropriate media directory. Note that in the
-    # installation media there is only a single medium for each class
-    # class, so we ignore the source media type.
-    foreach my $src_file (cat_($rpms_file)) {
-        chomp($src_file);
-        my @path_parts = split('/', $src_file);
+    # Find the URLs for the selected RPMs and add them to the appropriate
+    # media directory. Note that in the installation media there is only a
+    # single medium for each class, so we ignore the source media type.
+    my @packages = grep { defined $package{$_}{class} } keys %package;
+    foreach my $name (@packages) {
+        my $pkg = $package{$name}{object};
+        my $id = $pkg->id();
+        my @medium = grep { $id >= $_->{start} && $id <= $_->{end} } @{$urpm->{media}}
+          or die "ERROR: failed to identify the medium containing the $name package\n";
+        my $src_path = $medium[0]->{url} . '/' . $pkg->filename();
+        my @path_parts = split('/', $src_path);
         my $class = $path_parts[-3];
         my $name  = $path_parts[-1];
-        my $dst_file = $media_dir . $class . '/' . $name;
-        copy_or_link($src_file, $dst_file);
+        my $dst_path = $media_dir . $class . '/' . $name;
+        copy_or_link($src_path, $dst_path);
     }
 
     print "  generating media info\n" if $::verbose > 1;
@@ -562,6 +499,25 @@ sub create_media_cfg {
     close $f;
 }
 
+sub check_installer_media {
+    my ($build) = @_;
+
+    print "Checking installer media\n" if $::verbose;
+
+    my $arch = $build->{settings}{arch};
+    my $media_dir = $build->get_builddir('files/' . $arch . '/media/');
+    my $log_file = $build->get_builddir('tmp') . '/rpmcheck.log';
+    system("zcat -q $media_dir/*/media_info/hdlist.cz | rpmcheck -explain -failures > $log_file") == 0
+      or die "ERROR: failed to run rpmcheck\n";
+
+    if (system("grep -q FAILED $log_file") == 0) {
+        system("cat $log_file");
+        $::force or die "ERROR: some package dependencies are not satisfied\n";
+        print "NOTE: **** continuing due to --force option           ****\n";
+        print "NOTE: **** this ISO is not suitable for final release ****\n";
+    }
+}
+
 ###############################################################################
 # Miscellaneous File Creation
 ###############################################################################
@@ -627,37 +583,39 @@ sub run_urpm {
 
     my $urpmi_root = '--urpmi-root ' . $build->get_system_root;
 
-    # NOTE: don't try to create the command line by embedding variables in a double-quoted
-    # string. If $parameters is very large, it causes a buffer overrun.
-    my $error = system(join(' ', 'LC_ALL=C sudo', $cmd, $urpmi_root, $parameters));
+    my $error = system("LC_ALL=C sudo $cmd $urpmi_root $parameters");
     $error == 0 || $o_not_fatal or die "ERROR: $cmd command failed\n";
     $error;
 }
 
 sub add_to_selected_packages {
-    my ($source, $pkg, $class, $o_warn) = @_;
+    my ($source, $name, $class, $o_warn) = @_;
 
-    if ($package_class{$pkg} == 1) {
-        print "INFO <$source>: $pkg is already explictly selected\n" if $o_warn;
-    } elsif ($package_class{$pkg} == 2) {
-        print "INFO <$source>: $pkg is already implictly selected\n" if $o_warn;
-        $package_class{$pkg} = $class;
+    $package{$name} or die "ERROR <$source>: $name is not available in the urpmi media\n";
+
+    if ($package{$name}{class} == 1) {
+        print "INFO <$source>: $name is already explictly selected\n" if $o_warn;
+    } elsif ($package{$name}{class} == 2) {
+        print "INFO <$source>: $name is already implictly selected\n" if $o_warn;
+        $package{$name}{class} = $class;
     } else {
-        print "INFO <$source>: Selecting package $pkg\n" if $::verbose > 2;
-        $package_class{$pkg} = $class;
+        print "INFO <$source>: selecting package $name\n" if $::verbose > 2;
+        $package{$name}{class} = $class;
     }
 }
 
 sub remove_from_selected_packages {
-    my ($source, $pkg, $class, $o_warn) = @_;
+    my ($source, $name, $class, $o_warn) = @_;
+
+    $package{$name} or die "ERROR <$source>: $name is not available in the urpmi media\n";
 
-    if (defined $package_class{$pkg}) {
-        print "INFO <$source>: Deselecting package $pkg\n" if $::verbose > 2;
-        delete $package_class{$pkg};
+    if (defined $package{$name}{class}) {
+        print "INFO <$source>: deselecting package $name\n" if $::verbose > 2;
+        delete $package{$name}{class};
     } else {
-        print "INFO <$source>: $pkg is not currently selected\n" if $o_warn;
+        print "INFO <$source>: $name is not currently selected\n" if $o_warn;
     }
-    push @excluded_packages, $pkg;
+    push @excluded, $name;
 }
 
 sub update_package_selection {
@@ -676,30 +634,30 @@ sub update_package_selection {
             $data = $tail;
         }
         my @packages = split(' ', $data);
-        foreach my $pkg (@packages) {
-            my @alternatives = split('\|', $pkg);
+        foreach my $name (@packages) {
+            my @alternatives = split('\|', $name);
             if (@alternatives > 1) {
                 foreach my $alternative (@alternatives) {
                     $action->($file, $alternative, $class);
                 }
-            } elsif ($pkg =~ /[?*]/) {
-                print "  expanding package $pkg\n" if $::verbose > 1;
-                $pkg =~ s/\?/.?/g;
-                $pkg =~ s/\*/.*/g;
-                my $available_list = $build->get_builddir('tmp') . '/pkg-available.lst';
-                my @candidates = split('\n', `LC_ALL=C grep '^$pkg\$' $available_list`);
+            } elsif ($name =~ /[?*]/) {
+                print "  expanding $name\n" if $::verbose > 1;
+                $name =~ s/\?/.?/g;
+                $name =~ s/\*/.*/g;
+                my @candidates = grep { $_ =~ /^$name$/ } keys %package;
                 foreach (@candidates) {
                     $action->($file, $_, $class) ;
                 }
             } else {
-                $action->($file, $pkg, $class, $o_warn);
+                $action->($file, $name, $class, $o_warn);
             }
         }
     }
 }
 
 sub report_package_count() {
-    print "  package count = ", scalar keys %package_class, "\n" if $::verbose > 1;
+    my @packages = grep { defined $package{$_}{class} } keys %package;
+    print "  package count = ", scalar @packages, "\n" if $::verbose > 1;
 }
 
 1;