File Coverage

blib/lib/CPANPLUS/Dist/Debora/Package.pm

Criterion	Covered	Total	%
statement	519	591	87.8
branch	115	192	59.9
condition	35	65	53.8
subroutine	104	114	91.2
pod	36	36	100.0
total	809	998	81.0

package CPANPLUS::Dist::Debora::Package;

# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

use 5.016;
use warnings;
use utf8;

our $VERSION = '0.011';

use Carp qw(croak);
use Config;
use CPAN::Meta;
use English qw(-no_match_vars);
use File::Basename qw(dirname);
use File::Path qw(remove_tree);
use File::Spec::Functions qw(catdir catfile splitdir splitpath);
use File::Temp qw(tempdir);
use Net::Domain qw(hostfqdn);
use Software::LicenseUtils 0.103014;

use CPANPLUS::Dist::Debora::License;
use CPANPLUS::Dist::Debora::Pod;
use CPANPLUS::Dist::Debora::Util qw(
    parse_version
    module_is_distributed_with_perl
    decode_utf8
    can_run
    run
    find_most_recent_mtime
    find_shared_objects
);

# Map some distribution names to special package names.
my %PACKAGE_NAME_FOR = (
    'ack'              => 'ack',
    'App-Licensecheck' => 'licensecheck',
    'App-perlbrew'     => 'perlbrew',
    'TermReadKey'      => 'perl-Term-ReadKey',
);

# Version quirks.
my %VERSION_FOR = ('BioPerl-Run' => sub { parse_version($_[0])->normal });

# Modules with summaries and descriptions.
my %POD_FOR = (
    'ack'              => 'ack',
    'App-Licensecheck' => 'licensecheck',
    'TermReadKey'      => 'ReadKey.pm.PL',
    'TimeDate'         => 'Date::Parse',
    'YAML-LibYAML'     => 'YAML::XS',
);

# Common modules whose license might not be guessed.
my %LICENSE_FOR = (
    'AnyEvent'                    => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Apache-Htpasswd'             => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Cache-Cache'                 => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Canary-Stability'            => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'CGI-FormBuilder'             => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'CGI-FormBuilder-Source-Perl' => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Crypt-CBC'                   => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Encode-Detect'               => 'MPL-1.1',
    'Guard'                       => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Iterator'                    => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Iterator-Util'               => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Lingua-EN-Words2Nums'        => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Lingua-Stem-Snowball-Da'     => 'GPL-2.0-only',
    'Mozilla-CA'                  => 'MPL-2.0',
    'Socket6'                     => 'BSD',
    'String-ShellQuote'           => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'Sub-Delete'                  => 'Artistic-1.0-Perl OR GPL-1.0-or-later',
    'XML-Writer'                  => 'CC0-1.0',
);

sub new {
    my ($class, %attrs) = @_;

    my $attrs = $class->_buildargs(%attrs);

    return bless $attrs, $class;
}

sub _buildargs {
    my ($class, %attrs) = @_;

    if (!exists $attrs{module}) {
        croak 'No module';
    }

    my $builddir = $attrs{builddir} = $attrs{module}->status->extract;
    if (!defined $builddir) {
        croak 'No builddir';
    }

    if (!exists $attrs{installdirs}) {
        $attrs{installdirs} = 'vendor';
    }

    my $installdirs = $attrs{installdirs};
    if ($installdirs ne 'vendor' && $installdirs ne 'site') {
        croak "installdirs is neither 'vendor' nor 'site': '$installdirs'";
    }

    if (!exists $attrs{build_number}) {
        $attrs{build_number} = 1;
    }

    my $build_number = $attrs{build_number};
    if ($build_number !~ m{\A [1-9]\d* \z}xms) {
        croak "build_number is not a positive integer: '$build_number'";
    }

    $attrs{last_modification} = find_most_recent_mtime($builddir);

    return \%attrs;
}

