path: root/lib/MGA/DrakISO/BuildMedia.pm

# Copyright (C) 2017-2018 Mageia
#                    Martin Whitaker <mageia@martin-whitaker.me.uk>
#
# 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 2, 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, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA.

# SYNOPSIS
# --------
# This package provides a function to create the urpmi media that will be used
# by the classical installer and to generate the product.id and package.lst
# files that will be included in the installer ISO image.

package MGA::DrakISO::BuildMedia;

use strict;

use MDK::Common;
use URPM;
use urpm;
use urpm::media;

use MGA::DrakISO::ClassicBuild;
use MGA::DrakISO::Utils;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(prepare_media);

###############################################################################
# Global Variables
###############################################################################

# This object is used to access the urpmi database in our urpmi chroot.
my $urpm;

# 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:
#
#   base_pkg    a reference to the URPM::Package object for the newest
#               version/release of that package in the base media
#
#   best_pkg    a reference to the URPM::Package object for the newest
#               version/release of that package in all media
#
#   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 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;

###############################################################################
# Main Code
###############################################################################

# This is the top-level function called to prepare the installation media
# and other files required by the installer. It is independent of any other
# preparatory step.
#
sub prepare_media {
    my ($build) = @_;

    # 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_build_dir('tmp'));

    read_repo_product_id($build);

    prepare_urpmi_media($build);
    get_available_packages($build);

    include_groups  ($build, $build->{group_include_lists});
    exclude_packages($build, $build->{group_exclude_lists});
    update_dependencies();

    include_packages($build, $build->{package_include_lists});
    update_dependencies();

    exclude_packages($build, $build->{package_exclude_lists});
    update_dependencies();

    build_installer_media($build);

    check_installer_media($build, ${$build->{urpmi_media}{enabled_sections}}[0]);
    check_installer_media($build, '*');

    my $arch_dir = $build->get_build_dir('files/' . $build->{settings}{arch});

    create_product_id($build, $arch_dir . '/product.id');

    my $package_idx = $arch_dir . '/package.idx';

    create_index($build, $package_idx);
    copy_or_link($package_idx, $build->get_build_dir('dist/') . $build->get_name . '.idx');

    # We don't expect this function to be called twice, but clean up
    # nonetheless.
    undef $urpm;
    undef %package;
    undef @excluded;
}

###############################################################################
# URPM Setup
###############################################################################

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_build_dir('tmp') . '/media_url.lst';
    run_urpm($build, "urpmq", "--list-url > $list_file");
    foreach my $line (cat_($list_file)) {
        chomp($line);
        my ($name, $url) = split(' ', $line);
        if ($name) {
            $media{$name} = $url;
        }
    }

    # Now check the list of media specified by the user.
    my %media_valid;
    my $repo = $build->{settings}{repository};
    my $arch = $build->{settings}{arch};
    foreach my $section (@{$build->{urpmi_media}{enabled_sections}}) {
        foreach my $subsection (@{$build->{urpmi_media}{enabled_subsections}}) {
            my $name = $section . '-' . $subsection;
            my $url = $repo . '/' . $arch . '/media/' . $section . '/' . $subsection;
            if ($media{$name} eq $url) {
                # This medium already exists, so we just need to make sure it
                # is up to date.
                run_urpm($build, "urpmi.update", $name);
            } else {
                if ($media{$name}) {
                    # A medium with this name but a different url already exists.
                    # We need to remove it before we can add the new one.
                    run_urpm($build, "urpmi.removemedia", $name);
                }
                # Add the requested medium.
                run_urpm($build, "urpmi.addmedia", "--probe-synthesis $name $url");
                $media{$name} = $url;
            }
            $media_valid{$name} = 1;
        }
    }

    # Remove any media not in the user's list.
    foreach my $name (keys %media) {
        next if $media_valid{$name};
        run_urpm($build, "urpmi.removemedia", $name);
    }
}            

