File Coverage

blib/lib/Test/Perl/Dist.pm

Criterion	Covered	Total	%
statement	37	39	94.8
branch			n/a
condition			n/a
subroutine	13	13	100.0
pod			n/a
total	50	52	96.1

package Test::Perl::Dist;

use strict;
use warnings;
use 5.008001;
use Test::More 0.88 import => ['!done_testing'];
use Test::Builder;
use parent qw( Exporter );
use English qw( -no_match_vars );
use Scalar::Util qw( blessed );
use LWP::Online qw( :skip_all );
use File::Spec::Functions qw( :ALL );
use File::Path qw();
use File::Remove qw();
use Win32 qw();
use URI qw();

our @EXPORT =
  qw(test_run_dist test_verify_files_short test_verify_files_medium
  test_verify_files_long test_verify_portability test_cleanup);
push @EXPORT, @Test::More::EXPORT;

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

my $tests_completed = 0;



#####################################################################
# Default Paths

sub _make_path {
	my $dir = rel2abs( catdir( curdir(), @_ ) );
	if ( not -d $dir ) {
		File::Path::mkpath($dir);
	}
	ok( -d $dir, 'Created ' . $dir );
	$tests_completed++;
	return $dir;
}

sub _remake_path {
	my $dir = rel2abs( catdir( curdir(), @_ ) );
	if ( -d $dir ) {
		File::Remove::remove( \1, $dir );
	}
	File::Path::mkpath($dir);
	ok( -d $dir, 'Created ' . $dir );
	$tests_completed++;
	return $dir;
}

sub _paths {
	my $class    = shift;
	my $subpath  = shift || q{};
	my $testpath = shift || 't';

	# Create base and download directory so we can do a
	# GetShortPathName on it.
	my $basedir  = rel2abs( catdir( $testpath, "tmp$subpath" ) );
	my $download = rel2abs( catdir( $testpath, 'download' ) );

	if ( $basedir =~ m{\s}sm ) {
		plan( skip_all =>
			  'Cannot test successfully in a test directory with spaces' );
	}

	if ( not -d $basedir ) {
		File::Path::mkpath($basedir);
	}
	if ( not -d $download ) {
		File::Path::mkpath($download);
	}
	diag("Test base directory: $basedir");

	# Make or remake the subpaths
	my $output_dir = _remake_path( catdir( $basedir, 'output' ) );
	my $image_dir  = _remake_path( catdir( $basedir, 'image' ) );
	my $download_dir = _make_path($download);
	my $fragment_dir = _remake_path( catdir( $basedir, 'fragments' ) );
	my $build_dir    = _remake_path( catdir( $basedir, 'build' ) );
	my $tempenv_dir  = _remake_path( catdir( $basedir, 'tempdir' ) );
	return (
		output_dir   => $output_dir,
		image_dir    => $image_dir,
		download_dir => $download_dir,
		build_dir    => $build_dir,
		fragment_dir => $fragment_dir,
		temp_dir     => $basedir,
		tempenv_dir  => $tempenv_dir,
	);
} ## end sub _paths

sub _cpan_release {
	my $class = shift;
	if ( defined $ENV{PERL_RELEASE_TEST_PERLDIST_CPAN} ) {
		return (
			cpan => URI->new( $ENV{PERL_RELEASE_TEST_PERLDIST_CPAN} ) );
	} else {
		return ();
	}
}

sub _forceperl {
	my $class = shift;
	if ( defined $ENV{PERL_RELEASE_TEST_FORCEPERL} ) {
		return ( forceperl => 1 );
	} else {
		return ();
	}
}

sub _force {
	my $class = shift;
	if ( defined $ENV{PERL_RELEASE_TEST_FORCE} ) {
		return ( force => 1 );
	} else {
		return ();
	}
}



sub new_test_class_short {
	my $self          = shift;
	my $test_number   = shift;
	my $test_version  = shift;
	my $class_to_test = shift;
	my $testpath      = shift;

	if ( $OSNAME ne 'MSWin32' ) {
		plan( skip_all => 'Not on Win32' );
	}
	if ( rel2abs( curdir() ) =~ m{[.]}ms ) {
		plan( skip_all =>
			  'Cannot be tested in a directory with an extension.' );
	}

	my $test_class =
	  $self->_create_test_class_short( $test_number, $test_version,
		$class_to_test );
	my $test_object = eval {
		my $obj =
		  $test_class->new( $self->_paths( $test_number, $testpath ),
			$self->_cpan_release(), $self->_forceperl(), $self->_force(),
			@_ );
		return $obj;
	};
	if ($EVAL_ERROR) {
		if ( blessed($EVAL_ERROR)
			&& $EVAL_ERROR->isa('Exception::Class::Base') )
		{
			diag( $EVAL_ERROR->as_string );
		} else {
			diag($EVAL_ERROR);
		}

		# Time to get out.
		BAIL_OUT('Error in test object creation.');
	} ## end if ($EVAL_ERROR)

	isa_ok( $test_object, $class_to_test );
	$tests_completed++;

	return $test_object;
} ## end sub new_test_class_short



