Commit | Line | Data |
820f978f |
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; |