File Coverage

blib/lib/Test/Instruction.pm

Criterion	Covered	Total	%
statement	73	124	58.8
branch	20	62	32.2
condition	1	2	50.0
subroutine	22	43	51.1
pod	3	3	100.0
total	119	234	50.8

package Test::Instruction;

use 5.006; use strict; use warnings; our $VERSION = '0.02';
use Compiled::Params::OO qw/cpo/;
use Types::Standard qw/Optional Str Int Bool Any CodeRef ArrayRef HashRef/;
use B qw/svref_2object/;
use Switch::Again qw/switch/;
use Test::More;
use base 'Import::Export';

our (%EX, $validate);
BEGIN {
	%EX = (
		instruction => [qw/all/],
		instructions => [qw/all/],
		finish => [qw/all/]
	);
	$validate = cpo(
		instruction => {
			instance  => Optional->of(Any),
			meth      => Optional->of(Str),
			func      => Optional->of(CodeRef),
			args      => Optional->of(Any),
			args_list => Optional->of(Bool),
			test      => Optional->of(Str),
			expected  => Optional->of(Any),
			catch     => Optional->of(Bool),
			key       => Optional->of(Str),
			index     => Optional->of(Int),
		},
		instructions => {
			name => Str,
			run => ArrayRef,
			build => Optional->of(HashRef),
			instance => Optional->of(Any)
		},
		build => {
			class => Str,
			new => Optional->of(Str),
			args => Optional->of(Any),
			args_list => Optional->of(Bool)
		}
	);
}

