Perl::Dist::WiX::Util::Machine - Generate an entire set of related distributions

	# This is what Perl::Dist::Strawberry will do, as of version 2.03.

	# Create the machine
	my $machine = Perl::Dist::WiX::Util::Machine->new(
		class  => 'Perl::Dist::Strawberry',
		common => [ forceperl => 1 ],
		skip   => [4, 6],
	);

	# Set the different versions
	$machine->add_dimension('version');
	$machine->add_option('version',
		perl_version => '5101',
	);
	$machine->add_option('version',
		perl_version => '5101',
		portable     => 1,
	);
	$machine->add_option('version',
		perl_version => '5121',
		relocatable  => 1,
	);

	# Set the different paths
	$machine->add_dimension('drive');
	$machine->add_option('drive',
		image_dir => 'C:\strawberry',
	);
	$machine->add_option('drive',
		image_dir => 'D:\strawberry',
		msi       => 1,
		zip       => 0,
	);

	$machine->run();
	# Creates 8 distributions (really 6, because you can't have
	# portable => 1 and zip => 0 for the same distribution,
	# nor do we need to build a relocatable version twice.)	

	my $machine = Perl::Dist::WiX::Util::Machine->new(
		class => 'Perl::Dist::WiX',
		common => { forceperl => 1, },
		output => 'C:\',
		trace  => 2,
	);

   1: 1, 1, 1   2: 1, 1, 2   3: 1, 2, 1   4: 1, 2, 2
   5: 2, 1, 1 ...   
   9: 3, 1, 1 ...

	$machine->add_dimension('perl_version');

  $machine->add_option('perl_version',
    perl_version => '5120',
    relocatable => 1,
  );

	my @dists = $machine->all();

	my $dist = $machine->next();

	$machine->run();

package Perl::Dist::WiX::Util::Machine;

#<<<
use 5.010;
use Moose 0.90;
use Moose::Util::TypeConstraints;
use MooseX::Types::Moose         qw( Str ArrayRef HashRef Bool Int );
use Params::Util                 qw( _IDENTIFIER _HASH0 _DRIVER _CLASSISA );
use English                      qw( -no_match_vars );
use File::Copy                   qw();
use File::Copy::Recursive        qw();
use File::Path              2.08 qw( remove_tree );
use File::Spec::Functions        qw( catdir );
use File::Remove                 qw();
use File::HomeDir                qw();
use List::MoreUtils              qw( none );
use WiX3::Traceable              qw();
use Perl::Dist::WiX::Exceptions  qw();
#>>>

our $VERSION = '1.500002';

has class => (
	is  => 'ro',
	isa => subtype(
		'Str' => where {
			$_ ||= q{};
			_CLASSISA( $_, 'Perl::Dist::WiX' );
		},
		message {
			'Not a subclass of Perl::Dist::WiX.';
		},
	),
	required => 1,
	reader   => '_get_class',
);

has common => (
	traits   => ['Array'],
	is       => 'bare',
	isa      => ArrayRef,
	required => 1,
	handles  => { '_get_common' => 'elements', },
);

has output => (
	is      => 'ro',
	isa     => Str,
	default => sub { return File::HomeDir->my_desktop(); },
	reader  => '_get_output',
);

has skip => (
	traits  => ['Array'],
	is      => 'bare',
	isa     => ArrayRef,
	default => sub { return [0]; },
	handles => { '_get_skip_values' => 'elements', },
);

has trace => (
	is      => 'ro',
	isa     => Int,
	default => 1,
	reader  => '_get_trace',
);



has _dimensions => (
	traits   => ['Array'],
	is       => 'bare',
	isa      => ArrayRef,
	default  => sub { return []; },
	init_arg => undef,
	handles  => {
		'_add_dimension'  => 'push',
		'_get_dimensions' => 'elements',
	},
);

has _options => (
	traits   => ['Hash'],
	is       => 'bare',
	isa      => HashRef,
	default  => sub { return {}; },
	init_arg => undef,
	handles  => {
		'_set_options'   => 'set',
		'_option_exists' => 'exists',
		'_get_options'   => 'get',

	},
);

has _state => (
	traits   => ['Hash'],
	is       => 'bare',
	isa      => HashRef,
	default  => sub { return {} },
	init_arg => undef,
	handles  => {
		'_has_state' => 'count',
		'_set_state' => 'set',
		'_get_state' => 'get',
	},
);

has _eos => (
	traits   => ['Bool'],
	is       => 'bare',
	isa      => Bool,
	default  => 0,
	init_arg => undef,
	reader   => '_get_eos',
	handles  => { '_set_eos' => 'set', },
);

has _traceobject => (
	is       => 'bare',
	init_arg => undef,
	lazy     => 1,
	reader   => '_get_traceobject',
	builder  => '_build_traceobject',
);

sub _build_traceobject {
	my $self = shift;

	return WiX3::Traceable->new( tracelevel => $self->_get_trace() );
}


#####################################################################
# Constructor

sub BUILDARGS {
	my $class = shift;
	my %args;

	if ( @_ == 1 && 'HASH' eq ref $_[0] ) {
		%args = %{ $_[0] };
	} elsif ( 0 == @_ % 2 ) {
		%args = (@_);
	} else {
		PDWiX->throw( 'Parameters incorrect (not a hashref or hash)'
			  . 'for Perl::Dist::WiX::Util::Machine' );
	}

	if ( _HASH0( $args{common} ) ) {
		$args{common} = [ %{ $args{common} } ];
	}

	return \%args;
} ## end sub BUILDARGS

