File Coverage

blib/lib/System/Introspector/Probe/LibDirs/Perl.pm

Criterion	Covered	Total	%
statement	36	40	90.0
branch	2	6	33.3
condition	1	2	50.0
subroutine	8	9	88.8
pod	0	1	0.0
total	47	58	81.0

package System::Introspector::Probe::LibDirs::Perl;
use Moo;
use Module::Metadata;
use Digest::SHA;

use System::Introspector::Util qw(
    handle_from_command
    transform_exceptions
);

has root => (
    is      => 'ro',
    default => sub { '/' },
);

sub gather {
    my ($self) = @_;
    return transform_exceptions {
        my $pipe = $self->_open_locate_libdirs_pipe;
        my %libdir;
        while (defined( my $line = <$pipe> )) {
            chomp $line;
            $libdir{ $line } = transform_exceptions {
                return { modules => $self->_gather_libdir_info($line) };
            };
        }
        return { libdirs_perl => \%libdir };
    };
}

sub _gather_libdir_info {
    my ($self, $libdir) = @_;
    my %module;
    my $pipe = $self->_open_locate_pm_pipe($libdir);
    while (defined( my $line = <$pipe> )) {
        chomp $line;
        my $metadata = Module::Metadata->new_from_file($line);
        next unless $metadata->name;
        my $sha = Digest::SHA->new(256);
        $sha->addfile($line);
        my $version = $metadata->version;
        push @{ $module{ $metadata->name } //= [] }, {
            file        => $line,
            version     => (
                defined($version)
                ? sprintf('%s', $version)
                : undef
            ),
            size        => scalar(-s $line),
            sha256_hex  => $sha->hexdigest,
        };
    }
    return \%module;
}

sub _open_locate_pm_pipe {
    my ($self, $libdir) = @_;
    return handle_from_command
        sprintf q{find %s -name '*.pm'}, $libdir;
}

sub _open_locate_libdirs_pipe {
    my ($self) = @_;
    my $root = $self->root;
    $root .= '/'
        unless $root =~ m{/$};
    return handle_from_command sprintf
        q{locate --regex '^%s.*lib/perl5$'}, $root;
}

1;

__END__