File Coverage

blib/lib/Type/Tiny/Class.pm

Criterion	Covered	Total	%
statement	97	121	80.1
branch	25	42	59.5
condition	6	12	50.0
subroutine	28	31	90.3
pod	7	7	100.0
total	163	213	76.5

package Type::Tiny::Class;

use 5.008001;
use strict;
use warnings;

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

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

use Scalar::Util qw< blessed >;

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 { 'Class' }

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

	$opts->{name}  = $name unless exists $opts->{name}; $opts->{name} =~ s/:://g;
	$opts->{class} = $name unless exists $opts->{class};
	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 };
}

sub new {
	my $proto = shift;
	return $proto->class->new( @_ ) if blessed $proto;    # DWIM

	my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
	_croak "Need to supply class name" unless exists $opts{class};

	if ( Type::Tiny::_USE_XS ) {
		my $xsub =
			Type::Tiny::XS::get_coderef_for( "InstanceOf[" . $opts{class} . "]" );
		$opts{compiled_type_constraint} = $xsub if $xsub;
	}
	elsif ( Type::Tiny::_USE_MOUSE ) {
		require Mouse::Util::TypeConstraints;
		my $maker = "Mouse::Util::TypeConstraints"->can( "generate_isa_predicate_for" );
		$opts{compiled_type_constraint} = $maker->( $opts{class} ) if $maker;
	}

	return $proto->SUPER::new( %opts );
} #/ sub new

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

sub has_inlined { !!1 }

sub _is_null_constraint { 0 }

sub _build_constraint {
	my $self  = shift;
	my $class = $self->class;
	return sub { blessed( $_ ) and $_->isa( $class ) };
}

sub _build_inlined {
	my $self  = shift;
	my $class = $self->class;

	my $xsub;
	$xsub = Type::Tiny::XS::get_subname_for( "InstanceOf[$class]" )
		if Type::Tiny::_USE_XS;

	sub {
		my $var = $_[1];
		return
			qq{do { use Scalar::Util (); Scalar::Util::blessed($var) and $var->isa(q[$class]) }}
			if $Type::Tiny::AvoidCallbacks;
		return "$xsub\($var\)"
			if $xsub;
		qq{Scalar::Util::blessed($var) and $var->isa(q[$class])};
	};
} #/ sub _build_inlined

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

sub _instantiate_moose_type {
	my $self = shift;
	my %opts = @_;
	delete $opts{parent};
	delete $opts{constraint};
	delete $opts{inlined};
	require Moose::Meta::TypeConstraint::Class;
	return "Moose::Meta::TypeConstraint::Class"
		->new( %opts, class => $self->class );
} #/ sub _instantiate_moose_type

sub plus_constructors {
	my $self = shift;

	unless ( @_ ) {
		require Types::Standard;
		push @_, Types::Standard::HashRef(), "new";
	}

	require B;
	require Types::TypeTiny;

	my $class = B::perlstring( $self->class );

	my @r;
	while ( @_ ) {
		my $source = shift;
		Types::TypeTiny::is_TypeTiny( $source )
			or _croak "Expected type constraint; got $source";

		my $constructor = shift;
		Types::TypeTiny::is_StringLike( $constructor )
			or _croak "Expected string; got $constructor";

		push @r, $source, sprintf( '%s->%s($_)', $class, $constructor );
	} #/ while ( @_ )

	return $self->plus_coercions( \@r );
} #/ sub plus_constructors

sub parent {
	$_[0]{parent} ||= $_[0]->_build_parent;
}

sub _build_parent {
	my $self  = shift;
	my $class = $self->class;

	# Some classes (I'm looking at you, Math::BigFloat) include a class in
	# their @ISA to inherit methods, but then override isa() to return false,
	# so that they don't appear to be a subclass.
	#
	# In these cases, we don't want to list the parent class as a parent
	# type constraint.
	#
	my @isa = grep $class->isa( $_ ),
		do { no strict "refs"; no warnings; @{"$class\::ISA"} };

	if ( @isa == 0 ) {
		require Types::Standard;
		return Types::Standard::Object();
	}

	if ( @isa == 1 ) {
		return ref( $self )->new( class => $isa[0] );
	}

	require Type::Tiny::Intersection;
	"Type::Tiny::Intersection"->new(
		type_constraints => [ map ref( $self )->new( class => $_ ), @isa ],
	);
} #/ sub _build_parent

*__get_linear_isa_dfs =
	eval { require mro }
	? \&mro::get_linear_isa
	: sub {
	no strict 'refs';

	my $classname = shift;
	my @lin       = ( $classname );
	my %stored;

	foreach my $parent ( @{"$classname\::ISA"} ) {
		my $plin = __get_linear_isa_dfs( $parent );
		foreach ( @$plin ) {
			next if exists $stored{$_};
			push( @lin, $_ );
			$stored{$_} = 1;
		}
	}

	return \@lin;
	};

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 );

	my @isa = @{ __get_linear_isa_dfs( ref $value ) };

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

	require Type::Utils;
	return [
		sprintf( '"%s" requires that the reference isa %s', $self, $self->class ),
		sprintf(
			'The reference%s isa %s', $display_var, Type::Utils::english_list( @isa )
		),
	];
} #/ sub validate_explain

1;

__END__