--- /dev/null
+package System::Introspector::Probe::Perls;
+use Moo;
+
+use System::Introspector::Util qw(
+ transform_exceptions
+ handle_from_command
+ fail
+);
+
+has root => (
+ is => 'ro',
+ default => sub { '/' },
+);
+
+sub gather {
+ my ($self) = @_;
+ return transform_exceptions {
+ my @configs = $self->_find_possible_perl_configs;
+ my %found;
+ for my $config (@configs) {
+ my $info = transform_exceptions {
+ return $self->_gather_info($config);
+ };
+ $found{$config} = $info
+ if defined $info;
+ }
+ return { perls => \%found };
+ };
+}
+
+sub _gather_info {
+ my ($self, $config) = @_;
+ open my $fh, '<', $config
+ or fail "Unable to determine '$config': $!";
+ my $first_line = <$fh>;
+ return undef
+ unless defined $first_line and $first_line =~ m{^#.+configpm};
+ my %info;
+ my $is_info;
+ LINE:
+ while (defined( my $line = <$fh> )) {
+ if ($line =~ m{tie\s+\%Config}) {
+ $is_info++;
+ next LINE;
+ }
+ chomp $line;
+ if ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*'(.*)',\s*$}i) {
+ $info{$1} = $2;
+ }
+ elsif ($line =~ m{^\s*([a-z0-9_]+)\s*=>\s*undef,$}i) {
+ $info{$1} = undef;
+ }
+ }
+ return {
+ (defined $info{scriptdir} and $info{version})
+ ? (executable => join('/', $info{scriptdir}, 'perl' . $info{version}))
+ : (),
+ config => \%info,
+ };
+}
+
+sub _find_possible_perl_configs {
+ my ($self) = @_;
+ (my $root = $self->root) =~ s{/$}{};
+ my $handle = handle_from_command sprintf
+ q{locate --regex '^%s/.*/Config.pm$'}, $root;
+ my @lines = <$handle>;
+ chomp @lines;
+ return @lines;
+}
+
+1;
--- /dev/null
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+package Config;
+use strict;
+# use warnings; Pulls in Carp
+# use vars pulls in Carp
+@Config::EXPORT = qw(%Config);
+@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+# Need to stub all the functions to make code such as print Config::config_sh
+# keep working
+
+sub myconfig;
+sub config_sh;
+sub config_vars;
+sub config_re;
+
+my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
+
+our %Config;
+
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+ my $pkg = shift;
+ @_ = @Config::EXPORT unless @_;
+
+ my @funcs = grep $_ ne '%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
+
+ no strict 'refs';
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die sprintf qq{"%s" is not exported by the %s module\n},
+ $func, __PACKAGE__ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
+
+ *{"$callpkg\::Config"} = \%Config if $export_Config;
+ return;
+}
+
+die "Perl lib version (5.10.0) doesn't match executable version ($])"
+ unless $^V;
+
+$^V eq 5.10.0
+ or die "Perl lib version (5.10.0) doesn't match executable version (" .
+ sprintf("v%vd",$^V) . ")";
+
+sub FETCH {
+ my($self, $key) = @_;
+
+ # check for cached value (which may be undef so we use exists not defined)
+ return $self->{$key} if exists $self->{$key};
+
+ return $self->fetch_string($key);
+}
+sub TIEHASH {
+ bless $_[1], $_[0];
+}
+
+sub DESTROY { }
+
+sub AUTOLOAD {
+ require 'Config_heavy.pl';
+ goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
+ die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
+}
+
+# tie returns the object, so the value returned to require will be true.
+tie %Config, 'Config', {
+ archlibexp => '/usr/lib/perl/5.10',
+ archname => 'x86_64-linux-gnu-thread-multi',
+ cc => 'cc',
+ d_readlink => 'define',
+ d_symlink => 'define',
+ dlsrc => 'dl_dlopen.xs',
+ dont_use_nlink => undef,
+ exe_ext => '',
+ inc_version_list => '',
+ intsize => '4',
+ ldlibpthname => 'LD_LIBRARY_PATH',
+ libpth => '/usr/local/lib /lib /usr/lib /lib64 /usr/lib64',
+ osname => 'linux',
+ osvers => '2.6.32-5-amd64',
+ path_sep => ':',
+ privlibexp => '/usr/share/perl/5.10',
+ scriptdir => '/usr/bin',
+ sitearchexp => '/usr/local/lib/perl/5.10.0',
+ sitelibexp => '/usr/local/share/perl/5.10.0',
+ useithreads => 'define',
+ usevendorprefix => 'define',
+ version => '5.10.0',
+};
--- /dev/null
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+# for a description of the variables, please have a look at the
+# Glossary file, as written in the Porting folder, or use the url:
+# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
+
+package Config;
+use strict;
+use warnings;
+use vars '%Config';
+
+# Skip @Config::EXPORT because it only contains %Config, which we special
+# case below as it's not a function. @Config::EXPORT won't change in the
+# lifetime of Perl 5.
+my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
+ config_re => 1, compile_date => 1, local_patches => 1,
+ bincompat_options => 1, non_bincompat_options => 1,
+ header_files => 1);
+
+@Config::EXPORT = qw(%Config);
+@Config::EXPORT_OK = keys %Export_Cache;
+
+# Need to stub all the functions to make code such as print Config::config_sh
+# keep working
+
+sub bincompat_options;
+sub compile_date;
+sub config_re;
+sub config_sh;
+sub config_vars;
+sub header_files;
+sub local_patches;
+sub myconfig;
+sub non_bincompat_options;
+
+# Define our own import method to avoid pulling in the full Exporter:
+sub import {
+ shift;
+ @_ = @Config::EXPORT unless @_;
+
+ my @funcs = grep $_ ne '%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
+
+ no strict 'refs';
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die qq{"$func" is not exported by the Config module\n}
+ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
+
+ *{"$callpkg\::Config"} = \%Config if $export_Config;
+ return;
+}
+
+die "Perl lib version (5.14.2) doesn't match executable '$0' version ($])"
+ unless $^V;
+
+$^V eq 5.14.2
+ or die "Perl lib version (5.14.2) doesn't match executable '$0' version (" .
+ sprintf("v%vd",$^V) . ")";
+
+
+sub FETCH {
+ my($self, $key) = @_;
+
+ # check for cached value (which may be undef so we use exists not defined)
+ return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
+}
+
+sub TIEHASH {
+ bless $_[1], $_[0];
+}
+
+sub DESTROY { }
+
+sub AUTOLOAD {
+ require 'Config_heavy.pl';
+ goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
+ die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
+}
+
+# tie returns the object, so the value returned to require will be true.
+tie %Config, 'Config', {
+ archlibexp => '/usr/local/apps-perl/lib/5.14.2/x86_64-linux',
+ archname => 'x86_64-linux',
+ cc => 'cc',
+ d_readlink => 'define',
+ d_symlink => 'define',
+ dlext => 'so',
+ dlsrc => 'dl_dlopen.xs',
+ dont_use_nlink => undef,
+ exe_ext => '',
+ inc_version_list => ' ',
+ intsize => '4',
+ ldlibpthname => 'LD_LIBRARY_PATH',
+ libpth => '/usr/local/lib /lib/../lib /usr/lib/../lib /lib /usr/lib /lib64 /usr/lib64 /usr/local/lib64',
+ osname => 'linux',
+ osvers => '2.6.21.7-2.fc8xen-ec2-v1.0',
+ path_sep => ':',
+ privlibexp => '/usr/local/apps-perl/lib/5.14.2',
+ scriptdir => '/usr/local/apps-perl/bin',
+ sitearchexp => '/usr/local/apps-perl/lib/site_perl/5.14.2/x86_64-linux',
+ sitelibexp => '/usr/local/apps-perl/lib/site_perl/5.14.2',
+ so => 'so',
+ useithreads => undef,
+ usevendorprefix => undef,
+ version => '5.14.2',
+};
--- /dev/null
+use strictures 1;
+use Test::More;
+use FindBin;
+
+use System::Introspector::Probe::Perls;
+
+do {
+ no warnings 'redefine';
+# *System::Introspector::Probe::Perls::_find_possible_perl_configs = sub {
+# map "$FindBin::Bin/data/perls/$_/lib/Config.pm", '5.10.0', '5.14.2',
+# };
+};
+
+my $probe = System::Introspector::Probe::Perls->new(
+# root => "$FindBin::Bin/data/perls",
+);
+
+my $result = $probe->gather;
+ok $result, 'received data';
+
+is $result->{__error__}, undef, 'no errors';
+
+use Data::Dump qw( pp );
+pp $result;
+
+done_testing;
projects / scpubgit/System-Introspector.git / commitdiff