File Coverage

blib/lib/XT/Manager/API.pm

Criterion	Covered	Total	%
statement	97	221	43.8
branch	4	68	5.8
condition	0	27	0.0
subroutine	31	52	59.6
pod	0	14	0.0
total	132	382	34.5

package XT::Manager::API;

use strict;

BEGIN {
	$XT::Manager::API::AUTHORITY = 'cpan:TOBYINK';
	$XT::Manager::API::VERSION   = '0.006';
};

BEGIN {
	package XT::Manager::API::Types;
	no thanks;
	use Path::Tiny ();
	use Type::Library -base,
		-declare => qw( Path AbsPath File AbsFile Dir AbsDir XtTest XtTestSet XtComparison );
	use Type::Utils;
	use Types::Standard qw( Str ArrayRef );
	use Types::TypeTiny 0.004 StringLike => { -as => "Stringable" };

	class_type Path, { class => "Path::Tiny" };

	declare AbsPath,
		as Path, where { $_->is_absolute },
		inline_as { $_[0]->parent->inline_check($_) . "&& ${_}->is_absolute" },
		message {
			is_Path($_) ? "Path '$_' is not absolute" : Path->get_message($_);
		};

	declare File,
		as Path, where { $_->is_file },
		inline_as { $_[0]->parent->inline_check($_) . "&& (-f $_)" },
		message {
			is_Path($_) ? "File '$_' does not exist" : Path->get_message($_);
		};

	declare Dir,
		as Path, where { $_->is_dir },
		inline_as { $_[0]->parent->inline_check($_) . "&& (-d $_)" },
		message {
			is_Path($_) ? "Directory '$_' does not exist" : Path->get_message($_);
		};

	declare AbsFile,
		as intersection([AbsPath, File]),
		message {
			is_AbsPath($_) ? File->get_message($_) : AbsPath->get_message($_);
		};

	declare AbsDir,
		as intersection([AbsPath, Dir]),
		message {
			is_AbsPath($_) ? Dir->get_message($_) : AbsPath->get_message($_);
		};

	for my $type ( Path, File, Dir ) {
		coerce(
			$type,
			from Str()        => q{ Path::Tiny::path($_) },
			from Stringable() => q{ Path::Tiny::path($_) },
			from ArrayRef()   => q{ Path::Tiny::path(@$_) },
		);
	}

	for my $type ( AbsPath, AbsFile, AbsDir ) {
		coerce(
			$type,
			from Path         => q{ $_->absolute },
			from Str()        => q{ Path::Tiny::path($_)->absolute },
			from Stringable() => q{ Path::Tiny::path($_)->absolute },
			from ArrayRef()   => q{ Path::Tiny::path(@$_)->absolute },
		);
	}

	class_type XtTest,       { class => "XT::Manager::Test" };
	class_type XtTestSet,    { class => "XT::Manager::TestSet" };
	class_type XtComparison, { class => "XT::Manager::Comparison" };
};

BEGIN {
	package XT::Manager::API::Syntax;
	no thanks;
	use Moo ();
	use Moo::Role ();
	use Import::Into ();
	use Syntax::Collector -collect => q{
		use Types::Standard 0 -types;
		use XT::Manager::API::Types 0 -types;
		use match::smart 0.004 qw(M);
		use constant 0 { true => !!1, false => !!0 };
		use constant 0 { read_only => 'ro', read_write => 'rw', lazy_build => 'lazy' };
		no thanks 0.001;
		use strict 0;
		use warnings 0;
	};
	sub _exporter_validate_opts
	{
		my $me     = shift;
		my ($opts) = @_;
		'Moo::Role'->import::into($opts->{into}) if $opts->{role};
		'Moo'->import::into($opts->{into}) if $opts->{class};
		$me->SUPER::_exporter_validate_opts(@_);
	}
}

BEGIN {
	package XT::Manager::Exception::FileNotFound;
	use XT::Manager::API::Syntax -class;
	with qw(Throwable)
};

