lib/System/Introspector/LibDirs/Perl.pm

   1 package System::Introspector::LibDirs::Perl;
   2 use Moo;
   3 use Module::Metadata;
   4 use Digest::SHA;
   5
   6 has root => (
   7     is      => 'ro',
   8     default => sub { '/' },
   9 );
  10
  11 sub gather {
  12     my ($self) = @_;
  13     my $pipe = $self->_open_locate_libdirs_pipe;
  14     my %libdir;
  15     while (defined( my $line = <$pipe> )) {
  16         chomp $line;
  17         $libdir{ $line } = $self->_gather_libdir_info($line);
  18     }
  19     return \%libdir;
  20 }
  21
  22 sub _gather_libdir_info {
  23     my ($self, $libdir) = @_;
  24     my %module;
  25     my $pipe = $self->_open_locate_pm_pipe($libdir);
  26     while (defined( my $line = <$pipe> )) {
  27         chomp $line;
  28         my $metadata = Module::Metadata->new_from_file($line);
  29         next unless $metadata->name;
  30         my $sha = Digest::SHA->new(256);
  31         $sha->addfile($line);
  32         push @{ $module{ $metadata->name } //= [] }, {
  33             file        => $line,
  34             version     => $metadata->version,
  35             size        => scalar(-s $line),
  36             sha256_hex  => $sha->hexdigest,
  37         };
  38     }
  39     return \%module;
  40 }
  41
  42 sub _open_locate_pm_pipe {
  43     my ($self, $libdir) = @_;
  44     my $command = sprintf
  45         q{find %s -name '*.pm'},
  46         $libdir;
  47     open my $pipe, '-|', $command
  48         or die "Unable to open pipe to '$command': $!\n";
  49     return $pipe;
  50 }
  51
  52 sub _open_locate_libdirs_pipe {
  53     my ($self) = @_;
  54     my $root = $self->root;
  55     $root .= '/'
  56         unless $root =~ m{/$};
  57     my $command = sprintf
  58         q{locate --regex '^%s.*lib/perl5$'},
  59         $root;
  60     open my $pipe, '-|', $command
  61         or die "Unable to open pipe to '$command': $!\n";
  62     return $pipe;
  63 }
  64
  65 1;
  66
  67 __END__
  68
  69 =head1 NAME
  70
  71 System::Introspector::LibDirs::Perl - Gather perl lib directory data
  72
  73 =head1 DESCRIPTION
  74
  75 Finds locations that look like L<local::lib> or comparable Perl library
  76 directories, and extracts module information from them.
  77
  78 =head1 ATTRIBUTES
  79
  80 =head2 root
  81
  82 This is the root path to be searched for library directories. Defaults
  83 to C</>.
  84
  85 =head1 SEE ALSO
  86
  87 =over
  88
  89 =item L<System::Introspector>
  90
  91 =back
  92
  93 =cut
  94