view release on metacpan or  search on metacpan

lib/App/TestOnTap/Args.pm  view on Meta::CPAN

# in the testontap universe
#
package App::TestOnTap::Args;

use strict;
use warnings;

our $VERSION = '1.001';
my $version = $VERSION;
$VERSION = eval $VERSION;

use App::TestOnTap::Util qw(slashify expandAts $IS_WINDOWS);
use App::TestOnTap::Config;
use App::TestOnTap::Preprocess;
use App::TestOnTap::WorkDirManager;
use App::TestOnTap::OrderStrategy; 
use App::TestOnTap::PackInfo; 

use Archive::Zip qw(:ERROR_CODES);
use Getopt::Long qw(GetOptionsFromArray :config require_order no_ignore_case bundling);
use Pod::Usage;
use Pod::Simple::Search;
use Grep::Query;
use File::Spec;
use File::Path;
use File::Temp qw(tempdir);
use UUID::Tiny qw(:std);
use LWP::UserAgent;

# CTOR
#
sub new
{
	my $class = shift;
	my $version = shift;

	my $self = bless( { id => create_uuid_as_string() }, $class);
	$self->__parseArgv($version, @_);

	return $self;
}

sub __parseArgv
{
	my $self = shift;
	my $version = shift;
	my @argv = @_;
	
	my %rawOpts =
		(
			usage => 0,
			help => 0,
			manual => 0,
			version => 0,
			configuration => undef,		# no alternate config
			define => {},				# arbitrary key=value defines
			skip => undef,				# no skip filter
			include => undef,			# no include filter
			jobs => 1,					# run only one job at a time (no parallelism)
			order => undef,				# have no particular strategy for test order
			timer => 0,					# don't show timing output
			workdirectory => undef,		# explicit directory to use
			savedirectory => undef,		# don't save results (unless -archive is used)
			archive => 0,				# don't save results as archive
			v => 0,						# don't let through output from tests
			harness => 1,				# use the normal test harness
			merge => undef,				# ask the harness to merge stdout/stderr of tests
			dryrun => 0,				# don't actually run tests
			
			# hidden
			#
			_help => 0,
			_pp => 0,
			_pp_script => undef,
			_pp_info => 0,
			_ignore_dependencies => 0,
		);
		
	my @specs =
		(
			'usage|?',
			'help|h',
			'manual',
			'version',
			'configuration|cfg=s',
			'define|D=s%',
			'skip=s',
			'include=s',
			'jobs=i',
			'order=s',
			'timer!',
			'workdirectory=s',
			'savedirectory=s',
			'archive',
			'v|verbose+',
			'harness!',
			'merge!',
			'dryrun!',
			
			# hidden
			#
			'_help',
			'_pp',
			'_pp_script=s',
			'_pp_info',
			'_ignore_dependencies',
		);

	my $_argsPodName = 'App/TestOnTap/_Args._pod';
	my $_argsPodInput = Pod::Simple::Search->find($_argsPodName);
	my $argsPodName = 'App/TestOnTap/Args.pod';
	my $argsPodInput = Pod::Simple::Search->find($argsPodName);
	my $manualPodName = 'App/TestOnTap.pod';
	my $manualPodInput = Pod::Simple::Search->find($manualPodName);
	
	# for consistent error handling below, trap getopts problems
	# 
	eval
	{
		@argv = expandAts('.', @argv);
		$self->{fullargv} = [ @argv ];
		local $SIG{__WARN__} = sub { die(@_) };
		GetOptionsFromArray(\@argv, \%rawOpts, @specs)
	};
	if ($@)
	{
		pod2usage(-input => $argsPodInput, -message => "Failure parsing options:\n  $@", -exitval => 255, -verbose => 0);
	}

	# simple copies
	#
	$self->{$_} = $rawOpts{$_} foreach (qw(v archive timer harness dryrun));
	$self->{defines} = $rawOpts{define};

	# help with the hidden flags...
	#

	pod2usage(-input => $_argsPodInput, -exitval => 0, -verbose => 2, -noperldoc => 1) if $rawOpts{_help};

	# for the special selection of using --_pp* turn over to packinfo
	#
	my %packHelperOpts;
	foreach my $opt (keys(%rawOpts))
	{
		$packHelperOpts{$opt} = $rawOpts{$opt} if ($opt =~ /^_pp(_.+)?/ && $rawOpts{$opt});
	}
	if (keys(%packHelperOpts))
	{
		$packHelperOpts{verbose} = $rawOpts{v};
		App::TestOnTap::PackInfo::handle
										(
											\%packHelperOpts, 
											$version,
											$_argsPodName, $_argsPodInput,
											$argsPodName, $argsPodInput,
											$manualPodName, $manualPodInput
										);
		die("INTERNAL ERROR");
	}

	# if any of the doc switches made, display the pod
	#
	pod2usage(-input => $manualPodInput, -exitval => 0, -verbose => 2, -noperldoc => 1) if $rawOpts{manual};
	pod2usage(-input => $argsPodInput, -exitval => 0, -verbose => 2, -noperldoc => 1) if $rawOpts{help};
	pod2usage(-input => $argsPodInput, -exitval => 0, -verbose => 0) if $rawOpts{usage};
	pod2usage(-message => (slashify($0) . " version $version"), -exitval => 0, -verbose => 99, -sections => '_') if $rawOpts{version};

	# use the user skip or include filter for pruning the list of tests later
	#
	eval
	{
		if (defined($rawOpts{skip}) || defined($rawOpts{include}))
		{
			die("The options --skip and --include are mutually exclusive\n") if (defined($rawOpts{skip}) && defined($rawOpts{include}));
			if ($rawOpts{skip})
			{
				# try to compile the query first, to trigger any syntax problem now
				#
				Grep::Query->new($rawOpts{skip});
			
				# since we later want to select *included* files, 
				# we nefariously reverse the expression given
				#
				$self->{include} = Grep::Query->new("NOT ( $rawOpts{skip} )");
			}
			else
			{
				$self->{include} = Grep::Query->new($rawOpts{include});
			}
		}
	};
	if ($@)

lib/App/TestOnTap/Args.pm  view on Meta::CPAN

	# unless merge is explicitly set:
	# * default to merge if the results are saved in any way (to force stderr to the tap files)
	# * otherwise default to no merge
	#
	$self->{merge} =
		defined($rawOpts{merge})
			? $rawOpts{merge}
			: ($rawOpts{workdirectory} || $rawOpts{savedirectory} || $rawOpts{archive}) ? 1 : 0;

	# run preprocessing
	#
	$self->{preprocess} = App::TestOnTap::Preprocess->new($self->{config}->getPreprocessCmd(), $self, { %ENV }, \@argv);
}

