File Coverage

blib/lib/Test/Instruction.pm

Criterion	Covered	Total	%
statement	88	155	56.7
branch	38	104	36.5
condition	1	8	12.5
subroutine	26	47	55.3
pod	3	5	60.0
total	156	319	48.9

package Test::Instruction;

use 5.006; use strict; use warnings; our $VERSION = '0.07';
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),
			ref_key   => Optional->of(Str),
			ref_index => Optional->of(Int),
			debug 	  => Optional->of(Bool),
		},
		instructions => {
			name => Str,
			run => ArrayRef,
			build => Optional->of(HashRef),
			instance => Optional->of(Any),
			debug => Optional->of(Bool)
		},
		build => {
			class => Str,
			new => Optional->of(Str),
			args => Optional->of(Any),
			args_list => Optional->of(Bool)
		},
		debug => {
			name => Str,
			message => Str,
			out => Optional->of(Any),
		}
	);
}

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

	debug (
		name => 'Test instruction',
		message => 'Run the test instruction',
		out => $instruction
	) if $instruction->debug;

	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;
	}

	debug (
		name => $test_name,
		message => 'Code for the test instruction has been executed',
		out => \@test
	) if $instruction->debug;

	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
			);
		},
		code => sub {
			return is(
				ref $test[0],
				'CODE',
				sprintf "%s is a CODE block",
				$test_name
			);
		},
		code_execute => sub {
			return is_deeply(
				$test[0]->($instruction->args ? @{$instruction->args} : ()),
				$instruction->expected,
				sprintf "%s is deeply %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->(@_);

	debug (
		name => $instructions->name,
		message => 'running test instructions: ' + caller()
	) if $instructions->debug;

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

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

	debug (
		name => $instructions->name,
		message => 'Built the test instance object',
		out => $instance
	) if $instructions->debug;

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

	for my $instruction (@{$instructions->run}) {
		$test_info{tested}++;

		debug (
			name => $instructions->name,
			message => 'Run the next test instruction',
			out => $instruction
		) if $instructions->debug;

		if (my $subtests = delete $instruction->{instructions}) {
			my ($test_name, $new_instance) = _run_the_code(
				$validate->instruction->(
					instance => $instance,
					($instructions->debug ? (debug => $instructions->debug) : ()),
					%{$instruction}
				)
			);

			debug (
				name => sprintf("%s -> %s", $instructions->name, $test_name),
				message => 'Run the subtests of the test instruction',
				out => $instruction
			) if $instructions->debug;

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

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

		$test_info{fail}++
			unless instruction(
				instance => $instance,
				($instructions->debug ? (debug => $instructions->debug) : ()),
				%{$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 } : defined $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->ref_key) {
		my $key = $instruction->ref_key;
		return (
			"key: ${key}",
			$instruction->instance->{$key}
		);
	} elsif (defined $instruction->ref_index) {
		my $index = $instruction->ref_index;
		return (
			"index: ${index}",
			$instruction->instance->[$index]
		);
	} elsif ($instruction->instance) {
		return ('instance', $instruction->instance);
	}

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

sub caller_stack {
	my @caller; my $i = 0; my @stack;
        while(@caller = caller($i++)){
                next if $caller[0] eq 'Log::JSON::Lines';
                $stack[$i+1]->{module} = $caller[0];
                $stack[$i+1]->{file} = $1 if $caller[1] =~ /([^\/]+)$/;;
                $stack[$i+1]->{line} = $1 if $caller[2] =~ /(\d+)/;
                $stack[$i]->{sub} = $1 if $caller[3] =~ /([^:]+)$/;
        }
        my $stacktrace = join '->', reverse map {
                my $module = $_->{module} !~ m/^main$/ ? $_->{module} : $_->{file};
                $_->{sub}
                        ? $module . '::' . $_->{sub} . ':' . $_->{line}
                        : $module . ':' . $_->{line}
        } grep {
                $_ && $_->{module} && $_->{line} && $_->{file}
        } @stack;
	return $stacktrace;
}

sub debug {
	my $debug = $validate->debug->(@_);
	diag explain $debug->name . ' ~ ' . caller_stack();
	diag explain $debug->message;
	diag explain $debug->out;
}

__END__