File Coverage

blib/lib/Perl/Dist/Util/Toolchain.pm

Criterion	Covered	Total	%
statement	51	130	39.2
branch	7	34	20.5
condition	1	12	8.3
subroutine	14	22	63.6
pod	4	9	44.4
total	77	207	37.2

package Perl::Dist::Util::Toolchain;

use 5.005;
use strict;
use Carp                 ();
use Params::Util         qw{ _HASH _ARRAY };
use Module::CoreList     ();
use IO::Capture::Stdout  ();
use IO::Capture::Stderr  ();
use Process::Delegatable ();
use Process::Storable    ();
use Process              ();

use vars qw{$VERSION @ISA @DELEGATE};
BEGIN {
	$VERSION  = '1.16';
	@ISA      = qw{
		Process::Delegatable
		Process::Storable
		Process
	};
	@DELEGATE = ();

	# Automatically handle delegation within the test suite
	if ( $ENV{HARNESS_ACTIVE} ) {
		require Probe::Perl;
		@DELEGATE = (
			Probe::Perl->find_perl_interpreter, '-Mblib',
		);
	}
}

my %MODULES = (
	'5.008008' => [ qw{
		ExtUtils::MakeMaker
		File::Path
		ExtUtils::Command
		Win32API::File
		ExtUtils::Install
		ExtUtils::Manifest
		Test::Harness
		Test::Simple
		ExtUtils::CBuilder
		ExtUtils::ParseXS
		version
		Scalar::Util
		Compress::Raw::Zlib
		Compress::Raw::Bzip2
		IO::Compress::Base
		Compress::Bzip2
		IO::Zlib
		File::Spec
		File::Temp
		Win32::WinError
		Win32API::Registry
		Win32::TieRegistry
		File::HomeDir
		File::Which
		Archive::Zip
		Package::Constants
		IO::String
		Archive::Tar
		Compress::unLZMA
		Parse::CPAN::Meta
		YAML
		Net::FTP
		Digest::MD5
		Digest::SHA1
		Digest::SHA
		Module::Build
		Term::Cap
		CPAN
		Term::ReadKey
		Term::ReadLine::Perl
		Text::Glob
		Data::Dumper
		URI
		HTML::Tagset
		HTML::Parser
		LWP::UserAgent
	} ],
);
$MODULES{'5.010000'} = $MODULES{'5.008008'};
$MODULES{'5.008009'} = $MODULES{'5.008008'};

my %CORELIST = (
	'5.008008' => '5.008008',
	'5.008009' => '5.008008',
	'5.010000' => '5.010000',
);





#####################################################################
# Constructor and Accessors

sub new {
	my $class = shift;
	my $self  = bless { @_ }, $class;

	# Check the Perl version
	unless ( defined $self->perl_version ) {
		Carp::croak("Did not provide a perl_version param");
	}
	unless ( defined $self->{cpan} ) {
		Carp::croak("Did not provide a cpan param");
	}
	unless ( $MODULES{$self->perl_version} ) {
		Carp::croak("Perl version '" . $self->perl_version . "' is not supported in $class");
	}
	unless ( $CORELIST{$self->perl_version} ) {
		Carp::croak("Perl version '" . $self->perl_version . "' is not supported in $class");
	}

	# Populate the modules array if needed
	unless ( _ARRAY($self->{modules}) ) {
		$self->{modules}  = $MODULES{$self->perl_version};
	}

	# Confirm we can find the corelist for the Perl version
	my $corelist_version = $CORELIST{$self->perl_version};
	$self->{corelist} = $Module::CoreList::version{$corelist_version}
	                 || $Module::CoreList::version{$corelist_version+0};
	unless ( _HASH($self->{corelist}) ) {
		Carp::croak("Failed to find module core versions for Perl " . $self->perl_version);
	}

	# Check forced dists, if applicable
	if ( $self->{force} and ! _HASH($self->{force}) ) {
		Carp::croak("The force param must be a HASH reference");
	}

	# Create the distribution array
	$self->{dists} = [];

	return $self;
}

sub perl_version {
	$_[0]->{perl_version};
}

sub modules {
	@{$_[0]->{modules}};
}

sub dists {
	@{$_[0]->{dists}};
}

sub errstr {
	$_[0]->{errstr};
}

sub prepare {
	my $self = shift;

	# Squash all output that CPAN might spew during this process
	my $stdout = IO::Capture::Stdout->new;
	my $stderr = IO::Capture::Stderr->new;
	$stdout->start;
	$stderr->start;

	# Load the CPAN client
	require CPAN;
	CPAN->import();

	# Load the latest index
	eval {
		local $SIG{__WARN__} = sub { 1 };
		CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
		$CPAN::Config->{'urllist'} = [ $self->{cpan} ];
		$CPAN::Config->{'use_sqlite'} = q[0];
		CPAN::Index->reload;
	};

	$stdout->stop;
	$stderr->stop;

	return $@ ? '' : 1;
}

sub run {
	my $self = shift;

	# Squash all output that CPAN might spew during this process
	my $stdout = IO::Capture::Stdout->new;
	my $stderr = IO::Capture::Stderr->new;

	# Find the module
	my $core = delete $self->{corelist};

	$stdout->start;		$stderr->start;
	CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
	$CPAN::Config->{'urllist'} = [ $self->{cpan} ];
	$CPAN::Config->{'use_sqlite'} = q[0];
	$stdout->stop;		$stderr->stop;

	foreach my $name ( @{$self->{modules}} ) {
		# Shortcut if forced
		if ( $self->{force}->{$name} ) {
			push @{$self->{dists}}, $self->{force}->{$name};
			next;
		}

		# Get the CPAN object for the module, covering any output.
		$stdout->start;		$stderr->start;
		my $module = CPAN::Shell->expand('Module', $name);
		$stdout->stop;		$stderr->stop;
		unless ( $module ) {
			die "Failed to find '$name'";
		}

		# Ignore modules that don't need to be updated
		my $core_version = $core->{$name};
		if ( defined $core_version and $core_version =~ /_/ ) {
			# Sometimes, the core contains a developer
			# version. For the purposes of this comparison
			# it should be safe to "round down".
			$core_version =~ s/_.+$//;
		}
		my $cpan_version = $module->cpan_version;
		unless ( defined $cpan_version ) {
			next;
		}
		if ( defined $core_version and $core_version >= $cpan_version ) {
			next;
		}

		# Filter out already seen dists
		my $file = $module->cpan_file;
		$file =~ s/^[A-Z]\/[A-Z][A-Z]\///;
		push @{$self->{dists}}, $file;
	}

	# Remove duplicates
	my %seen = ();
	@{$self->{dists}} = grep { ! $seen{$_}++ } @{$self->{dists}};

	return 1;
}

sub delegate {
	my $self = shift;
	unless ( $self->{delegated} ) {
		$self->SUPER::delegate( @DELEGATE );
		$self->{delegated} = 1;
	}
	return 1;
}

sub delegated {
	$_[0]->{delegated};
}

1;