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
  26                 and $info->{config}{sitelibexp}
  27                 and $seen{$info->{config}{sitelibexp}}++;
  28             $found{$config} = $info
  29                 if defined $info;
  30         }
  31         return { perls => \%found };
  32     };
  33 }
  34
  35 sub _gather_info {
  36     my ($self, $config) = @_;
  37     open my $fh, '<', $config
  38         or fail "Unable to determine '$config': $!";
  39     my $first_line = <$fh>;
  40     return undef
  41         unless defined $first_line and $first_line =~ m{^#.+configpm};
  42     my %info;
  43     my $is_info;
  44   LINE:
  45     while (defined( my $line = <$fh> )) {
  46         if ($line =~ m{tie\s+\%Config}) {
  47             $is_info++;
  48             next LINE;
  49         }
  50         chomp $line;
  51         if ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*'(.*)',\s*$}i) {
  52             $info{$1} = $2;
  53         }
  54         elsif ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*undef,$}i) {
  55             $info{$1} = undef;
  56         }
  57     }
  58     return {
  59         (defined $info{scriptdir} and $info{version})
  60         ? (executable => join('/', $info{scriptdir}, 'perl' . $info{version}))
  61         : (),
  62         config => \%info,
  63     };
  64 }
  65
  66 sub _find_possible_perl_configs {
  67     my ($self) = @_;
  68     (my $root = $self->root) =~ s{/$}{};
  69     my $handle = handle_from_command sprintf
  70         q{locate --regex '^%s/.*/Config.pm$'}, $root;
  71     my @lines = <$handle>;
  72     chomp @lines;
  73     return @lines;
  74 }
  75
  76 1;
  77
  78 __END__
  79
  80 =head1 NAME
  81
  82 System::Introspector::Probe::Perls - Locate perl installations
  83
  84 =head1 DESCRIPTION
  85
  86 Tries to locate perl installations on the system and collects
  87 information about them.
  88
  89 =head1 SEE ALSO
  90
  91 =over
  92
  93 =item L<System::Introspector>
  94
  95 =back
  96
  97 =head1 COPYRIGHT
  98
  99 Copyright (c) 2012 the L<System::Introspector>
 100 L<AUTHOR|System::Introspector/AUTHOR>,
 101 L<CONTRIBUTORS|System::Introspector/CONTRIBUTORS> and
 102 L<SPONSORS|System::Introspector/SPONSORS>.
 103
 104 =head1 LICENSE
 105
 106 This library is free software and may be distributed under the same terms
 107 as perl itself.
 108
 109 =cut