BEGIN {
	package XT::Manager::Test;
	use XT::Manager::API::Syntax -class;

	has t_file => (
		is       => read_only,
		isa      => File,
		required => true,
		coerce   => File->coercion,
		handles  => { name => "basename" },
	);

	has config_file => (
		is         => lazy_build,
		isa        => File,
		required   => false,
		coerce     => File->coercion,
		predicate  => "has_config_file",
	);

	sub BUILDARGS
	{
		my $class  = shift;
		my $params = $class->SUPER::BUILDARGS(@_);
		delete $params->{config_file} unless defined $params->{config_file};
		return $params;
	}

	sub _build_file
	{
		my ($self, $extension) = @_;
		my $abs = $self->t_file->absolute;
		$abs =~ s/\.\Kt$/$extension/;
		return unless -f $abs;
		return $abs;
	}

	sub _build_config_file
	{
		shift->_build_file('config');
	}
};

BEGIN {
	package XT::Manager::TestSet;
	use XT::Manager::API::Syntax -role;

	requires qw(
		add_test
		remove_test
		_build_tests
		_build_disposable_config_files
	);

	has tests => (
		is         => lazy_build,
		isa        => ArrayRef[XtTest],
		predicate  => "has_tests",
	);

	has disposable_config_files => (
		is         => lazy_build,
		isa        => Bool,
		predicate  => "has_disposable_config_files",
	);

	sub is_ignored { +return }

	sub test
	{
		my ($self, $name) = @_;
		my @results = grep { $_->name eq $name } @{ $self->tests };
		wantarray ? @results : $results[0];
	}
};

BEGIN {
	package XT::Manager::FileSystemTestSet;
	use XT::Manager::API::Syntax -role;
	with qw(XT::Manager::TestSet);

	has dir => (
		is       => read_only,
		isa      => Dir,
		required => true,
		coerce   => Dir->coercion,
	);

	sub _build_tests
	{
		my $self = shift;
		$self->dir->mkpath unless -d $self->dir;

		[
			map  { XtTest->new(t_file => $_) }
			grep { !$_->is_dir and $_ =~ /\.t$/ }
			$self->dir->children
		]
	}

	sub _build_disposable_config_files { true }

	sub compare
	{
		my ($self, $other) = @_;
		my %results;
		foreach my $t (@{ $self->tests })
		{
			$results{ $t->name }{L} = [ $t->t_file->stat->mtime ];
		}
		foreach my $t (@{ $other->tests })
		{
			$results{ $t->name }{R} = [ $t->t_file->stat->mtime ];
		}

		XtComparison->new(
			left  => $self,
			right => $other,
			data  => \%results,
		);
	}

	sub add_test
	{
		my ($self, $t) = @_;
		my $o = $t;
		$t = $self->test($t) unless ref $t;

		"XT::Manager::Exception::FileNotFound"->throw(
			message => "$o not found in ".$self->dir
		) unless ref $t;

		my $dir = $self->dir;
		my ($t_file, $config_file);
		my $dump = sub {
			my ($old, $new) = @_;
			my $fh = $new->openw;
			print $fh $old->slurp;
			close $fh;
			utime $old->stat->mtime, $old->stat->mtime, "$new";
		};

		$t_file = File->coercion->([ "$dir", $t->t_file->basename ]);
		$dump->($t->t_file, $t_file);

		if ($t->has_config_file)
		{
			$config_file = File->coercion->([ "$dir", $t->config_file->basename ]);
			$dump->($t->config_file, $config_file) if $self->disposable_config_files || !(-e $config_file);
		}

		my $object = XtTest->new(
			t_file      => $t_file,
			config_file => $config_file,
		);
		push @{ $self->tests }, $object;

		return $object;
	}

	sub remove_test
	{
		my ($self, $t) = @_;
		my $o = $t;
		$t = $self->test($t) unless ref $t;

		"XT::Manager::Exception::FileNotFound"->throw(
			"$o not found in ".$self->dir
		) unless ref $t;

		$t->t_file->remove;
		if ($t->has_config_file)
		{
			$t->config_file->remove if $self->disposable_config_files || !(-e $t->config_file);
		}

		$self->tests([ grep { $_->name ne $t->name } @{ $self->tests } ]);
		return $self;
	}
};