sub get_available_packages {
    my ($build) = @_;

    $urpm = urpm->new;

    urpm::set_files($urpm, $build->get_chroot_dir);
    urpm::get_global_options($urpm);

    $urpm->{info} = sub {};
    $urpm->{log}  = sub {};

    urpm::media::configure($urpm);

    my $base_section = ${$build->{urpmi_media}{enabled_sections}}[0];

    $urpm->traverse(sub {
        my ($pkg) = @_;
        my $name = $pkg->name;
        my @medium = grep { $pkg->id >= $_->{start} && $pkg->id <= $_->{end} } @{$urpm->{media}}
          or die "ERROR: failed to identify the medium containing the $name package\n";
        if (!defined $package{$name} || $pkg->compare_pkg($package{$name}{best_pkg}) > 0) {
            $package{$name}{best_pkg} = $pkg;
        }
        return if $medium[0]->{name} !~ /^$base_section/;
        if (!defined $package{$name}{base_pkg} || $pkg->compare_pkg($package{$name}{base_pkg}) > 0) {
            $package{$name}{base_pkg} = $pkg;
        }
    });
    
}

###############################################################################
# Package Group Selection
###############################################################################

sub include_groups {
    my ($build, $file_list) = @_;

    # Read the lists of groups requested by the user.
    foreach my $file (@$file_list) {
        -f $file or die "ERROR: cannot open group list file '$file'\n";
        print "Including groups from $file\n" if $::verbose > 1;
        my $line_number = 0;
        foreach my $line (cat_($file)) {
            chomp($line);
            $line_number++;
            my ($entry, $comment) = split('#', $line);
            my ($name, $threshold) = split(' ', $entry);
            next if !$name; # skip pure comment lines
            if ($name =~ /^task-/) {
                $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 "ERROR: invalid threshold for $name on line $line_number of '$file'\n";
                $group_threshold{$name} = $threshold;
            }
        }
    }

    # Use the distribution rpmsrate file to select and add packages in the
    # requested groups.
    my $rpmsrate_src = $build->{settings}{repository} . '/' . $build->{settings}{arch} . '/media/media_info/rpmsrate';
    my $rpmsrate_tmp = $build->get_build_dir('tmp') . '/rpmsrate';
    copy_or_link($rpmsrate_src, $rpmsrate_tmp);
    add_rated_packages($build, $rpmsrate_tmp);
    report_package_count();
}

# Partially derived from read_rpmsrate_raw in pkgs.pm.
sub add_rated_packages {
    my ($build, $file) = @_;

    # Property records are two-element arrays. The first element is the
    # indentation level of the property record. The second element is an
    # array of property values which contains the accumulated property
    # values for that indentation level. A property value is either a
    # rating number (1 to 6) or a flag expression consisting of one or
    # more flags, possibly qualified by the "!" operator, and separated
    # by the "||" operator. The indentation level of the property record
    # is the indentation level of the most indented property value in the
    # array.
    #
    # Property records are collected as we read each line of the file, and
    # retained until the initial indentation level of a new line is less
    # than the indentation level of the record.

    my @property_records;

    my $line_number = 0;
    foreach my $line (cat_($file)) {
        $line_number++;

        # Use of hard tabs will confuse our calculation of indentation...
        $line =~ /\t/ and die "ERROR: hard tab not allowed at $file line $line_number\n";

        # Remove any comments.
        $line =~ s/#.*//;

        # Split out any leading white space. This is the initial indent for
        # the line.
        my ($indent, $remaining) = $line =~ /(\s*)(.*)/;

        # Skip empty lines.
        next if !$remaining;

        # Only retain the properties that are less indented than the current
        # line.
        @property_records = grep { $_->[0] < length($indent) } @property_records;

        # Inherit an initial set of property values from the last retained
        # record (which should be the most indented of the retained records).
        my @values = @property_records ? @{$property_records[-1][1]} : ();

        # Capture all the properties on this line.
        my $consumed;   # Most recently consumed portion of line.
        my $value;      # Most recently captured property value.
        while ($remaining =~ 
                /^(
                    (
                      [1-6]
                      |
                      (?:            (?: !\s*)? [0-9A-Z_]+(?:".*?")?)
                      (?: \s*\|\|\s* (?: !\s*)? [0-9A-Z_]+(?:".*?")?)*
                    )
                    (?:\s+|$)
                  )(.*)/x
              ) {
            ($consumed, $value, $remaining) = ($1,$2,$3);

            # Remove any non-quoted white space from the captured property
            # value.
            while ($value =~ s,^\s*(("[^"]*"|[^"\s]*)*)\s+,$1,) {}

            # Add a new property record and increase the indent each time we
            # capture a value.
            push @values, $value;
            push @property_records, [ length($indent), [ @values ] ];
            $indent .= $consumed;
        }

        # The remainder of the line (if any) is expected to be a list of
        # package names, separated by white space.
        if ($remaining) {
            # Pull out the rating for the current indentation level.
            my ($ratings, $flag_expressions) = partition { /^\d$/ } @values;
            my ($rating) = @$ratings or die "ERROR: missing rating at $file line $line_number\n";

            # In the installer, the set of flag expressions is treated as a
            # list of conditions, all of which must be true for the package
            # to be selected. But we need to include the packages for any
            # possible selection of categories, so we need to determine
            # whether any individual flag matches one of groups specified by
            # the user and whether the package rating meets the specified
            # threshold for that group.
            my @flags = map { split('\|\|', $_) } @$flag_expressions;

            # Skip any architecture-specific packages that don't match our
            # architecture.
            my $arch = $build->{settings}{arch};
            next if $arch eq 'x86_64' && member('!TYPE"64bit"', @flags);
            next if $arch ne 'x86_64' && member( 'TYPE"64bit"', @flags);

            # Skip any packages that don't match the user's requirements.
            next if !any { defined $group_threshold{$_} && $rating >= $group_threshold{$_} } @flags;

            # 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";
                }
            }
        }
    }
}