sub _read {
    my ($self, $name, $default) = @_;

    if (!exists $self->{$name}) {
        $self->{$name} = $default->();
    }

    return $self->{$name};
}

sub module {
    my $self = shift;

    return $self->{module};
}

sub installdirs {
    my $self = shift;

    return $self->{installdirs};
}

sub sourcefile {
    my $self = shift;

    my $sourcefile
        = $self->_read('sourcefile', sub { $self->module->status->fetch });

    return $sourcefile;
}

sub sourcedir {
    my $self = shift;

    my $sourcedir
        = $self->_read('sourcedir', sub { dirname($self->sourcefile) });

    return $sourcedir;
}

sub last_modification {
    my $self = shift;

    return $self->{last_modification};
}

sub builddir {
    my $self = shift;

    return $self->{builddir};
}

sub outputdir {
    my $self = shift;

    my $outputdir = $self->_read('outputdir', sub { dirname($self->builddir) });

    return $outputdir;
}

sub stagingdir {
    my $self = shift;

    my $stagingdir = $self->_read('stagingdir',
        sub { tempdir('stagingXXXX', DIR => $self->outputdir) });

    return $stagingdir;
}

sub shared_objects {
    my $self = shift;

    my $shared_objects
        = $self->_read('shared_objects', sub { $self->_get_shared_objects });

    return $shared_objects;
}

sub is_noarch {
    my $self = shift;

    my $is_noarch = $self->_read('is_noarch', sub { $self->_get_is_noarch });

    return $is_noarch;
}

sub module_name {
    my $self = shift;

    my $module_name
        = $self->_read('module_name', sub { $self->_get_module_name });

    return $module_name;
}

sub dist_name {
    my $self = shift;

    return $self->module->package_name;
}

sub name {
    my $self = shift;

    my $name = $self->_read('name',
        sub { $self->_normalize_name($self->dist_name) });

    return $name;
}

sub dist_version {
    my $self = shift;

    return $self->module->package_version;
}

sub version {
    my $self = shift;

    my $version = $self->_read('version',
        sub { $self->_normalize_version($self->dist_version) });

    return $version;
}

sub build_number {
    my $self = shift;

    return $self->{build_number};
}

sub author {
    my $self = shift;

    my $author = $self->_read('author', sub { $self->module->author->author });

    return $author;
}

sub packager {
    my $self = shift;

    my $packager = $self->_read('packager', sub { $self->_get_packager });

    return $packager;
}

sub vendor {
    my $self = shift;

    my $vendor = $self->_read('vendor', sub { $self->_get_vendor });

    return $vendor;
}

sub url {
    my $self = shift;

    # A link to MetaCPAN is more useful than the homepage.
    my $url = $self->_read('url',
        sub { 'https://metacpan.org/dist/' . $self->dist_name });

    return $url;
}

sub summary {
    my $self = shift;

    my $summary = $self->_read('summary', sub { $self->_get_summary });

    return $summary;
}

sub description {
    my $self = shift;

    my $description
        = $self->_read('description', sub { $self->_get_description });

    return $description;
}

sub dependencies {
    my $self = shift;

    my $dependencies
        = $self->_read('dependencies', sub { $self->_get_dependencies });

    return $dependencies;
}

sub copyrights {
    my $self = shift;

    my $copyrights = $self->_read('copyrights', sub { $self->_get_copyrights });

    return $copyrights;
}

sub licenses {
    my $self = shift;

    my $licenses = $self->_read('licenses', sub { $self->_get_licenses });

    return $licenses;
}

sub license {
    my $self = shift;

    my $license = $self->_read('license', sub { $self->_get_license });

    return $license;
}

sub files {
    my $self = shift;

    my $files = $self->_read('files',
        sub { [@{$self->_get_docfiles}, @{$self->_get_stagingfiles}] });

    return $files;
}

sub files_by_type {
    my ($self, $type) = @_;

    my @files = map { $_->{name} } grep { $_->{type} eq $type } @{$self->files};

    return \@files;
}