sub instruction {
	my $instruction = $validate->instruction->(@_);
	my ($test_name, @test) = ("", ());
	if ( $instruction->catch ) {
		$test_name = 'catch';
		exits $instruction->test or $instruction->test('like');
		eval { _run_the_code( $instruction ) };
		@test = $@;
	} else {
		@test = _run_the_code( $instruction );
		$test_name = shift @test;
	}

	if ( not $instruction->test ) {
		ok(0, "No 'test' passed with instruction");
		return;
	}

	switch $instruction->test,
		"ref" => sub {
			return is_deeply( $test[0], $instruction->expected, "${test_name} is ref - is_deeply" );

		},
		ref_key_scalar => sub {
			return ok(0, "No key passed to test - ref_key_scalar - testing - ${test_name}")
				if (! $instruction->key );
			return is(
				$test[0]->{$instruction->key},
				$instruction->expected,
				sprintf "%s is ref - has scalar key: %s - is - %s",
				$test_name,
				$instruction->key,
				$instruction->expected
			);
		},
		ref_key_like => sub {
			return ok(0, "No key passed to test - ref_key_like - testing - ${test_name}")
				if (! $instruction->key );
			my $like = $instruction->expected;
			return like(
				$test[0]->{$instruction->key},
				qr/$like/,
				sprintf "%s is ref - has scalar key: %s - like - %s",
				$test_name,
				$instruction->key,
				$instruction->expected
			);
		},
		ref_key_ref => sub {
			return ok(0, "No key passed to test - ref_key_ref - testing - ${test_name}")
				if (! $instruction->key );
			return is_deeply(
				$test[0]->{$instruction->key},
				$instruction->expected,
				sprintf "%s is ref - has ref key: %s - is_deeply - ref",
				$test_name,
				$instruction->key,
			);
		},
		ref_index_scalar => sub {
			return ok(0, "No index passed to test - ref_index_scalar - testing - ${test_name}")
				if (! defined $instruction->index );
			return is(
				$test[0]->[$instruction->index],
				$instruction->expected,
				sprintf "%s is ref - has scalar index: %s - is - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			);
		},
		ref_index_ref => sub {
			return ok(0, "No index passed to test - ref_index_ref - testing - ${test_name}")
				if (! defined $instruction->index );
			is_deeply(
				$test[0]->[$instruction->index],
				$instruction->expected,
				sprintf "%s is ref - has ref index: %s - is_deeply - ref",
				$test_name,
				$instruction->index,
			);
		},
		ref_index_like => sub {
			return ok(0, "No index passed to test - ref_index_like - testing - ${test_name}")
				if (! defined $instruction->index );
			my $like = $instruction->expected;
			return like(
				$test[0]->[$instruction->index],
				qr/$like/,
				sprintf "%s is ref - has scalar index: %s - like - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			);
		},
		ref_index_obj => sub {
			return ok(0, "No index passed to test - ref_index_obj - testing - ${test_name}")
				if (! defined $instruction->index );
			return isa_ok(
				$test[0]->[$instruction->index],
				$instruction->expected,
				sprintf "%s is ref - has obj index: %s - isa_ok - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			);
		},
		list_index_scalar => sub {
			return ok(0, "No index passed to test - list_index_scalar - testing - ${test_name}")
				if (! defined $instruction->index );

			return is(
				$test[$instruction->index],
				$instruction->expected,
				sprintf "%s is list - has scalar index: %s - is - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			);
		},
		list_index_ref => sub {
			return ok(0, "No index passed to test - list_index_ref - testing - ${test_name}")
				if (! defined $instruction->index );
			return is_deeply(
				$test[$instruction->index],
				$instruction->expected,
				sprintf "%s is list - has ref index: %s - is_deeply - ref",
				$test_name,
				$instruction->index,
			);
		},
		list_index_like => sub {
			return ok(0, "No index passed to test - list_index_like - testing - ${test_name}")
				if (! defined $instruction->index );
			my $like = $instruction->expected;
			return is(
				$test[$instruction->index],
				qr/$like/,
				sprintf "%s is list - has scalar index: %s - like - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			);
		},
		list_index_obj => sub {
			return ok(0, "No index passed to test - list_index_obj - testing - ${test_name}")
				if (! defined $instruction->index );
			return isa_ok(
				$test[$instruction->index],
				$instruction->expected,
				sprintf "%s is list - has obj index: %s - isa_ok - %s",
				$test_name,
				$instruction->index,
				$instruction->expected
			),
		},
		list_key_scalar => sub {
			return ok(0, "No key passed to test - list_key_scalar - testing - ${test_name}")
				if (! $instruction->key );
			return is(
				{@test}->{$instruction->key},
				$instruction->expected,
				sprintf "%s is list - has scalar key: %s - is - %s",
				$test_name,
				$instruction->key,
				$instruction->expected
			);
		},
		list_key_ref => sub {
			return ok(0, "No key passed to test - list_key_ref - testing - ${test_name}")
				if (! $instruction->key );
			return is_deeply(
				{@test}->{$instruction->key},
				$instruction->expected,
				sprintf "%s is list - has ref key: %s - is_deeply - ref",
				$test_name,
				$instruction->key,
			);
		},
		list_key_like => sub {
			return ok(0, "No key passed to test - list_key_like - testing - ${test_name}")
				if (! $instruction->key );
			my $like = $instruction->expected;
			return is(
				{@test}->{$instruction->key},
				qr/$like/,
				sprintf "%s is list - has scalar key: %s - like - %s",
				$test_name,
				$instruction->key,
				$instruction->expected
			);
		},
		count => sub {
			return is(
				scalar @test,
				$instruction->expected,
				sprintf "%s is array - count - is - %s",
				$test_name,
				$instruction->expected
			);
		},
		count_ref => sub {
			return is(
				scalar @{$test[0]},
				$instruction->expected,
				sprintf "%s is ref - count - is - %s",
				$test_name,
				$instruction->expected
			);
		},
		scalar => sub {
			return is( $test[0], $instruction->expected, sprintf "%s is scalar - is - %s",
				$test_name, defined $instruction->expected ? $instruction->expected : 'undef');
		},
		hash => sub {
			return is_deeply(
				scalar @test == 1 ? $test[0] : {@test},
				$instruction->expected,
				sprintf "%s is hash - is_deeply",
				$test_name,
			);
		},
		array => sub {
			return is_deeply(
				scalar @test == 1 ? $test[0] : \@test,
				$instruction->expected,
				sprintf "%s is array - is_deeply",
				$test_name,
			);
		},
		obj => sub {
			return isa_ok(
				$test[0],
				$instruction->expected,
				sprintf "%s isa_ok - %s",
				$test_name,
				$instruction->expected
			);
		},
		like => sub {
			my $like = $instruction->expected;
			return like(
				$test[0],
				qr/$like/,
				sprintf "%s is like - %s",
				$test_name,
				$instruction->expected
			);
		},
		true => sub {
			return ok($test[0], "${test_name} is true - 1");
		},
		false => sub {
			return ok(!$test[0], "${test_name} is false - 0");
		},
		undef => sub {
			return is($test[0], undef, "${test_name} is undef");
		},
		ok => sub {
			return ok(@test, "${test_name} is ok");
		},
		skip => sub {
			return ok(1, "${test_name} - skip");
		},
		default => sub {
			ok(0, "Unknown instruction $_[0]: passed to instrcution");
			return;
		};
}

sub instructions {
	my $instructions = $validate->instructions->(@_);

	ok(1, sprintf "instructions: %s", $instructions->name);

	my $instance = $instructions->build ? _build($instructions->build) : $instructions->instance;

	my %test_info = (
		fail => 0,
		tested => 0,
	);

	for my $instruction (@{$instructions->run}) {
		$test_info{tested}++;
		if (my $subtests = delete $instruction->{instructions}) {
			my ($test_name, $new_instance) = _run_the_code(
				$validate->instruction->(
					instance => $instance,
					%{$instruction}
				)
			);

			$test_info{fail}++
				unless instruction(
					instance => $new_instance,
					test => $instruction->{test},
					expected => $instruction->{expected}
				);

			instructions(
				instance => $new_instance,
				run => $subtests,
				name => sprintf "Subtest -> %s -> %s", $instructions->name, $test_name
			);
			next;
		}

		$test_info{fail}++
			unless instruction(
				instance => $instance,
				%{$instruction}
			);
	}

	$test_info{ok} = $test_info{fail} ? 0 : 1;
	return ok(
		$test_info{ok},
		sprintf(
			"instructions: %s - tested %d instructions - success: %d - failure: %d",
			$instructions->name,
			$test_info{tested},
			($test_info{tested} - $test_info{fail}),
			$test_info{fail}
		)
	);
}

sub finish {
	my $done_testing = done_testing(shift);
	return $done_testing;
}


sub _build {
	my $build = $validate->build->(@_);
	my $new = $build->new || 'new';
	return $build->class->$new($build->args_list ? @{ $build->args } : $build->args);
}

sub _run_the_code {
	my $instruction = shift;
	if ($instruction->meth) {
		my $meth = $instruction->meth;
		return (
			"function: ${meth}",
			$instruction->instance->$meth(
				$instruction->args_list
					? @{ $instruction->args }
					: $instruction->args
			)
		);
	} elsif ($instruction->func) {
		my $func_name = svref_2object($instruction->func)->GV->NAME;
		return (
			"function: ${func_name}",
			$instruction->func->($instruction->args_list ? @{$instruction->args} : $instruction->args)
		);
	} elsif ($instruction->instance) {
		return ('instance', $instruction->instance);
	}

	die(
		'instruction passed to _run_the_code must have a func, meth or instance key'
	);
}

__END__