view release on metacpan or  search on metacpan

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

package App::TestOnTap::Config;

use strict;
use warnings;

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

use App::TestOnTap::Util qw(slashify ensureArray);
use App::TestOnTap::OrderStrategy;
use App::TestOnTap::ExecMap;
use App::TestOnTap::ParallelGroupManager;

use Config::Std;
use File::Spec;
use Grep::Query;
use UUID::Tiny qw(:std);

# CTOR
#
sub new
{
	my $class = shift;
	my $suiteRoot = shift;
	my $userCfgFile = shift;
	my $ignoreDeps = shift;

	my $configFile = slashify(File::Spec->rel2abs($userCfgFile || "$suiteRoot/" . getName()));
	die("Missing configuration file '$configFile'\n") unless -f $configFile;

	my $self = bless({}, $class);
	$self->__readCfgFile($configFile, $ignoreDeps);

	return $self;
}

# read the raw Config::Std file and fill in
# data fields
#
sub __readCfgFile
{
	my $self = shift;
	my $configFile = shift;
	my $ignoreDeps = shift;
	
	read_config($configFile, my $cfg);
	
	# this looks weird, I know - see https://rt.cpan.org/Public/Bug/Display.html?id=56862
	#
	# I seem to hit the problem with "Warning: Name "Config::Std::Hash::DEMOLISH" used only once..."
	# when running a Par::Packer binary but not when as a 'normal' script.
	#
	# The below incantation seem to get rid of that, at least for now. Let's see if it reappears... 
	#
	my $dummy = *Config::Std::Hash::DEMOLISH;
	$dummy = *Config::Std::Hash::DEMOLISH;
	
	# pick the necessities from the blank section
	#
	my $blankSection = $cfg->{''} || {};

	# a valid uuid is required
	#
	my $id = $blankSection->{id} || '';
	if (!$id)
	{
		$id = create_uuid_as_string();
		warn("WARNING: No id found, using generated '$id'!\n");
		$blankSection->{id} = $id; 
	}
	die("Invalid/missing suite id: '$id'") unless $id =~ /^[0-9a-fA-F]{8}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{12}$/;
	$self->{id} = $id;
	
	# an optional filter to skip parts while scanning suite root
	#
	# ensure it's in text form - an array is simply joined using newlines
	#
	my $skip = $blankSection->{skip};
	if (defined($skip))
	{
		$skip = join("\n", @$skip) if ref($skip) eq 'ARRAY';
		$skip = Grep::Query->new($skip);
	}
	$self->{skip} = $skip;

	# an optional filter to check if a test can run in parallel (with any other test) 
	#
	# ensure it's in text form - an array is simply joined using newlines
	#
	my $parallelizable = $blankSection->{parallelizable};
	if (defined($parallelizable))
	{
		$parallelizable = join("\n", @$parallelizable) if ref($parallelizable) eq 'ARRAY';
		$parallelizable = Grep::Query->new($parallelizable);
	}
	$self->{parallelizable} = $parallelizable;

	# read the optional order strategy
	#
	$self->{orderstrategy} = App::TestOnTap::OrderStrategy->new($blankSection->{order}) if $blankSection->{order};	
	
	# read the preprocess (optional) command
	#
	$self->{preprocesscmd} = ensureArray($blankSection->{preprocess});
	
	# read the postprocess (optional) command
	#
	$self->{postprocesscmd} = ensureArray($blankSection->{postprocess});