sub mb_opt {
    my $self = shift;

    my $installdirs = $self->installdirs;

    return << "END_MB_OPT";
--installdirs $installdirs
END_MB_OPT
}

sub mm_opt {
    my $self = shift;

    my $installdirs = $self->installdirs;

    return << "END_MM_OPT";
INSTALLDIRS=$installdirs
END_MM_OPT
}

sub sanitize_stagingdir {
    my $self = shift;

    my $fail_count = 0;

    my $finddepth = sub {
        my $dir = shift;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            # Process sub directories first.
            if (-d $path) {
                __SUB__->($path);
            }

            # Sanitize the permissions.
            my @stat = lstat $path;
            if (!@stat) {
                error("Could not stat '$path': $OS_ERROR");
                next ENTRY;
            }

            my $old_mode = $stat[2] & oct '0777';
            my $new_mode = ($old_mode & oct '0755') | oct '0200';
            if ($old_mode != $new_mode) {
                if (!chmod $new_mode, $path) {
                    error("Could not chmod '$path': $OS_ERROR");
                    ++$fail_count;
                }
            }

            # Remove empty directories and some files.
            if (-d $path) {
                rmdir $path;
            }
            else {
                if (   $entry eq 'perllocal.pod'
                    || $entry eq '.packlist'
                    || ($entry =~ m{[.]bs \z}xms && -z $path))
                {
                    if (!unlink $path) {
                        error("Could not remove '$path': $OS_ERROR");
                        ++$fail_count;
                    }
                }
            }
        }
        closedir $dh;

        return;
    };
    $finddepth->($self->stagingdir);

    return $fail_count == 0;
}

sub remove_stagingdir {
    my $self = shift;

    my $stagingdir = $self->{stagingdir};
    if (defined $stagingdir) {
        remove_tree($stagingdir);
        delete $self->{stagingdir};
    }

    return 1;
}

sub rpm_cmd {
    my $self = shift;

    state $rpm_cmd = can_run('rpm');

    return $rpm_cmd;
}

sub rpm_eval {
    my ($self, $expr) = @_;

    my $string = q{};

    my $rpm_cmd = $self->rpm_cmd;
    if ($rpm_cmd) {
        my @eval_cmd = ($rpm_cmd, '--eval', $expr);
        my $output   = q{};
        if (run(command => \@eval_cmd, buffer => \$output)) {
            chomp $output;
            $string = eval { decode_utf8($output) } // q{};
        }
    }

    return $string;
}

sub sudo_cmd {
    my $self = shift;

    my $module   = $self->module;
    my $backend  = $module->parent;
    my $config   = $backend->configure_object;
    my $sudo_cmd = $config->get_program('sudo') // 'sudo';

    return $sudo_cmd;
}

sub DESTROY {
    my $self = shift;

    my $stagingdir = $self->{stagingdir};
    if (defined $stagingdir) {
        ##no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
        eval { remove_tree($stagingdir) };
    }

    return;
}

## no critic (Subroutines::ProhibitExcessComplexity)

sub _normalize_name {
    my ($self, $dist_name) = @_;

    my $name;
    if (exists $PACKAGE_NAME_FOR{$dist_name}) {
        $name = $PACKAGE_NAME_FOR{$dist_name};
    }
    else {
        $name = $dist_name;

        # Prepend "perl-" unless the name starts with "perl-".
        if ($name !~ m{\A perl-}xms) {
            $name = 'perl-' . $name;
        }
    }

    return $name;
}

sub _normalize_version {
    my ($self, $dist_version) = @_;

    my $dist_name = $self->dist_name;

    my $version = $dist_version // 0;

    if (exists $VERSION_FOR{$dist_name}) {
        $version = $VERSION_FOR{$dist_name}->($version);
    }

    $version =~ s{\A v}{}xms;    # Strip "v".

    return $version;
}

