From: Robert 'phaylon' Sedlacek Date: Tue, 10 Jul 2012 16:07:02 +0000 (+0000) Subject: perl interpreters probe and tests X-Git-Tag: v0.001_001~30 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=820f978f8a055210e2bda615ac36f4235d96f496;p=scpubgit%2FSystem-Introspector.git perl interpreters probe and tests --- diff --git a/lib/System/Introspector/Probe/Perls.pm b/lib/System/Introspector/Probe/Perls.pm new file mode 100644 index 0000000..d25e70c --- /dev/null +++ b/lib/System/Introspector/Probe/Perls.pm @@ -0,0 +1,72 @@ +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; diff --git a/t/data/perls/5.10.0/lib/Config.pm b/t/data/perls/5.10.0/lib/Config.pm new file mode 100644 index 0000000..af3ce80 --- /dev/null +++ b/t/data/perls/5.10.0/lib/Config.pm @@ -0,0 +1,94 @@ +# 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', +}; diff --git a/t/data/perls/5.14.2/lib/Config.pm b/t/data/perls/5.14.2/lib/Config.pm new file mode 100644 index 0000000..1cfb4b7 --- /dev/null +++ b/t/data/perls/5.14.2/lib/Config.pm @@ -0,0 +1,110 @@ +# 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', +}; diff --git a/t/perls.t b/t/perls.t new file mode 100644 index 0000000..f04348b --- /dev/null +++ b/t/perls.t @@ -0,0 +1,26 @@ +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;