###############################################################################
# Individual Package Selection
###############################################################################

sub include_packages {
    my ($build, $file_list) = @_;

    foreach my $file (@$file_list) {
        print "Including packages from $file\n" if $::verbose;
        update_package_selection($build, $file, \&add_to_selected_packages, 1, 'warn');
        report_package_count();
    }
}

sub exclude_packages {
    my ($build, $file_list) = @_;

    foreach my $file (@$file_list) {
        print "Excluding packages from $file\n" if $::verbose;
        update_package_selection($build, $file, \&remove_from_selected_packages, 0, 'warn');
        report_package_count();
    }
}

###############################################################################
# Package Dependency Detection
###############################################################################

sub update_dependencies() {

    print "Calculating dependencies\n" if $::verbose;

    # Remove any existing dependencies.
    my @dependencies = grep { $package{$_}{class} == 2 } keys %package;
    delete $package{$_}{class} foreach @dependencies;

    # Calculate the dependencies and update the package list.
    my @search_list = grep { $package{$_}{class} == 1 } keys %package;
    while (@search_list) {
        foreach my $name (@search_list) {
            my $pkg = $package{$name}{best_pkg};
            my $parent_name = $pkg->name;
            my @requires = $pkg->requires_nosense;
            $urpm->traverse_tag('whatprovides', \@requires, sub {
                my ($pkg) = @_;
                return if is_obsolete($urpm, $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;
    }
    report_package_count();
}

sub is_obsolete {
    my ($urpm, $pkg) = @_;

    # This is derived from URPM::Resolve::_find_packages_obsoleting(). The
    # arch compatibility checks have been dropped, as we know we only have
    # one arch in our urpmi database.
    my @obsoleting_pakages = grep {
        $_ && !$_->flag_skip
           && $_->obsoletes_overlap($pkg->name . " == " . $pkg->epoch . ":" . $pkg->version . "-" . $pkg->release)
           && $_->fullname ne $pkg->fullname;
    } $urpm->packages_obsoleting($pkg->name);

    @obsoleting_pakages > 0;
}

###############################################################################
# Installation Media Generation
###############################################################################

sub build_installer_media {
    my ($build) = @_;

    print "Building installer media\n" if $::verbose;

    # Create a clean set of media directories
    my $arch = $build->{settings}{arch};
    my $arch_dir = $build->get_build_dir('files/' . $arch);
    my $media_dir = $arch_dir . '/media/';
    rm_rf($media_dir) if -e $media_dir;
    mkdir_p($media_dir . 'media_info');
    mkdir_p($media_dir . $_ . '/media_info') foreach @{$build->{urpmi_media}{enabled_sections}};

    print "  adding RPMs\n" if $::verbose > 1;

    # 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 section, so we ignore the source media subsection.
    my @packages = grep { defined $package{$_}{class} } keys %package;
    foreach my $name (@packages) {
        foreach my $pkg (uniq($package{$name}{best_pkg}, $package{$name}{base_pkg})) {
            defined $pkg or next;
            my @medium = grep { $pkg->id >= $_->{start} && $pkg->id <= $_->{end} } @{$urpm->{media}};
            my $src_path = $medium[0]->{url} . '/' . $pkg->filename;
            my @path_parts = split('/', $src_path);
            my $class = $path_parts[-3];
            my $fname = $path_parts[-1];
            my $dst_path = $media_dir . $class . '/' . $fname;
            copy_or_link($src_path, $dst_path);

            member($name, @{$build->{biarch_packages}}) or next;
            my $xarch = $arch eq 'x86_64' ? 'i586' : 'x86_64';
            # Here we take a shortcut, and assume the identical package exists
            # for the other arch.
            $src_path =~ s/$arch/$xarch/g;
            # This feature only exists to support 32-bit UEFI on 64-bit systems,
            # so it's not worth creating a separate medium for the other arch.
            $dst_path =~ s/$arch\.rpm/$xarch\.rpm/;
            copy_or_link($src_path, $dst_path);
        }
    }

    print "  generating media info\n" if $::verbose > 1;

    # Copy the pubkeys from the repository. Use the pubkeys from the first
    # media subsection in each section.
    my $repo_media_dir = $build->{settings}{repository} . '/' . $arch . '/media/';
    my $first_subsection = ${$build->{urpmi_media}{enabled_subsections}}[0];
    foreach my $section (@{$build->{urpmi_media}{enabled_sections}}) {
        my $pubkey = $repo_media_dir . $section . '/' . $first_subsection . '/media_info/pubkey';
        copy_or_link($pubkey, $media_dir . $section . '/media_info/pubkey');
    }

    # Create the media config file.
    create_media_cfg($build, $media_dir . 'media_info/media.cfg');

    # Add files we can take directly from the source repository.
    copy_or_link($repo_media_dir . '/media_info/compssUsers.pl', $media_dir . 'media_info/compssUsers.pl');
    copy_or_link($repo_media_dir . '/media_info/file-deps',      $media_dir . 'media_info/file-deps');
    copy_or_link($repo_media_dir . '/media_info/rpmsrate',       $media_dir . 'media_info/rpmsrate');

    # Generate the remaining media info.
    my $silent = $::verbose < 3;
    print "-- messages from gendistrib -----------------------\n" if !$silent;
    run_('gendistrib', if_($silent, '-s'), $arch_dir)
      or die "ERROR: gendistrib failed to generate the media info\n";
    print "---------------------------------------------------\n" if !$silent;
}

sub create_media_cfg {
    my ($build, $file) = @_;

    my $version = $build->{settings}{version};
    my $branch  = $build->{settings}{branch};
    my $arch    = $build->{settings}{arch};

    open(my $f, '>', $file);
    print $f "[media_info]\n";
    print $f "mediacfg_version=2\n";
    print $f "version=$version\n";
    print $f "branch=$branch\n";
    print $f "arch=$arch\n";
    print $f "askmedia=1\n"  if $build->{media_cfg}{askmedia};
    print $f "suppl=1\n"     if $build->{media_cfg}{suppl};
    print $f "xml-info=1\n"  if $build->{media_cfg}{xml_info};
    foreach my $section (@{$build->{urpmi_media}{enabled_sections}}) {
        print $f "\n";
        print $f "[$section]\n";
        print $f "synthesis=../$section/media_info/synthesis.hdlist.cz\n";
        print $f "hdlist=../$section/media_info/hdlist.cz\n";
        print $f "pubkey=../$section/media_info/pubkey\n";
        print $f "name=" . ucfirst($section) . " Release (Installer)\n";
    }
    close $f;
}

sub check_installer_media {
    my ($build, $section) = @_;

    print "Checking installer media [$section]\n" if $::verbose;

    my $arch = $build->{settings}{arch};
    my $media_dir = $build->get_build_dir('files/' . $arch . '/media');
    my $log_file  = $build->get_build_dir('tmp') . '/rpmcheck.log';
    run_("zcat -q $media_dir/$section/media_info/hdlist.cz | rpmcheck -explain -failures > $log_file")
      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
###############################################################################

sub read_repo_product_id {
    my ($build) = @_;

    my $src_file = $build->{settings}{repository} . '/' . $build->{settings}{arch} . '/product.id';
    my $product_id;
    if ($src_file =~ m!^(ftp|http)://!) {
        $product_id = `curl --silent $src_file`;
        $? and die "ERROR: couldn't fetch product.id file from repository\n";
    } else {
        $product_id = cat_($src_file);
    }

    my %h = map { if_(/(.*?)=(.*)/, $1 => $2) } split(',', $product_id);

    foreach my $setting (qw(type version branch product)) {
        next if defined $build->{settings}{$setting};
        $h{$setting} or die "ERROR: $setting field missing from product.id\n";
        $build->{settings}{$setting} = $h{$setting};
    }
}

sub create_product_id {
    my ($build, $file) = @_;

    open(my $f, '>', $file);
    print $f join(',',
        'vendor='       . $build->{settings}{vendor},
        'distribution=' . $build->{settings}{distro},
        'type='         . $build->{settings}{type},
        'version='      . $build->{settings}{version},
        'branch='       . $build->{settings}{branch},
        'release='      . $build->{settings}{release},
        'arch='         . $build->{settings}{arch},
        'product='      . $build->{settings}{product}
    );
    print $f "\n";
    close($f);
}

# Derived from BCD::Genisoimage::create_idx
sub create_index {
    my ($build, $file) = @_;

    my $arch = $build->{settings}{arch};

    my $media_dir = $build->get_build_dir('files/' . $arch . '/media/');
    my @hdlists = glob("$media_dir/*/media_info/hdlist.cz");

    my @tab;
    my $urpm = URPM->new;
    foreach (@hdlists) {
        $urpm->parse_hdlist($_);
        $urpm->traverse(sub {
            my $pkg = shift;
            my $pkgname = $pkg->name;  
            my $version = $pkg->version;
            my $arch    = $pkg->arch;
            push @tab, "$pkgname-$version ($arch)";
        });
    }

    my %hashtab = map { $_ => 1 } @tab;
    my @orderedpkgs = sort keys %hashtab;

    my $label = $build->{media}{label};

    open(my $f, '>', $file);
    foreach (@orderedpkgs) {
        print $f "$label $_\n";
    }
    close($f);
}

###############################################################################
# Helper Functions
###############################################################################

sub run_urpm {
    my ($build, $cmd, $parameters, $o_not_fatal) = @_;

    my $urpmi_root = '--urpmi-root ' . $build->get_chroot_dir;

    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, $name, $class, $o_warn) = @_;

    $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 explicitly selected\n" if $o_warn;
    } elsif ($package{$name}{class} == 2) {
        print "INFO <$source>: $name is already implicitly selected\n" if $o_warn;
        $package{$name}{class} = $class;
    } else {
        print "INFO <$source>: selecting package $name\n" if $::verbose > 2;
        $package{$name}{class} = $class;
    }
}

sub remove_from_selected_packages {
    my ($source, $name, $class, $o_warn) = @_;

    $package{$name} or die "ERROR <$source>: $name is not available in the urpmi media\n";

    if (defined $package{$name}{class}) {
        print "INFO <$source>: deselecting package $name\n" if $::verbose > 2;
        delete $package{$name}{class};
    } else {
        print "INFO <$source>: $name is not currently selected\n" if $o_warn;
    }
    push @excluded, $name;
}

sub update_package_selection {
    my ($build, $file, $action, $class, $o_warn) = @_;

    my $arch = $build->{settings}{arch};

    -f $file or die "ERROR: cannot open package list file '$file'\n";
    foreach my $line (cat_($file)) {
        chomp($line);
        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 $name (@packages) {
            my @alternatives = split('\|', $name);
            if (@alternatives > 1) {
                foreach my $alternative (@alternatives) {
                    $action->($file, $alternative, $class);
                }
            } 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, $name, $class, $o_warn);
            }
        }
    }
}

sub report_package_count() {
    my @packages = grep { defined $package{$_}{class} } keys %package;
    print "  package count = ", scalar @packages, "\n" if $::verbose > 1;
}

1;