DiskUsage probe tests

[scpubgit/System-Introspector.git] / lib / System / Introspector / LibDirs / Perl.pm

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

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

sub gather {
    my ($self) = @_;
    my $pipe = $self->_open_locate_libdirs_pipe;
    my %libdir;
    while (defined( my $line = <$pipe> )) {
        chomp $line;
        $libdir{ $line } = $self->_gather_libdir_info($line);
    }
    return \%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);
        push @{ $module{ $metadata->name } //= [] }, {
            file        => $line,
            version     => $metadata->version,
            size        => scalar(-s $line),
            sha256_hex  => $sha->hexdigest,
        };
    }
    return \%module;
}

sub _open_locate_pm_pipe {
    my ($self, $libdir) = @_;
    my $command = sprintf
        q{find %s -name '*.pm'},
        $libdir;
    open my $pipe, '-|', $command
        or die "Unable to open pipe to '$command': $!\n";
    return $pipe;
}

sub _open_locate_libdirs_pipe {
    my ($self) = @_;
    my $root = $self->root;
    $root .= '/'
        unless $root =~ m{/$};
    my $command = sprintf
        q{locate --regex '^%s.*lib/perl5$'},
        $root;
    open my $pipe, '-|', $command
        or die "Unable to open pipe to '$command': $!\n";
    return $pipe;
}

1;