sub _unnumify_version {
    my ($self, $dist_version) = @_;

    my $version
        = $self->_normalize_version(parse_version($dist_version)->normal);

    return $version;
}

sub _get_meta {
    my $self = shift;

    my $meta;

    my $builddir = $self->builddir;
    META:
    for (qw(META.json META.yml)) {
        my $metafile = catfile($builddir, $_);
        if (-f $metafile) {
            $meta = eval { CPAN::Meta->load_file($metafile) };
            last META if defined $meta;
        }
    }

    return $meta;
}

sub _meta {
    my $self = shift;

    my $meta = $self->_read('meta', sub { $self->_get_meta });

    return $meta;
}

sub _get_pod {
    my $self = shift;

    my $builddir = $self->builddir;

    my $name = $POD_FOR{$self->dist_name} // $self->module_name;
    my @dirs = map { catdir($builddir, $_) } qw(blib/lib blib/bin lib bin .);
    my $pod  = CPANPLUS::Dist::Debora::Pod->find($name, @dirs, $builddir);

    return $pod;
}

sub _pod {
    my $self = shift;

    return $self->_read('pod', sub { $self->_get_pod });
}

sub _get_shared_objects {
    my $self = shift;

    my $stagingdir = $self->{stagingdir};
    if (!defined $stagingdir) {
        croak 'Call shared_objects after the distribution has been built';
    }

    my $shared_objects = find_shared_objects($stagingdir);

    return $shared_objects;
}

sub _get_is_noarch {
    my $self = shift;

    # Searching for source code files isn't reliable as there are Perl
    # distributions with C files in example directories.
    #
    # Instead, we look for an "auto" directory and search for shared objects
    # after the distribution has been installed in the staging directory.

    my $stagingdir = $self->{stagingdir};
    if (!defined $stagingdir) {
        croak 'Call is_arch after the distribution has been built';
    }

    my $is_noarch = @{$self->shared_objects} == 0;
    if ($is_noarch) {
        my $installdirs = $self->installdirs;
        my $archdir     = $Config{"install${installdirs}arch"};
        if (defined $archdir) {
            my $autodir = catdir($stagingdir, $archdir, 'auto');
            if (-d $autodir) {
                $is_noarch = 0;
            }
        }
    }

    return $is_noarch;
}

sub _get_module_name {
    my $self = shift;

    my $name = $self->module->module;

    # Is there a .pm file with the distribution's name?
    my @module   = split qr{-}xms, $self->dist_name;
    my $filename = catfile($self->builddir, 'lib', @module) . '.pm';
    if (-f $filename) {
        $name = join q{::}, @module;
    }

    return $name;
}

sub _get_packager {
    my $self = shift;

    my $name;
    my $email;

    my $EMAIL = qr{ \A
        (?:([^<]*) \h+)?     # name
        ]+@[^>]+) >?  # email
    }xms;

    if ($self->rpm_eval('%{?packager}') =~ $EMAIL) {
        $name  = $1;
        $email = $2;
    }

    if (!$name) {
        NAME:
        for my $key (qw(DEBFULLNAME NAME GITLAB_USER_NAME)) {
            if ($ENV{$key}) {
                $name = eval { decode_utf8($ENV{$key}) };
                last NAME if $name;
            }
        }
    }

    for my $key (qw(DEBEMAIL EMAIL GITLAB_USER_EMAIL)) {
        if ($ENV{$key}) {
            my $value = eval { decode_utf8($ENV{$key}) };
            if ($value && $value =~ $EMAIL) {
                if (!$name) {
                    $name = $1;
                }
                if (!$email) {
                    $email = $2;
                }
            }
        }
    }

    my $user;

    my @pw = eval { getpwuid $UID };
    if (@pw) {
        $user = eval { decode_utf8($pw[0]) };

        if (!$name) {
            my $gecos = eval { decode_utf8($pw[6]) };
            if ($gecos) {
                ($name) = split qr{,}xms, $gecos;
            }
        }
    }

    if (!$user) {
        USER:
        for my $key (qw(LOGNAME USER USERNAME)) {
            if ($ENV{$key}) {
                $user = eval { decode_utf8($ENV{$key}) };
                last USER if $user;
            }
        }
    }

    if (!$user) {
        $user = 'nobody';
    }

    if (!$name) {
        $name = $user;
    }

    if (!$email) {
        my $host = hostfqdn;
        $host =~ s{[.]$}{}xms;
        $email = $user . q{@} . $host;
    }

    return "$name <$email>";
}

