File Coverage

blib/lib/Type/Tiny/ConstrainedObject.pm

Criterion	Covered	Total	%
statement	35	37	97.3
branch	3	4	75.0
condition			n/a
subroutine	12	13	92.3
pod	6	6	100.0
total	56	60	95.0

package Type::Tiny::ConstrainedObject;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Type::Tiny::ConstrainedObject::AUTHORITY = 'cpan:TOBYINK';
	$Type::Tiny::ConstrainedObject::VERSION   = '2.002001';
}

$Type::Tiny::ConstrainedObject::VERSION =~ tr/_//d;

sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }

use Type::Tiny ();
our @ISA = 'Type::Tiny';

my %errlabel = (
	parent     => 'a parent',
	constraint => 'a constraint coderef',
	inlined    => 'an inlining coderef',
);

sub new {
	my $proto = shift;
	my %opts  = ( @_ == 1 ) ? %{ $_[0] } : @_;
	for my $key ( qw/ parent constraint inlined / ) {
		next unless exists $opts{$key};
		_croak(
			'%s type constraints cannot have %s passed to the constructor',
			$proto->_short_name,
			$errlabel{$key},
		);
	}
	$proto->SUPER::new( %opts );
} #/ sub new

sub has_parent {
	!!1;
}

sub parent {
	require Types::Standard;
	Types::Standard::Object();
}

sub _short_name {
	die "subclasses must implement this";    # uncoverable statement
}

my $i                  = 0;
my $_where_expressions = sub {
	my $self = shift;
	my $name = shift;
	$name ||= "where expression check";
	my ( %env, @codes );
	while ( @_ ) {
		my $expr       = shift;
		my $constraint = shift;
		if ( !ref $constraint ) {
			push @codes, sprintf( 'do { local $_ = %s; %s }', $expr, $constraint );
		}
		else {
			require Types::Standard;
			my $type =
				Types::Standard::is_RegexpRef( $constraint )
				? Types::Standard::StrMatch()->of( $constraint )
				: Types::TypeTiny::to_TypeTiny( $constraint );
			if ( $type->can_be_inlined ) {
				push @codes,
					sprintf(
					'do { my $tmp = %s; %s }', $expr,
					$type->inline_check( '$tmp' )
					);
			}
			else {
				++$i;
				$env{ '$chk' . $i } = do { my $chk = $type->compiled_check; \$chk };
				push @codes, sprintf( '$chk%d->(%s)', $i, $expr );
			}
		} #/ else [ if ( !ref $constraint )]
	} #/ while ( @_ )

	if ( keys %env ) {

		# cannot inline
		my $sub = Eval::TypeTiny::eval_closure(
			source =>
				sprintf( 'sub ($) { local $_ = shift; %s }', join( q( and ), @codes ) ),
			description => sprintf( '%s for %s', $name, $self->name ),
			environment => \%env,
		);
		return $self->where( $sub );
	} #/ if ( keys %env )
	else {
		return $self->where( join( q( and ), @codes ) );
	}
};

sub stringifies_to {
	my $self = shift;
	my ( $constraint ) = @_;
	$self->$_where_expressions( "stringification check", q{"$_"}, $constraint );
}

sub numifies_to {
	my $self = shift;
	my ( $constraint ) = @_;
	$self->$_where_expressions( "numification check", q{0+$_}, $constraint );
}

sub with_attribute_values {
	my $self       = shift;
	my %constraint = @_;
	$self->$_where_expressions(
		"attributes check",
		map { my $attr = $_; qq{\$_->$attr} => $constraint{$attr} }
			sort keys %constraint,
	);
}

1;

__END__