sub getFullArgv
{
	my $self = shift;
	
	return $self->{fullargv};
}

sub getArgv
{
	my $self = shift;

	return $self->{preprocess}->getArgv();
}

sub getId
{
	my $self = shift;
	
	return $self->{id};
}

sub getJobs
{
	my $self = shift;
	
	return $self->{jobs};
}

sub getOrderStrategy
{
	my $self = shift;
	
	return $self->{orderstrategy};
}

sub getPreprocess
{
	my $self = shift;
	
	return $self->{preprocess};
}

sub getTimer
{
	my $self = shift;
	
	return $self->{timer};
}

sub getArchive
{
	my $self = shift;
	
	return $self->{archive};
}

sub getDefines
{
	my $self = shift;
	
	return $self->{defines};
}

sub getVerbose
{
	my $self = shift;
	
	return $self->{v};
}

sub getMerge
{
	my $self = shift;
	
	return $self->{merge};
}

sub getSuiteRoot
{
	my $self = shift;
	
	return $self->{suiteroot};
}

sub getSaveDir
{
	my $self = shift;
	
	return $self->{savedirectory};
}

sub getWorkDirManager
{
	my $self = shift;
	
	return $self->{workdirmgr};
}

sub getConfig
{
	my $self = shift;
	
	return $self->{config};
}

sub useHarness
{