sub _get_vendor {
    my $self = shift;

    my $vendor = $self->rpm_eval('%{?vendor}');
    if (!$vendor || $vendor =~ m{%}xms) {
        $vendor = 'CPANPLUS';
    }

    return $vendor;
}

sub _get_summary_from_meta {
    my $self = shift;

    my $summary;

    my $meta = $self->_meta;
    if (defined $meta) {
        my $text = $meta->{abstract};
        if ($text && $text !~ m{unknown}xmsi) {
            $summary = $text;
        }
    }

    return $summary;
}

sub _get_summary_from_pod {
    my $self = shift;

    my $summary;

    my $pod = $self->_pod;
    if (defined $pod) {
        $summary = $pod->summary;
    }

    return $summary;
}

sub _get_summary {
    my $self = shift;

    my $summary = $self->_get_summary_from_meta // $self->_get_summary_from_pod
        // 'Module for the Perl programming language';
    $summary =~ s{\v+}{ }xmsg;                    # Replace newlines.
    $summary =~ s{[.]+ \z}{}xms;                  # Remove trailing dots.
    $summary =~ s{\A (?:An? | The) \h+}{}xmsi;    # Remove leading articles.

    return ucfirst $summary;
}

sub _get_description {
    my $self = shift;

    my $description = q{};

    my $pod = $self->_pod;
    if (defined $pod) {
        $description = $pod->description;
    }

    if (!$description) {
        my $module_name = $self->module_name;
        $description
            = "$module_name is a module for the Perl programming language.";
    }

    return $description;
}

sub _get_requires {
    my $self = shift;

    my %requires;

    my $prereqs = $self->module->status->prereqs // {};

    my $meta = $self->_meta;
    if (defined $meta && ref $meta->{prereqs} eq 'HASH') {
        my $meta_runtime  = $meta->{prereqs}->{runtime} // {};
        my $meta_requires = $meta_runtime->{requires}   // {};

        # We can only have dependencies that are in the prereqs.
        %requires = map { $_ => $meta_requires->{$_} }
            grep { exists $prereqs->{$_} } keys %{$meta_requires};
    }
    else {
        %requires = %{$prereqs};
    }

    return \%requires;
}

sub _get_dependencies {
    my $self = shift;

    my %requires = %{$self->_get_requires};
    my $backend  = $self->module->parent;

    # Sometimes versions are numified and cannot be compared with stringified
    # versions.
    my %version_for = (
        'Algorithm-Diff'   => sub {0},
        'BioPerl'          => sub { $self->_unnumify_version($_[0]) },
        'Catalyst'         => sub {0},
        'Catalyst-Runtime' => sub {0},
        'CGI-Simple'       => sub {0},
        'DBD-Pg'           => sub { $self->_unnumify_version($_[0]) },
    );

    my %dependency;

    MODULE:
    for my $module_name (keys %requires) {
        my $module = $backend->module_tree($module_name);
        next MODULE if !$module;

        # Task::Weaken is only a build dependency.
        next MODULE if $module_name eq 'Task::Weaken';

        # Ignore dependencies on modules for VMS and Windows.
        next MODULE if $module_name =~ m{\A (?:VMS | Win32)}xms;

        my $dist_name = $module->package_name;
        my $version   = parse_version($requires{$module_name});

        my $is_core
            = $module_name eq 'perl'
            || module_is_distributed_with_perl($module_name, $version)
            || $module->package_is_perl_core;

        if (exists $version_for{$dist_name}) {
            $version = $version_for{$dist_name}->($version);
        }

        if (!exists $dependency{$module_name}
            || $dependency{$module_name}->{version} < $version)
        {
            $dependency{$module_name} = {
                dist_name => $dist_name,
                version   => $version,
                is_module => $module_name ne 'perl',
                is_core   => $is_core,
            };
        }
    }

    my @dependencies = map { {
        module_name  => $_,
        dist_name    => $dependency{$_}->{dist_name},
        package_name => $self->_normalize_name($dependency{$_}->{dist_name}),
        version      => $self->_normalize_version($dependency{$_}->{version}),
        is_module    => $dependency{$_}->{is_module},
        is_core      => $dependency{$_}->{is_core},
    } } sort { uc $a cmp uc $b } keys %dependency;

    return \@dependencies;
}