sub BUILD {
	my $self = shift;

	# Check params
	if ( not _DRIVER( $self->_get_class(), 'Perl::Dist::WiX' ) ) {
		PDWiX->throw('Missing or invalid class param');
	}

	my $output = $self->_get_output();
	if ( not -d $output or not -w $output ) {
		PDWiX->throw( "The output directory '$output' does not "
			  . 'exist, or is not writable' );
	}

	return $self;
} ## end sub BUILD




#####################################################################
# Setup Methods

sub add_dimension {
	my $self = shift;
	my $name = _IDENTIFIER(shift)
	  or PDWiX->throw('Missing or invalid dimension name');
	if ( $self->_has_state() ) {
		PDWiX->throw('Cannot alter params once iterating');
	}
	if ( $self->_option_exists($name) ) {
		PDWiX->throw("The dimension '$name' already exists");
	}

	$self->_add_dimension($name);
	$self->_set_options( $name => [] );
	return 1;
} ## end sub add_dimension

sub add_option {
	my $self = shift;
	my $name = _IDENTIFIER(shift)
	  or PDWiX->throw('Missing or invalid dimension name');
	if ( $self->_has_state() ) {
		PDWiX->throw('Cannot alter params once iterating');
	}
	if ( not $self->_option_exists($name) ) {
		PDWiX->throw("The dimension '$name' does not exist");
	}
	my $option = $self->_get_options($name);
	push @{$option}, [@_];
	$self->_set_options( $name => $option );
	return 1;
} ## end sub add_option




#####################################################################
# Iterator Methods

sub _increment_state {
	my $self = shift;
	my $name = shift;

	my $number = $self->_get_state($name);
	$self->_set_state( $name, ++$number );

	return;
}

sub all {
	my $self    = shift;
	my @objects = ();
	while (1) {
		my $object = $self->next() or last;
		push @objects, $object;
	}
	return @objects;
}

sub next { ## no critic (ProhibitBuiltinHomonyms)
	## no critic (ProhibitExplicitReturnUndef)
	my $self = shift;
	if ( $self->_get_eos() ) {

		# Already at last state
		return undef;
	}

	# Initialize the iterator if needed
	if ( $self->_has_state() ) {

		# Move to the next position
		my $found = 0;
		foreach my $name ( $self->_get_dimensions() ) {
			if ( $self->_get_state($name) !=
				$#{ $self->_get_options($name) } )
			{

				# Normal iteration
				$self->_increment_state($name);
				$found = 1;
				last;
			}

			# We've hit the end of a dimension.
			# Loop the state to the start, so the
			# next dimension will iterate to the
			# correct value.
			$self->_set_state( $name => 0 );
		} ## end foreach my $name ( $self->_get_dimensions...)
		if ( not $found ) {
			$self->_set_eos();
			return undef;
		}
	} else {

		# Initialize to the first position
		my %state;
		foreach my $name ( $self->_get_dimensions() ) {
			if ( not @{ $self->_get_options($name) } ) {
				PDWiX->throw("No options for dimension '$name'");
			}
			$state{$name} = 0;
		}
		$self->_set_state(%state);

	} ## end else [ if ( $self->_has_state...)]

	# Create the parameter-set
	my @params = $self->_get_common();
	foreach my $name ( $self->_get_dimensions() ) {
		my $i = $self->_get_state($name);
		push @params, @{ $self->_get_options($name)->[$i] };
	}
	push @params, ( '_trace_object' => $self->_get_traceobject() );
	push @params, ( 'trace'         => $self->_get_trace() );

	# Create the object with those params
	return $self->_get_class()->new(@params);
} ## end sub next





#####################################################################
# Execution Methods

sub run {
	my $self       = shift;
	my $success    = 0;
	my $output_dir = $self->_get_output();
	my $num        = 0;

	while ( my $dist = $self->next() ) {
		$dist->prepare();
		$num++;
		if ( none { $_ == $num } $self->_get_skip_values() ) {
			$success = eval { $dist->run(); 1; };

			if ($success) {

				# Copy the output products for this run to the
				# main output area.
				foreach my $file ( $dist->get_output_files() ) {
					File::Copy::copy( $file, $output_dir );
				}
				File::Copy::Recursive::dircopy( $dist->output_dir(),
					catdir( $output_dir, "success-output-$num" ) );
				File::Copy::Recursive::dircopy( $dist->fragment_dir(),
					catdir( $output_dir, "success-fragments-$num" ) );
			} else {
				print $EVAL_ERROR;
				File::Copy::Recursive::dircopy( $dist->output_dir(),
					catdir( $output_dir, "error-output-$num" ) );
			}
		} else {
			print "\n\nSkipping build number $num.";
		}

		print "\n\n\n\n\n";
		print q{-} x 60;
		print "\n\n\n\n\n";

		# Flush out the image dir for the next run
		my $err;
		my $dir = $dist->image_dir();
		remove_tree(
			"$dir",
			{   keep_root => 1,
				error     => \$err,
			} );
		my $e = $EVAL_ERROR;

		if ($e) {
			PDWiX::Directory->throw(
				dir     => $dir,
				message => "Failed to remove directory, critical error:\n$e"
			);
		}
		if ( @{$err} ) {
			my $errors = q{};
			for my $diag ( @{$err} ) {
				my ( $file, $message ) = %{$diag};
				if ( $file eq q{} ) {
					$errors .= "General error: $message\n";
				} else {
					$errors .= "Problem removing $file: $message\n";
				}
			}
			PDWiX::Directory->throw(
				dir     => $dir,
				message => "Failed to remove directory, errors:\n$errors"
			);
		} ## end if ( @{$err} )
	} ## end while ( my $dist = $self->next...)
	return 1;
} ## end sub run

1;