sub new_test_class_medium {
	my $self          = shift;
	my $test_number   = shift;
	my $test_version  = shift;
	my $class_to_test = shift;
	my $testpath      = shift;

	if ( $OSNAME ne 'MSWin32' ) {
		plan( skip_all => 'Not on Win32' );
	}
	if ( not -d 'blib') {
		plan( skip_all => 'Perl::Dist::WiX::Toolchain has problems if ' .
		'dmake or Build has not been ran before testing.' );
	}
	if ( rel2abs( curdir() ) =~ m{[.]}ms ) {
		plan( skip_all =>
			  'Cannot be tested in a directory with an extension.' );
	}

	my $test_class =
	  $self->_create_test_class_medium( $test_number, $test_version,
		$class_to_test );
	my $test_object = eval {
		$test_class->new( $self->_paths( $test_number, $testpath ),
			$self->_cpan_release(), $self->_forceperl(), $self->_force(),
			@_ );
	};

	if ($EVAL_ERROR) {
		if ( blessed($EVAL_ERROR)
			&& $EVAL_ERROR->isa('Exception::Class::Base') )
		{
			diag( $EVAL_ERROR->as_string() );
		} else {
			diag($EVAL_ERROR);
		}

		# Time to get out.
		BAIL_OUT('Error in test object creation.');
	} ## end if ($EVAL_ERROR)

	isa_ok( $test_object, $class_to_test );
	$tests_completed++;

	return $test_object;
} ## end sub new_test_class_medium



sub new_test_class_long {
	my $self          = shift;
	my $test_number   = shift;
	my $test_version  = shift;
	my $class_to_test = shift;
	my $testpath      = shift;

	if ( $OSNAME ne 'MSWin32' ) {
		plan( skip_all => 'Not on Win32' );
	}
	if ( not -d 'blib') {
		plan( skip_all => 'Perl::Dist::WiX::Toolchain has problems if ' .
		'dmake or Build has not been ran before testing.' );
	}
	if ( rel2abs( curdir() ) =~ m{[.]}ms ) {
		plan( skip_all =>
			  'Cannot be tested in a directory with an extension.' );
	}

	my $test_class =
	  $self->_create_test_class_long( $test_number, $test_version,
		$class_to_test );
	my $test_object = eval {
		$test_class->new( $self->_paths( $test_number, $testpath ),
			$self->_cpan_release(), $self->_forceperl(), $self->_force(),
			@_ );
	};

	if ($EVAL_ERROR) {
		if ( blessed($EVAL_ERROR)
			&& $EVAL_ERROR->isa('Exception::Class::Base') )
		{
			diag( $EVAL_ERROR->as_string );
		} else {
			diag($EVAL_ERROR);
		}

		# Time to get out.
		BAIL_OUT('Error in test object creation.');
	} ## end if ($EVAL_ERROR)

	isa_ok( $test_object, $class_to_test );
	$tests_completed++;

	return $test_object;
} ## end sub new_test_class_long



sub test_run_dist {
	my $dist = shift;

	# Run the dist object, and ensure everything we expect was created
	my $time  = scalar localtime;
	my $class = ref $dist;
	if ( $class !~ m/::Short/msx ) {
		diag("Building test dist @ $time.");
		if ( $class =~ m/::Long/msx ) {
			diag('Building may take several hours... (sorry)');
		} else {
			diag('Building may take an hour or two... (sorry)');
		}
	}
	ok( eval { $dist->run; 1; }, '->run ok' );
	if ($EVAL_ERROR) {
		if ( blessed($EVAL_ERROR)
			&& $EVAL_ERROR->isa('Exception::Class::Base') )
		{
			diag( $EVAL_ERROR->as_string );
		} else {
			diag($EVAL_ERROR);
		}
		BAIL_OUT('Could not run test object.');
	}
	$time = scalar localtime;
	if ( $class !~ m/::Short/msx ) {
		diag("Test dist finished @ $time.");
	}
	$tests_completed++;

	return;
} ## end sub test_run_dist