sub _get_copyrights {
    my $self = shift;

    my @copyrights;

    my $pod = $self->_pod;
    if (defined $pod) {
        push @copyrights, @{$pod->copyrights};
    }

    if (!@copyrights) {
        my $author = $self->author;
        my $holder
            = $author ? "$author and possibly others" : 'unknown authors';
        my $time = $self->last_modification;
        my $year = (gmtime $time)[5] + 1900;
        push @copyrights, {year => $year, holder => $holder};
    }

    return \@copyrights;
}

sub _get_licenses_from_meta {
    my $self = shift;

    my @licenses;

    my $meta = $self->_meta;
    if (defined $meta) {
        my $keys = $meta->{license};
        if (defined $keys) {
            if (!ref $keys) {
                $keys = [$keys];
            }
            my %ignore_key = map { $_ => 1 } qw(open_source unrestricted);
            for my $key (grep { !exists $ignore_key{$_} } @{$keys}) {
                my @license
                    = Software::LicenseUtils->guess_license_from_meta_key($key,
                    2);
                if (@license) {
                    push @licenses, @license;
                }
            }
        }
    }

    return \@licenses;
}

sub _get_licenses_from_pod {
    my $self = shift;

    my @licenses;

    my $pod = $self->_pod;
    if (defined $pod) {
        my @license
            = Software::LicenseUtils->guess_license_from_pod($pod->text);
        if (@license) {
            push @licenses, @license;
        }
    }

    return \@licenses;
}

sub _get_licenses {
    my $self = shift;

    my %copyright = %{$self->copyrights->[-1]};

    my $get_license = sub {
        my $spdx_expression = shift;

        my $license = eval {
            Software::LicenseUtils->new_from_spdx_expression({
                spdx_expression => $spdx_expression,
                %copyright
            });
        };
        if (!$license) {
            $license = CPANPLUS::Dist::Debora::License->new({
                package => $self,
                %copyright
            });
        }

        return $license;
    };

    my %unique_guesses
        = map { $_->name => $_ } @{$self->_get_licenses_from_meta},
        @{$self->_get_licenses_from_pod};

    # Add the copyright year and author to the guessed licenses.
    my @licenses
        = map { $get_license->($_->spdx_expression) } values %unique_guesses;
    if (!@licenses) {
        push @licenses, $get_license->($LICENSE_FOR{$self->dist_name});
    }

    my @sorted_licenses
        = sort { $a->spdx_expression cmp $b->spdx_expression } @licenses;

    return \@sorted_licenses;
}

sub _get_license {
    my $self = shift;

    my @names   = map { $_->spdx_expression } @{$self->licenses};
    my $license = join ' AND ',
        map { @names > 1 && m{\b OR \b}xmsi ? "($_)" : $_ } @names;

    return $license;
}

