File Coverage

blib/lib/Type/Tiny/Wrapped.pm

Criterion	Covered	Total	%
statement	47	67	70.1
branch	11	32	34.3
condition	2	21	9.5
subroutine	20	22	90.9
pod	13	13	100.0
total	93	155	60.0

use 5.008;
use strict;
use warnings;

package Type::Tiny::Wrapped;

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

use Scalar::Util 'weaken';
use Type::Tiny 0.022 ();
use base 'Type::Tiny';

sub wrapper             { $_[0]{wrapper} }
sub wrapped             { $_[0]{parent} }
sub pre_check           { $_[0]{wrapper}{pre_check} }
sub pre_coerce          { $_[0]{wrapper}{pre_coerce} }
sub post_check          { $_[0]{wrapper}{post_check} }
sub post_coerce         { $_[0]{wrapper}{post_coerce} }
sub inlined_pre_check   { $_[0]{wrapper}{inlined_pre_check} }
sub inlined_pre_coerce  { $_[0]{wrapper}{inlined_pre_coerce} }
sub inlined_post_check  { $_[0]{wrapper}{inlined_post_check} }
sub inlined_post_coerce { $_[0]{wrapper}{inlined_post_coerce} }

sub _build_compiled_check {
	my $self = shift;

	return Eval::TypeTiny::eval_closure(
		source      => sprintf('sub ($) { %s }', $self->inline_check('$_[0]')),
		description => sprintf("compiled check '%s'", $self),
	) if $self->can_be_inlined;

	my $pre  = $self->pre_check;
	my $orig = $self->wrapped->compiled_check(@_);
	my $post = $self->post_check;

	return $orig unless $pre || $post;

	weaken $self;
	return sub {
		local $_ = $_[0];
		return if defined($pre) && !$pre->($self, @_);
		return if !$orig->(@_);
		return if defined($post) && !$post->($self, @_);
		return !!1;
	};
}

sub _strict_check {
	my $self = shift;
	local $_ = $_[0];

	my $pre  = $self->pre_check;
	my $post = $self->post_check;

	return if defined($pre) && !$pre->($self, @_);
	return if !$self->wrapped->_strict_check(@_);
	return if defined($post) && !$post->($self, @_);

	return !!1;
}

sub is_subtype_of {
	my $self = shift;
	$self->wrapper->is_a_type_of(@_) or $self->SUPER::is_subtype_of(@_);
}

sub inline_check {
	my $self  = shift;
	local $_ = (my $var = $_[0]);

	Type::Tiny::_croak('Cannot inline type constraint check for "%s"', $self)
		unless $self->can_be_inlined;

	my @r;
	if (my $pre = $self->inlined_pre_check) {
		push @r, $pre->($self, $var);
	}
	push @r, $self->wrapped->inline_check($var);
	if (my $post = $self->inlined_post_check) {
		push @r, $post->($self, $var);
	}

	my $r = join " && " => map { /[;{}]/ ? "do { $_ }" : "($_)" } @r;
	return @r==1 ? $r : "($r)";
}

sub can_be_inlined {
	my $self = shift;
	return if $self->pre_check && ! $self->inlined_pre_check;
	return if $self->post_check && ! $self->inlined_post_check;
	return $self->wrapped->can_be_inlined;
}

1;

__END__