Perl::Dist::WiX::Toolchain - Compiles the initial toolchain for a Win32 perl distribution.

  my $toolchain = Perl::Dist::WiX::Toolchain->new(
    perl_version => '5.012000',       # This is as could be returned from $].
	cpan         => URI::file('C:\\minicpan\'),
	bits         => 32,
  );

  $toolchain->delegate() or die $toolchain->get_error();

  my @dists;
  if (0 < $toolchain->dist_count()) {
	@dists = $toolchain->get_dists();
  }

  ...

  my @distribution_tarballs = $toolchain->get_dists();

  my $distribution_count = $toolchain->dist_count();

  $toolchain->get_error();

  $toolchain->delegate() or die $toolchain->get_error();

package Perl::Dist::WiX::Toolchain;

use 5.010;
use Moose 0.90;
use MooseX::NonMoose;
use MooseX::Types::Moose qw( Str Int Bool HashRef ArrayRef Maybe );
use MooseX::Types::URI qw( Uri );
use Moose::Util::TypeConstraints;
use English qw( -no_match_vars );
use Carp qw();
use Params::Util qw( _HASH );
use Module::CoreList 2.49 qw();
use IO::Capture::Stdout qw();
use IO::Capture::Stderr qw();
use vars qw(@DELEGATE);
use namespace::clean -except => 'meta';

our $VERSION = '1.500001';
$VERSION =~ s/_//ms;

extends qw(
  Process::Delegatable
  Process
);

# This is called by Moose::Object->new(), and just checks that we passed
# in a version of Perl that we know how to handle.
sub BUILD {
	my $self  = shift;
	my $class = ref $self;

	if ( not $self->_modules_exists( $self->_get_perl_version() ) ) {
		Carp::croak( q{Perl version '}
			  . $self->_get_perl_version()
			  . "' is not supported in $class" );
	}
	if ( not $self->_corelist_version_exists( $self->_get_perl_version() ) )
	{
		Carp::croak( q{Perl version '}
			  . $self->_get_perl_version()
			  . "' is not supported in $class" );
	}

} ## end sub BUILD

has perl_version => (
	is       => 'ro',
	isa      => Str,
	reader   => '_get_perl_version',
	required => 1,
);




has force => (
	traits  => ['Hash'],
	is      => 'ro',
	isa     => HashRef,
	default => sub { return {} },
	handles => {
		'_force_exists'    => 'exists',
		'_get_forced_dist' => 'get',
	},
);

has cpan => (
	is       => 'ro',
	isa      => Str,
	reader   => '_get_cpan',
	required => 1,
);

has bits => (
	is  => 'ro',                       # Integer 32/64
	isa => subtype(
		'Int' => where {
			$_ == 32 or $_ == 64;
		},
		message {
			'Must be a 32 or 64-bit perl';
		},
	),
	required => 1,
);


# These attributes are undocumented, and are private to the class.
# They may contain public accessors, and those will be documented.
has _modules => (
	traits   => ['Hash'],
	is       => 'bare',
	isa      => HashRef [ ArrayRef [Str] ],
	builder  => '_build_modules',
	lazy     => 1,
	init_arg => undef,
	handles  => {
		'_modules_exists' => 'exists',
		'_get_modules'    => 'get',
	},
);

sub _build_modules {
	my $self = shift;

	my @modules_list = ( 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
		  IPC::Run3
		  Probe::Perl
		  Test::Script
		  File::Which
		  File::HomeDir
		  Archive::Zip
		  Package::Constants
		  IO::String
		  Archive::Tar}
	);

	if ( 32 == $self->bits() ) {
		push @modules_list, 'Compress::unLZMA';
	}

	push @modules_list, qw{
	  Win32::UTCFileTime
	  CPAN::Meta::YAML
	  JSON::PP
	  Parse::CPAN::Meta
	  YAML
	  Net::FTP
	  Digest::MD5
	  Digest::SHA1
	  Digest::SHA
	  Module::Metadata
	  Perl::OSType
	  Version::Requirements
	  CPAN::Meta
	  Module::Build
	  Term::Cap
	  CPAN
	  Term::ReadKey
	  Term::ReadLine::Perl
	  Text::Glob
	  Data::Dumper
	  Pod::Text
	  URI
	  HTML::Tagset
	  HTML::Parser
	  LWP
	};

	my %modules = ( '5.010000' => \@modules_list, );
	$modules{'5.010001'} = $modules{'5.010000'};
	$modules{'5.012000'} = $modules{'5.010000'};
	$modules{'5.012001'} = $modules{'5.010000'};
	$modules{'5.012002'} = $modules{'5.010000'};
	$modules{'5.012003'} = $modules{'5.010000'};
	$modules{'5.014000'} = $modules{'5.010000'};

	return \%modules;
} ## end sub _build_modules



has _corelist_version => (
	traits   => ['Hash'],
	is       => 'bare',
	isa      => HashRef [Str],
	builder  => '_build_corelist_version',
	init_arg => undef,
	lazy     => 1,
	handles  => {
		'_corelist_version_exists' => 'exists',
		'_get_corelist_version'    => 'get',
	},
);



sub _build_corelist_version {

	my %corelist = (
		'5.010000' => '5.010000',
		'5.010001' => '5.010001',
		'5.012000' => '5.012000',
		'5.012001' => '5.012001',
		'5.012002' => '5.012002',
		'5.012003' => '5.012003',
		'5.014000' => '5.014000',
	);

	return \%corelist;
} ## end sub _build_corelist_version



has _corelist => (
	traits   => ['Hash'],
	is       => 'bare',
	isa      => HashRef,
	builder  => '_build_corelist',
	init_arg => undef,
	lazy     => 1,
	handles  => {
		'_corelist_exists' => 'exists',
		'_get_corelist'    => 'get',
	},
);



sub _build_corelist {
	my $self = shift;

	# Confirm we can find the corelist for the Perl version
	my $corelist_version =
	  $self->_get_corelist_version( $self->_get_perl_version() );
	my $corelist = $Module::CoreList::version{$corelist_version}
	  || $Module::CoreList::version{ $corelist_version + 0 };

	if ( not _HASH($corelist) ) {
		Carp::croak( 'Failed to find module core versions for Perl '
			  . $self->_get_perl_version() );
	}

	return $corelist;
} ## end sub _build_corelist

has _dists => (
	traits   => ['Array'],
	is       => 'bare',
	isa      => ArrayRef [Str],
	default  => sub { return [] },
	init_arg => undef,
	handles  => {
		'_push_dists'  => 'push',
		'get_dists'    => 'elements',
		'_grep_dists'  => 'grep',
		'_empty_dists' => 'clear',
		'dist_count'   => 'count',
	},
);



has _delegated => (
	traits   => ['Bool'],
	is       => 'ro',
	isa      => Bool,
	init_arg => undef,
	default  => 0,
	handles  => { '_delegate' => 'set', },
);

# Process::Delegatable sets this, this attribute just
# defines how to get at it.
has errstr => (
	is       => 'bare',
	isa      => Maybe [Str],
	init_arg => undef,
	default  => undef,
	reader   => 'get_error',
);


BEGIN {
	@DELEGATE = ();

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

sub delegate {
	my $self = shift;
	if ( not $self->_delegated() ) {
		$self->SUPER::delegate(@DELEGATE);
		$self->_delegate();
	}
	return 1;
}

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
	if (
		eval {
			local $SIG{__WARN__} = sub {1};
			if ( not $CPAN::Config_loaded++ ) {
				CPAN::HandleConfig->load();
			}
			$CPAN::Config->{'urllist'}    = [ $self->_get_cpan() ];
			$CPAN::Config->{'use_sqlite'} = q[0];
			CPAN::Index->reload();
			1;
		} )
	{
		$stdout->stop();
		$stderr->stop();
		return 1;
	} else {
		$stdout->stop();
		$stderr->stop();
		return 0;
	}
} ## end sub prepare

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();
	$stdout->start();
	$stderr->start();

	if ( not $CPAN::Config_loaded++ ) {
		CPAN::HandleConfig->load();
	}
	$CPAN::Config->{'urllist'}    = [ $self->_get_cpan() ];
	$CPAN::Config->{'use_sqlite'} = q[0];
	$stdout->stop();
	$stderr->stop();

	foreach
	  my $name ( @{ $self->_get_modules( $self->_get_perl_version() ) } )
	{

		# Shortcut if forced
		if ( $self->_force_exists($name) ) {
			$self->_push_dists( $self->_get_forced_dist($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();

		if ( not $module ) {
			## no critic (RequireCarping RequireUseOfExceptions)
			die "Failed to find '$name'";
		}

		# Ignore modules that don't need to be updated
		my $core_version = $self->_get_corelist($name);
		if ( defined $core_version and $core_version =~ /_/ms ) {

			# Sometimes, the core contains a developer
			# version. For the purposes of this comparison
			# it should be safe to "round down".
			$core_version =~ s{_.+}{}ms;
		}
		my $cpan_version = $module->cpan_version;
		if ( not 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 [[:upper:]] / [[:upper:]][[:upper:]] /}{}msx;
		$self->_push_dists($file);
	} ## end foreach my $name ( @{ $self...})

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

	$self->_empty_dists();
	$self->_push_dists(@dists);

	return 1;
} ## end sub run

__PACKAGE__->meta->make_immutable;

1;

__END__