File Coverage

blib/lib/Return/Type.pm

Criterion	Covered	Total	%
statement	78	84	92.8
branch	13	20	65.0
condition	7	14	50.0
subroutine	15	15	100.0
pod	1	2	50.0
total	114	135	84.4

use 5.008;
use strict;
use warnings;

package Return::Type;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.004';

use Attribute::Handlers;
use Eval::TypeTiny qw( eval_closure );
use Sub::Identify qw( sub_fullname );
use Sub::Name qw( subname );
use Types::Standard qw( Any ArrayRef HashRef Int );
use Types::TypeTiny qw( to_TypeTiny );

sub _inline_type_check
{
	my $class = shift;
	my ($type, $var, $env, $suffix) = @_;

	return $type->inline_assert($var) if $type->can_be_inlined;

	$env->{'$type_'.$suffix} = \$type;
	return sprintf('$type_%s->assert_return(%s);', $suffix, $var);
}

sub _inline_type_coerce_and_check
{
	my $class = shift;
	my ($type, $var, $env, $suffix) = @_;

	my $coerce = '';
	if ($type->has_coercion and $type->coercion->can_be_inlined)
	{
		$coerce = sprintf('%s = %s;', $var, $type->coercion->inline_coercion($var));
	}
	elsif ($type->has_coercion)
	{
		$env->{'$coercion_'.$suffix} = \( $type->coercion );
		$coerce = sprintf('%s = $coercion_%s->coerce(%s);', $var, $suffix, $var);
	}

	return $coerce . $class->_inline_type_check(@_);
}

sub wrap_sub
{
	my $class = shift;
	my $sub   = $_[0];
	local %_  = @_[ 1 .. $#_ ];

	$_{$_}     &&= to_TypeTiny($_{$_}) for qw( list scalar );
	$_{scalar} ||= Any;
	$_{list}   ||= ($_{scalar} == Any ? Any : ArrayRef[$_{scalar}]);

	my $prototype = prototype($sub);
	$prototype = defined($prototype) ? "($prototype)" : "";

	my %env  = ( '$sub' => \$sub );
	my @src  = sprintf('sub %s { my $wa = wantarray;', $prototype);
	my $call = '$sub->(@_)';

	if ($_{scope_upper})
	{
		require Scope::Upper;
		$call = '&Scope::Upper::uplevel($sub => (@_) => &Scope::Upper::SUB(&Scope::Upper::SUB))';
	}

	exists($_{$_}) || ($_{$_} = $_{coerce}) for qw( coerce_list coerce_scalar );
	my $inline_list   = $_{coerce_list}   ? '_inline_type_coerce_and_check' : '_inline_type_check';
	my $inline_scalar = $_{coerce_scalar} ? '_inline_type_coerce_and_check' : '_inline_type_check';

	# List context
	push @src, 'if ($wa) {';
	if ( $_{list}->is_a_type_of(HashRef) )
	{
		push @src, 'my $rv = do { use warnings FATAL => qw(misc); +{' . $call . '} };';
		push @src, $class->$inline_list($_{list}, '$rv', \%env, 'l');
		push @src, 'return %$rv;';
	}
	else
	{
		push @src, 'my $rv = [' . $call . '];';
		push @src, $class->$inline_list($_{list}, '$rv', \%env, 'l');
		push @src, 'return @$rv;';
	}
	push @src, '}';

	# Scalar context
	push @src, 'elsif (defined $wa) {';
	push @src, 'my $rv = ' . $call . ';';
	push @src, $class->$inline_scalar($_{scalar}, '$rv', \%env, 's');
	push @src, 'return $rv;';
	push @src, '}';

	# Void context - cannot request a value to check, so check must be skipped
	push @src, "$call;";

	push @src, '}';

	my $rv = eval_closure(
		source       => \@src,
		environment  => \%env,
	);
	return subname(sub_fullname($sub), $rv);
}

sub UNIVERSAL::ReturnType :ATTR(CODE)
{
	my ($package, $symbol, $referent, $attr, $data) = @_;

	no warnings qw(redefine);
	my %args = (@$data % 2) ? (scalar => @$data) : @$data;
	*$symbol = __PACKAGE__->wrap_sub($referent, %args);
}

1;

__END__