File Coverage

blib/lib/Type/Tiny/Wrapper.pm

Criterion	Covered	Total	%
statement	35	47	74.4
branch	3	6	50.0
condition	1	3	33.3
subroutine	10	20	50.0
pod	14	14	100.0
total	63	90	70.0

use 5.008;
use strict;
use warnings;

package Type::Tiny::Wrapper;

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

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

sub new {
	my $class = shift;
	my $self = $class->SUPER::new(@_);
	Type::Tiny::_croak("Type::Tiny::Wrapper types must not have a constraint!")
		unless $self->_is_null_constraint;
	return $self;
}

sub wrap {
	my $self = shift;
	my $type = Types::TypeTiny::to_TypeTiny($_[0]);
	require Type::Tiny::Wrapped;
	require Type::Coercion::Wrapped;
	my $wrapped = bless($type->create_child_type => 'Type::Tiny::Wrapped');
	$wrapped->{wrapper}      = $self;
	$wrapped->{display_name} = sprintf('%s[%s]', $self->display_name, $type->display_name);
	$wrapped->{coercion}   ||= 'Type::Coercion::Wrapped'->new(
		type_constraint   => $wrapped,
		type_coercion_map => $type->has_coercion
			? [ @{$type->coercion->type_coercion_map} ]
			: [ Types::Standard::Any(), q{ $_ } ],
	);
	bless($wrapped->{coercion} => 'Type::Coercion::Wrapped');
	return $wrapped;
}

my @FIELDS = qw/
	pre_check pre_coerce post_check post_coerce
	inlined_pre_check inlined_pre_coerce inlined_post_check inlined_post_coerce
/;
sub pre_check           { $_[0]{pre_check} }
sub pre_coerce          { $_[0]{pre_coerce} }
sub post_check          { $_[0]{post_check} }
sub post_coerce         { $_[0]{post_coerce} }
sub inlined_pre_check   { $_[0]{inlined_pre_check} }
sub inlined_pre_coerce  { $_[0]{inlined_pre_coerce} }
sub inlined_post_check  { $_[0]{inlined_post_check} }
sub inlined_post_coerce { $_[0]{inlined_post_coerce} }

sub child_type_class { +__PACKAGE__ }

sub create_child_type {
	my $self = shift;
	$self->SUPER::create_child_type(
		( map {
			exists($self->{$_}) ? ($_ => $self->{$_}) : ()
		} @FIELDS ),
		@_,
	);
}

sub has_constraint_generator { 1 }

sub constraint_generator {
	my $self = shift;
	weaken $self;
	return sub { $self->wrap(shift) };
}

1;

__END__