File Coverage

blib/lib/Type/Coercion/Wrapped.pm

Criterion	Covered	Total	%
statement	36	51	70.5
branch	6	18	33.3
condition	4	15	26.6
subroutine	8	9	88.8
pod	2	2	100.0
total	56	95	58.9

use 5.008;
use strict;
use warnings;

package Type::Coercion::Wrapped;

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

use base 'Type::Coercion';
use Scalar::Util 'weaken';

sub _build_compiled_coercion {
	my $self = shift;

	return $self->SUPER::_build_compiled_coercion(@_)
		if $self->can_be_inlined;

	my $type = $self->type_constraint;
	my $pre  = $type->pre_coerce;
	my $orig = $self->SUPER::_build_compiled_coercion(@_);
	my $post = $type->post_coerce;

	return $orig unless $pre || $post;

	weaken $type;
	return sub {
		local $_ = $_[0];
		$_ = $pre->($type, $_) if defined($pre);
		$_ = $orig->($_);
		$_ = $post->($type, $_) if defined($post);
		return $_;
	};
}

my $counter = 0;
sub inline_coercion {
	my $self = shift;
	local $_ = (my $varname = $_[0]);

	my $tc   = $self->type_constraint;
	my $pre  = $tc && $tc->inlined_pre_coerce;
	my $post = $tc && $tc->inlined_post_coerce;

	my $code = '';
	if ($pre) {
		my $tmpvar = sprintf('$__TypeCoercionWrappedTmp%d', ++$counter);
		$code .= sprintf('my %s = do { no warnings; %s };', $tmpvar, $pre->($tc, $varname));
		$_ = $varname = $tmpvar;
	}

	do {
		my $tmpvar = sprintf('$__TypeCoercionWrappedTmp%d', ++$counter);
		$code .= sprintf('my %s = do { no warnings; %s };', $tmpvar, $self->SUPER::inline_coercion($varname));
		$_ = $varname = $tmpvar;
	};

	if ($post) {
		$code .= sprintf('do { no warnings; %s };', $post->($tc, $varname));
	}

	"do { no warnings; $code }";
}

sub can_be_inlined {
	my $self = shift;
	if (my $tc = $self->type_constraint) {
		return if $tc->pre_coerce && !$tc->inlined_pre_coerce;
		return if $tc->post_coerce && !$tc->inlined_post_coerce;
	}
	return $self->SUPER::can_be_inlined;
}

1;

__END__