sub _get_docfiles {
    my $self = shift;

    my $LICENSE = qr{ \A (?:
       COPYING(?:[.](?:LESSER|LIB))?
       | COPYRIGHT
       | LICEN[CS]E
       ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my $CHANGELOG = qr{ \A (?:
        Change(?:s|Log)
        ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my $DOC = qr{ \A (?:
        AUTHORS
        | BUGS
        | CONTRIBUTING
        | CREDITS
        | FAQ
        | NEWS
        | README
        | THANKS
        | TODO
        ) (?:[.](?:md|mkdn|pod|txt))? \z
    }xmsi;

    my %regex_for = (
        'license'   => $LICENSE,
        'changelog' => $CHANGELOG,
        'doc'       => $DOC,
    );

    my @files;

    my $fix_permissions = sub {
        my $dir = shift;

        chmod oct '0755', $dir;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            if (-d $path) {
                __SUB__->($path);
            }
            else {
                chmod oct '0644', $path;
            }
        }
        closedir $dh;

        return;
    };

    my $find = sub {
        my $dir = shift;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            # Skip symbolic links.
            next ENTRY if -l $path;

            if (-d $path) {
                if ($entry eq 'examples') {
                    $fix_permissions->($path);
                    my $file = {name => $entry, type => 'doc'};
                    push @files, $file;
                }
            }
            elsif (-s $path) {
                TYPE:
                for my $type (keys %regex_for) {
                    if ($entry =~ $regex_for{$type}) {
                        chmod oct '0644', $path;
                        my $file = {name => $entry, type => $type};
                        push @files, $file;
                        last TYPE;
                    }
                }
            }
        }
        closedir $dh;

        return;
    };
    $find->($self->builddir);

    my @sorted_files = sort { $a->{name} cmp $b->{name} } @files;

    return \@sorted_files;
}

sub _get_excludedirs {
    my $self = shift;

    # A list of directories that are provided by Perl and must not be removed
    # by packages.

    my @vars = qw(
        installsitearch
        installsitebin
        installsitelib
        installsiteman1dir
        installsiteman3dir
        installsitescript
        installvendorarch
        installvendorbin
        installvendorlib
        installvendorman1dir
        installvendorman3dir
        installvendorscript
    );

    my %excludedirs = map { $_ => 1 } qw(/etc);
    VAR:
    for my $var (@vars) {
        my $value = $Config{$var};
        next VAR if !$value;

        if ($var =~ m{arch \z}xms) {
            $value = catdir($value, 'auto');
        }

        my ($volume, $path) = File::Spec->splitpath($value, 1);

        my ($dir, @dirs) = splitdir($path);
        while (@dirs) {
            $dir = catdir($dir, shift @dirs);
            $excludedirs{$dir} = 1;
        }
    }

    return \%excludedirs;
}

sub _get_stagingfiles {
    my $self = shift;

    my $stagingdir        = $self->stagingdir;
    my $stagingdir_length = length $stagingdir;
    my $excludedirs       = $self->_get_excludedirs;

    my @files;

    my $find = sub {
        my $dir = shift;

        opendir my $dh, $dir
            or croak "Could not traverse '$dir': $OS_ERROR";
        ENTRY:
        while (defined(my $entry = readdir $dh)) {
            next ENTRY if $entry eq q{.} || $entry eq q{..};

            my $path = catfile($dir, $entry);

            my $name = substr $path, $stagingdir_length;
            my $type = -l $path ? 'link' : -d $path ? 'dir' : 'file';
            if ($type eq 'file') {
                my ($volume, $dirs, $file) = splitpath($name);
                my %subdir = map { $_ => 1 } splitdir($dirs);
                if (exists $subdir{etc}) {
                    $type = 'config';
                }
                elsif (exists $subdir{man}) {
                    $type = 'man';
                }
            }

            if (!exists $excludedirs->{$name}) {
                my $file = {name => $name, type => $type};
                push @files, $file;
            }

            # Skip symbolic links.
            next ENTRY if -l $path;

            if (-d $path) {
                __SUB__->($path);
            }
        }
        closedir $dh;

        return;
    };
    $find->($stagingdir);

    my @sorted_files = sort { $a->{name} cmp $b->{name} } @files;

    return \@sorted_files;
}

1;
__END__