BEGIN {
	package XT::Manager::Repository;
	use XT::Manager::API::Syntax -class;
	with qw(XT::Manager::FileSystemTestSet);
}

BEGIN {
	package XT::Manager::XTdir;
	use XT::Manager::API::Syntax -class;
	with qw(XT::Manager::FileSystemTestSet);

	has ignore_list => (
		is         => lazy_build,
		isa        => Any,
		predicate  => "has_ignore_list",
	);

	sub _build_disposable_config_files { false }

	sub _build_ignore_list
	{
		my $self = shift;
		$self->dir->mkpath unless -d $self->dir;

		my $file  = File->coercion->([ $self->dir, '.xt-ignore' ]);
		return unless -f "$file";
		my @ignore =
			map { qr{$_} }
			map { chomp; $_ }
			$file->slurp;
		return \@ignore;
	}

	sub is_ignored
	{
		my ($self, $name) = @_;
		return true if $name |M| $self->ignore_list;
		return;
	}

	sub add_ignore
	{
		my ($self, $string) = @_;
		$self->dir->mkpath unless -d $self->dir;

		my $file  = File->coercion->([ $self->dir, '.xt-ignore' ]);
		open my $fh, '>>', "$file";
		print $fh quotemeta($string);
		close $fh;
		push @{ $self->ignore_list }, qr{ \Q $string \E }x;
	}
};

BEGIN {
	package XT::Manager::Comparison;
	use XT::Manager::API::Syntax -class;

	use constant {
		LEFT_ONLY     => '+   ',
		RIGHT_ONLY    => '  ? ',
		LEFT_NEWER    => 'U   ',
		RIGHT_NEWER   => '  M ',
	};

	has data => (
		is       => read_only,
		isa      => HashRef,
		required => true,
	);

	has [qw/left right/] => (
		is       => read_only,
		does     => XtTestSet,
		required => true,
	);

	sub test_names
	{
		my $self = shift;
		sort keys %{ $self->data };
	}

	sub left_has
	{
		my ($self, $name) = @_;
		return $self->data->{$name}{L};
	}

	sub right_has
	{
		my ($self, $name) = @_;
		return $self->data->{$name}{R};
	}

	sub status
	{
		my ($self, $name) = @_;
		my $L = $self->left_has($name);
		my $R = $self->right_has($name);

		return LEFT_ONLY   if (  $L and !$R );
		return RIGHT_ONLY  if ( !$L and  $R );
		return LEFT_NEWER  if (  $L and  $R  and $L->[0] > $R->[0] );
		return RIGHT_NEWER if (  $L and  $R  and $L->[0] < $R->[0] );
		return;
	}

	sub show
	{
		my ($self, $verbose) = @_;

		my $str = '';
		foreach my $t ($self->test_names)
		{
			next if $self->right->is_ignored($t);

			my $status = $self->status($t);
			if (defined $status and length $status)
			{
				$str .= sprintf("%s  %s\n", $status, $t);
			}
			elsif ($verbose)
			{
				$str .= "      $t\n";
			}
		}
		return $str;
	}

	sub should_pull
	{
		my $self = shift;
		grep
		{
			my $f = $_;
			if ($self->right->is_ignored($f))
			{
				0;
			}
			else
			{
				my $st = $self->status($f);
				$st = "" unless defined $st;
				$st eq LEFT_ONLY || $st eq LEFT_NEWER;
			}
		} $self->test_names;
	}
};

__FILE__
__END__