File Coverage

blib/lib/Type/Tiny/Role.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	18	28	64.2
condition	5	12	41.6
subroutine	23	23	100.0
pod	5	5	100.0
total	119	136	87.5

package Type::Tiny::Role;

use 5.008001;
use strict;
use warnings;

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

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

use Scalar::Util qw< blessed weaken >;

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

use Exporter::Tiny 1.004001 ();
use Type::Tiny::ConstrainedObject ();
our @ISA = qw( Type::Tiny::ConstrainedObject Exporter::Tiny );

sub _short_name { 'Role' }

sub _exporter_fail {
	my ( $class, $name, $opts, $globals ) = @_;
	my $caller = $globals->{into};

	$opts->{name} = $name unless exists $opts->{name}; $opts->{name} =~ s/:://g;
	$opts->{role} = $name unless exists $opts->{role};
	my $type = $class->new($opts);

	$INC{'Type/Registry.pm'}
		? 'Type::Registry'->for_class( $caller )->add_type( $type )
		: ( $Type::Registry::DELAYED{$caller}{$type->name} = $type )
		unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
	return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
}

my %cache;

sub new {
	my $proto = shift;
	my %opts  = ( @_ == 1 ) ? %{ $_[0] } : @_;
	_croak "Need to supply role name" unless exists $opts{role};
	return $proto->SUPER::new( %opts );
}

sub role    { $_[0]{role} }
sub inlined { $_[0]{inlined} ||= $_[0]->_build_inlined }

sub has_inlined { !!1 }

sub _is_null_constraint { 0 }

sub _build_constraint {
	my $self = shift;
	my $role = $self->role;
	return sub {
		blessed( $_ ) and do {
			my $method = $_->can( 'DOES' ) || $_->can( 'isa' );
			$_->$method( $role );
		}
	};
} #/ sub _build_constraint

sub _build_inlined {
	my $self = shift;
	my $role = $self->role;
	sub {
		my $var = $_[1];
		my $code =
			qq{Scalar::Util::blessed($var) and do { my \$method = $var->can('DOES')||$var->can('isa'); $var->\$method(q[$role]) }};
		return qq{do { use Scalar::Util (); $code }} if $Type::Tiny::AvoidCallbacks;
		$code;
	};
} #/ sub _build_inlined

sub _build_default_message {
	my $self = shift;
	my $c    = $self->role;
	return sub {
		sprintf '%s did not pass type constraint (not DOES %s)',
			Type::Tiny::_dd( $_[0] ), $c;
		}
		if $self->is_anon;
	my $name = "$self";
	return sub {
		sprintf '%s did not pass type constraint "%s" (not DOES %s)',
			Type::Tiny::_dd( $_[0] ), $name, $c;
	};
} #/ sub _build_default_message

sub validate_explain {
	my $self = shift;
	my ( $value, $varname ) = @_;
	$varname = '$_' unless defined $varname;

	return undef if $self->check( $value );
	return ["Not a blessed reference"] unless blessed( $value );
	return ["Reference provides no DOES method to check roles"]
		unless $value->can( 'DOES' );

	my $display_var = $varname eq q{$_} ? '' : sprintf( ' (in %s)', $varname );

	return [
		sprintf( '"%s" requires that the reference does %s', $self, $self->role ),
		sprintf( "The reference%s doesn't %s", $display_var,        $self->role ),
	];
} #/ sub validate_explain

1;

__END__