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         for my $config (@configs) {
  21             my $info = transform_exceptions {
  22                 return $self->_gather_info($config);
  23             };
  24             $found{$config} = $info
  25                 if defined $info;
  26         }
  27         return { perls => \%found };
  28     };
  29 }
  30
  31 sub _gather_info {
  32     my ($self, $config) = @_;
  33     open my $fh, '<', $config
  34         or fail "Unable to determine '$config': $!";
  35     my $first_line = <$fh>;
  36     return undef
  37         unless defined $first_line and $first_line =~ m{^#.+configpm};
  38     my %info;
  39     my $is_info;
  40   LINE:
  41     while (defined( my $line = <$fh> )) {
  42         if ($line =~ m{tie\s+\%Config}) {
  43             $is_info++;
  44             next LINE;
  45         }
  46         chomp $line;
  47         if ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*'(.*)',\s*$}i) {
  48             $info{$1} = $2;
  49         }
  50         elsif ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*undef,$}i) {
  51             $info{$1} = undef;
  52         }
  53     }
  54     return {
  55         (defined $info{scriptdir} and $info{version})
  56         ? (executable => join('/', $info{scriptdir}, 'perl' . $info{version}))
  57         : (),
  58         config => \%info,
  59     };
  60 }
  61
  62 sub _find_possible_perl_configs {
  63     my ($self) = @_;
  64     (my $root = $self->root) =~ s{/$}{};
  65     my $handle = handle_from_command sprintf
  66         q{locate --regex '^%s/.*/Config.pm$'}, $root;
  67     my @lines = <$handle>;
  68     chomp @lines;
  69     return @lines;
  70 }
  71
  72 1;