lib/System/Introspector/Probe/Perls.pm

   1 package System::Introspector::Probe::Perls;
   2 use Moo;
   3
   4 use System::Introspector::Util qw(
   5     transform_exceptions
   6     handle_from_command
   7     fail
   8 );
   9
  10 has root => (
  11     is      => 'ro',
  12     default => sub { '/' },
  13 );
  14
  15 sub gather {
  16     my ($self) = @_;
  17     return transform_exceptions {
  18         my @configs = $self->_find_possible_perl_configs;
  19         my %found;
  20         my %seen;
  21         for my $config (@configs) {
  22             my $info = transform_exceptions {
  23                 return $self->_gather_info($config);
  24             };
  25             next if $info->{config}{sitelibexp}
  26                 and $seen{$info->{config}{sitelibexp}}++;
  27             $found{$config} = $info
  28                 if defined $info;
  29         }
  30         return { perls => \%found };
  31     };
  32 }
  33
  34 sub _gather_info {
  35     my ($self, $config) = @_;
  36     open my $fh, '<', $config
  37         or fail "Unable to determine '$config': $!";
  38     my $first_line = <$fh>;
  39     return undef
  40         unless defined $first_line and $first_line =~ m{^#.+configpm};
  41     my %info;
  42     my $is_info;
  43   LINE:
  44     while (defined( my $line = <$fh> )) {
  45         if ($line =~ m{tie\s+\%Config}) {
  46             $is_info++;
  47             next LINE;
  48         }
  49         chomp $line;
  50         if ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*'(.*)',\s*$}i) {
  51             $info{$1} = $2;
  52         }
  53         elsif ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*undef,$}i) {
  54             $info{$1} = undef;
  55         }
  56     }
  57     return {
  58         (defined $info{scriptdir} and $info{version})
  59         ? (executable => join('/', $info{scriptdir}, 'perl' . $info{version}))
  60         : (),
  61         config => \%info,
  62     };
  63 }
  64
  65 sub _find_possible_perl_configs {
  66     my ($self) = @_;
  67     (my $root = $self->root) =~ s{/$}{};
  68     my $handle = handle_from_command sprintf
  69         q{locate --regex '^%s/.*/Config.pm$'}, $root;
  70     my @lines = <$handle>;
  71     chomp @lines;
  72     return @lines;
  73 }
  74
  75 1;