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; |
9bd83260 |
20 | my %seen; |
820f978f |
21 | for my $config (@configs) { |
22 | my $info = transform_exceptions { |
23 | return $self->_gather_info($config); |
24 | }; |
9745213f |
25 | next if $info |
26 | and $info->{config}{sitelibexp} |
9bd83260 |
27 | and $seen{$info->{config}{sitelibexp}}++; |
820f978f |
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; |
f24afb0e |
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 |