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

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