sub test_verify_files_short {
	my $test_number = shift;
	my $testpath = shift || 't';
	my $test_dir =
	  catdir( $testpath, "tmp$test_number", qw{ image c bin } );

	ok( -f catfile( $test_dir, qw{ dmake.exe } ), 'Found dmake.exe' );

	ok( -f catfile( $test_dir, qw{ startup Makefile.in } ),
		'Found startup' );

	$tests_completed += 2;

	return;
} ## end sub test_verify_files_short



sub test_verify_files_medium {
	my $test_number = shift;
	my $dll_version = shift;
	my $testpath    = shift || 't';

	my $dll_file = "perl${dll_version}.dll";
	my $test_dir = catdir( $testpath, "tmp$test_number", 'image' );

	# C toolchain files
	ok( -f catfile( $test_dir, qw{ c bin dmake.exe } ), 'Found dmake.exe',
	);
	ok( -f catfile( $test_dir, qw{ c bin startup Makefile.in } ),
		'Found startup',
	);
	ok( -f catfile( $test_dir, qw{ c bin pexports.exe } ),
		'Found pexports',
	);

	# Perl core files
	ok( -f catfile( $test_dir, qw{ perl bin perl.exe } ),
		'Found perl.exe',
	);

	if ( -f catfile( $test_dir, qw{ image portable.perl } ) ) {

		# Toolchain files
		ok( -f catfile( $test_dir, qw{ perl site lib LWP.pm } ),
			'Found LWP.pm', );

		# Custom installed file
		ok( -f catfile( $test_dir, qw{ perl site lib Config Tiny.pm } ),
			'Found Config::Tiny',
		);
	} else {

		# Toolchain files
		ok( -f catfile( $test_dir, qw{ perl vendor lib LWP.pm } ),
			'Found LWP.pm', );

		# Custom installed file
		ok( -f catfile( $test_dir, qw{ perl vendor lib Config Tiny.pm } ),
			'Found Config::Tiny',
		);
	}

	# Did we build Perl correctly?
	ok( -f catfile( $test_dir, qw{ perl bin }, $dll_file ),
		'Found Perl DLL',
	);

	$tests_completed += 7;

	return;
} ## end sub test_verify_files_medium



sub _create_test_class_short {
	my $self         = shift;
	my $test_number  = shift;
	my $test_version = shift;
	my $test_class   = shift;
	my $answer       = "Test::Perl::Dist::Short$test_number";

	my $code = <<"EOF";
		require $test_class;

		\@${answer}::ISA = ( "$test_class" );

		###############################################################
		# Configuration


		###############################################################
		# Main Methods

		sub ${answer}::new {
			return shift->${test_class}::new(
				perl_version  => $test_version,
				trace         => 1,
				build_number  => 1,
				app_publisher_url => 'http://vanillaperl.org',
				tasklist      => [qw(final_initialization install_dmake)],
				app_ver_name  => 'Test Perl 1 alpha 1',
				app_name      => 'Test Perl',
				app_publisher => 'Vanilla Perl Project',
				app_id        => 'testperl',
				\@_,
			);
		}
EOF

	eval $code;
	return $answer;
} ## end sub _create_test_class_short



sub _create_test_class_medium {
	my $self         = shift;
	my $test_number  = shift;
	my $test_version = shift;
	my $test_class   = shift;
	my $answer       = "Test::Perl::Dist::Medium$test_number";

	eval <<"EOF";
		require $test_class;

		\@${answer}::ISA = ( "$test_class" );

		###############################################################
		# Main Methods

		sub ${answer}::new {
			return shift->${test_class}::new(
				perl_version => $test_version,
				trace => 1,
				build_number => 1,
				app_publisher_url => 'http://vanillaperl.org',
				app_name      => 'Test Perl',
				app_ver_name  => 'Test Perl 1 alpha 1',
				app_publisher => 'Vanilla Perl Project',
				app_id        => 'testperl',
				tasklist      => [ qw(
					final_initialization
					install_c_toolchain
					install_perl
					install_perl_toolchain
					test_distro
					regenerate_fragments
					write
				)],
				\@_,
			);
		}

		sub ${answer}::test_distro {
			my \$self = shift;
			if (\$self->portable()) {
				\$self->install_distribution(
					name             => 'ADAMK/Config-Tiny-2.12.tar.gz',
					mod_name         => 'Config::Tiny',
					makefilepl_param => ['INSTALLDIRS=site'],
				);
			} else {
				\$self->install_distribution(
					name             => 'ADAMK/Config-Tiny-2.12.tar.gz',
					mod_name         => 'Config::Tiny',
					makefilepl_param => ['INSTALLDIRS=vendor'],
				);
			}
			return 1;
		}
EOF

	return $answer;
} ## end sub _create_test_class_medium



