view release on metacpan or  search on metacpan

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

											$_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 ($@)
	{
		$! = 255;
		die("Failure creating filter:\n  $@");
	}

	# make sure we have a valid jobs value
	#
	my $maxJobs = $ENV{_TESTONTAP_MAX_JOBS} 
					? 0 + $ENV{_TESTONTAP_MAX_JOBS}
					: $IS_WINDOWS
						? 60	# read about max being 64, leave room
						: ~0;	# max int, e.g. almost 'infinite'
	
	if ($rawOpts{jobs} > $maxJobs)
	{
		$rawOpts{jobs} = $maxJobs;
		warn("WARNING: Maximum jobs restricted, resetting to '--jobs $maxJobs' \n");
	}
	pod2usage(-message => "Invalid -jobs value: '$rawOpts{jobs}'", -exitval => 255, -verbose => 0) if $rawOpts{jobs} < 1;
	$self->{jobs} = $rawOpts{jobs};
	
	# verify known order strategies
	#
	$self->{orderstrategy} = App::TestOnTap::OrderStrategy->new($rawOpts{order}) if $rawOpts{order};
	
	# set up savedir, if given - or, if archive is given fall back to current dir
	#
	if (defined($rawOpts{savedirectory}) || $rawOpts{archive})
	{
		eval
		{
			$self->{savedirectory} = slashify(File::Spec->rel2abs($rawOpts{savedirectory} || '.'));
			die("The -savedirectory '$self->{savedirectory}' exists but is not a directory\n") if (-e $self->{savedirectory} && !-d $self->{savedirectory});
			if (!-e $self->{savedirectory})
			{
				mkpath($self->{savedirectory}) or die("Failed to create -savedirectory '$self->{savedirectory}': $!\n");
			}
		};
		if ($@)
		{
			$! = 255;
			die("Failure setting up the save directory:\n  $@");
		}
	}

	# make sure we have the suite root and that it exists as directory
	#
	eval
	{
		die("No suite root provided!\n") unless @argv;
		$self->{suiteroot} = $self->__findSuiteRoot(shift(@argv));
	};
	if ($@)
	{
		$! = 255;
		die("Failure getting suite root directory:\n  $@");
	}

	# we want a config in the suite root
	#
	eval
	{
		$self->{config} = App::TestOnTap::Config->new($self->{suiteroot}, $rawOpts{configuration}, $rawOpts{_ignore_dependencies}); 
	};
	if ($@)
	{
		$! = 255;
		die("Failure handling config in '$self->{suiteroot}':\n  $@");
	}

	# set up the workdir manager
	#
	eval
	{
		$self->{workdirmgr} = App::TestOnTap::WorkDirManager->new($self, $rawOpts{workdirectory}, $self->{suiteroot});
	};
	if ($@)
	{
		$! = 255;
		die("Failure setting up the working directory:\n  $@");
	};

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

}

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

sub useHarness
{
	my $self = shift;
	
	return $self->{harness} && !$self->doDryRun();
}

sub doDryRun
{
	my $self = shift;
	
	return $self->{dryrun};
}

sub include
{
	my $self = shift;
	my $tests = shift;
	
	return
		$self->{include}
			? [ $self->{include}->qgrep(@$tests) ]
			: undef;
}

# PRIVATE
#

sub __findSuiteRoot
{
	my $self = shift;
	my $suiteroot = shift;

	if (-d $suiteroot)
	{
		$suiteroot = slashify(File::Spec->rel2abs($suiteroot));
	}
	else
	{
		die("Not a directory or zip archive: '$suiteroot'\n") unless $suiteroot =~ /\.zip$/i;
		my $zipfile = $suiteroot;
		my $tmpdir = slashify(tempdir("testontap-XXXX", TMPDIR => 1, CLEANUP => 1));

		if (!-f $suiteroot)
		{
			# maybe it's a url?
			# need to dl it before unpacking
			#
			my $localzip = slashify("$tmpdir/local.zip");
			print "Downloading '$suiteroot' => $localzip...\n" if $self->{v};
			my $ua = LWP::UserAgent->new();
			$ua->ssl_opts(verify_hostname => 0);
			my $response = $ua->get($suiteroot, ':content_file' => $localzip);
			if ($response->is_error() || !-f $localzip)
			{
				my $rc = $response->code();
				die("Treated '$suiteroot' as URL - failed to download : $rc\n");
			}
			$zipfile = $localzip;
		}
		
		print "Unpacking '$zipfile'...\n" if $self->{v};
		my $zipErr;
		Archive::Zip::setErrorHandler(sub { $zipErr = $_[0]; chomp($zipErr) });
		my $zip = Archive::Zip->new($zipfile);
		die("Error when unpacking '$zipfile': $zipErr\n") if $zipErr;
		my @memberNames = $zip->memberNames();
		die("The zip archive '$suiteroot' is empty\n") unless @memberNames;
		my @rootEntries = grep(m#^[^/]+/?$#, @memberNames);
		die("The zip archive '$suiteroot' has more than one root entry\n") if scalar(@rootEntries) > 1;
		my $testSuiteDir = $rootEntries[0];
		die("The zip archive '$suiteroot' must have a test suite directory as root entry\n") unless $testSuiteDir =~ m#/$#;
		my $cfgFile = $testSuiteDir . App::TestOnTap::Config::getName();
		die("The zip archive '$suiteroot' must have a '$cfgFile' entry\n") unless grep(/^\Q$cfgFile\E$/, @memberNames);
		die("Failed to extract '$suiteroot': $!\n") unless $zip->extractTree('', $tmpdir) == AZ_OK;
		$suiteroot = slashify(File::Spec->rel2abs("$tmpdir/$testSuiteDir"));
		print "Unpacked '$suiteroot'\n" if $self->{v}; 
	}
	
	return $suiteroot;
}

1;