sub _create_test_class_long {
	my $self         = shift;
	my $test_number  = shift;
	my $test_version = shift;
	my $test_class   = shift;
	my $answer       = "Test::Perl::Dist::Long$test_number";

	eval <<"EOF";
		require $test_class;

		\@${answer}::ISA = ( "$test_class" );

		###############################################################
		# Main Methods

		sub ${answer}::new {
			return shift->${test_class}::new(
				perl_version => $test_version,
				trace => 1,
				build_number => 1,
				app_publisher_url => 'http://vanillaperl.org',
				app_name          => 'Test Perl',
				app_ver_name      => 'Test Perl 1 alpha 1',
				app_publisher     => 'Vanilla Perl Project',
				app_id            => 'testperl',
				\@_,
			);
		}

		sub ${answer}::install_cpan_upgrades {
			my \$self = shift;
			\$self->${test_class}::install_cpan_upgrades();
			if (\$self->portable()) {
				\$self->install_distribution(
					name             => 'ADAMK/Config-Tiny-2.12.tar.gz',
					mod_name         => 'Config::Tiny',
					makefilepl_param => ['INSTALLDIRS=site'],
				);
			} else {
				\$self->install_distribution(
					name             => 'ADAMK/Config-Tiny-2.12.tar.gz',
					mod_name         => 'Config::Tiny',
					makefilepl_param => ['INSTALLDIRS=vendor'],
				);
			}
			return 1;
		}
EOF

	return $answer;
} ## end sub _create_test_class_long



sub test_verify_files_long {
	my $test_number = shift;
	my $dll_version = shift;
	my $testpath    = shift || 't';

	my $dll_file = "perl${dll_version}.dll";
	my $test_dir = catdir( $testpath, "tmp$test_number", 'image' );

	# C toolchain files
	ok( -f catfile( $test_dir, qw{ c bin dmake.exe } ), 'Found dmake.exe',
	);

	ok( -f catfile( $test_dir, qw{ c bin startup startup.mk } ),
		'Found startup',
	);
	ok( -f catfile( $test_dir, qw{ c bin pexports.exe } ),
		'Found pexports',
	);

	# Perl core files
	ok( -f catfile( $test_dir, qw{ perl bin perl.exe } ),
		'Found perl.exe',
	);

	if ( -f catfile( $test_dir, qw{ image portable.perl } ) ) {

		# Toolchain files
		ok( -f catfile( $test_dir, qw{ perl site lib LWP.pm } ),
			'Found LWP.pm', );

		# Custom installed file
		ok( -f catfile( $test_dir, qw{ perl site lib Config Tiny.pm } ),
			'Found Config::Tiny',
		);
	} else {

		# Toolchain files
		ok( -f catfile( $test_dir, qw{ perl vendor lib LWP.pm } ),
			'Found LWP.pm', );

		# Custom installed file
		ok( -f catfile( $test_dir, qw{ perl vendor lib Config Tiny.pm } ),
			'Found Config::Tiny',
		);
	}

	# Did we build Perl correctly?
	ok( -f catfile( $test_dir, qw{ perl bin }, $dll_file ),
		'Found Perl DLL',
	);

	$tests_completed += 7;

	return;
} ## end sub test_verify_files_long



sub test_verify_portability {
	my $test_number   = shift;
	my $base_filename = shift;
	my $testpath      = shift || 't';

	my $test_dir = catdir( 't', "tmp$test_number" );

	# Did we build the zip file?
	ok( -f catfile( $test_dir, 'output', "${base_filename}.zip" ),
		'Found zip file',
	);

	# Did we build it portable?
	ok( -f catfile( $test_dir, qw{ image portable.perl } ),
		'Found portable file',
	);
	ok( -f catfile( $test_dir, qw{ image perl site lib Portable.pm } ),
		'Found Portable.pm',
	);

	$tests_completed += 3;

	return;
} ## end sub test_verify_portability



sub test_cleanup {
	my $test_number = shift;
	my $testpath = shift || 't';

	if ( Test::Builder->new()->is_passing() ) {

		diag('Removing build files on successful test.');
		my $dir = catdir( $testpath, "tmp$test_number" );
		File::Remove::remove( \1, $dir );
	} else {
		diag('Did not pass, so not removing files.');
	}

	return;
} ## end sub test_cleanup



sub done_testing {
	my $additional_tests = shift || 0;

	return Test::More::done_testing( $tests_completed + $additional_tests );
}

1;

__END__