File Coverage

blib/lib/isa.pm

Criterion	Covered	Total	%
statement	46	61	75.4
branch	11	34	32.3
condition	2	7	28.5
subroutine	10	11	90.9
pod	0	4	0.0
total	69	117	58.9

use 5.006;
use strict;
use warnings;

package isa;

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

BEGIN {
	*HAS_XS = eval { require Type::Tiny::XS; 1 }
		? sub(){!!1}
		: sub(){!!0};

	eval { require Mouse::Util; } unless HAS_XS();
	*HAS_MOUSE = eval { Mouse::Util::MOUSE_XS() and 'Mouse::Util'->can('generate_isa_predicate_for') }
		? sub(){!!1}
		: sub(){!!0};

	*HAS_NATIVE = ( $] ge '5.032' )
		? sub(){!!1}
		: sub(){!!0};

	*perlstring = eval { require B; 'B'->can('perlstring') }
		|| sub { sprintf '"%s"', quotemeta($_[0]) };

	*is_CodeRef = HAS_XS()
		? Type::Tiny::XS::get_coderef_for('CodeRef')
		: sub { 'CODE' eq ref $_[0] };

	*is_HashRef = HAS_XS()
		? Type::Tiny::XS::get_coderef_for('HashRef')
		: sub { 'HASH' eq ref $_[0] };

	*is_NonEmptyStr = HAS_XS()
		? Type::Tiny::XS::get_coderef_for('NonEmptyStr')
		: sub { defined $_[0] and !length ref $_[0] and length $_[0] };
};

sub import {
	my ( $caller, $me ) = ( scalar(caller), shift );

	my %imports;
	for my $arg ( @_ ) {
		if ( is_HashRef $arg ) {
			%imports = ( %imports, %$arg );
		}
		else {
			$imports{ $me->subname_for( $arg ) } = $arg;
		}
	}

	$me->setup_for( $caller, \%imports );
}

sub subname_for {
	my ( $me, $class ) = ( shift, @_ );
	$class =~ s/\W+/_/g;
	'isa_' . $class;
}

sub failed_expectation {
	my ( $me, $bad_value, $role, $expectation ) = ( shift, @_ );
	my $printable_value =
		ref($bad_value)        ? sprintf( '%s reference', ref($bad_value) ) :
		!defined($bad_value)   ? 'undef' :
		!length($bad_value)    ? 'empty string' : 'something weird';

	require Carp;
	Carp::croak( sprintf(
		'Expected %s to be %s, but got %s; failed',
		$role,
		$expectation,
		$printable_value,
	) );
}

my %cache;
sub setup_for {
	my ( $me, $caller, $imports ) = ( shift, @_ );

	while ( my ( $subname, $class ) = each %$imports ) {
		is_NonEmptyStr $subname or $me->failed_expectation( $subname, 'function name', 'non-empty string' );
		is_NonEmptyStr $class   or $me->failed_expectation( $class,   'class name',    'non-empty string' );

		no strict 'refs';
		no warnings 'redefine';
		*{"$caller\::$subname"} = (
			$cache{ $class } ||= $me->generate_coderef( $class )
			or die( "Problem generating coderef for $class" )
		);
	}
}

sub generate_coderef {
	my ( $me, $class ) = ( shift, @_ );
	my $code;

	if ( HAS_XS ) {
		my $typename = sprintf( 'InstanceOf[%s]', $class );
		$code = Type::Tiny::XS::get_coderef_for( $typename );
		return $code if is_CodeRef $code;
	}

	if ( HAS_MOUSE ) {
		$code = Mouse::Util::generate_isa_predicate_for( $class );
		return $code if is_CodeRef $code;
	}

	if ( HAS_NATIVE ) {
		$code = eval sprintf(
			q{ package isa::__NATIVE__; use feature q[isa]; no warnings q[experimental::isa]; sub { $_[0] isa %s } },
			perlstring($class),
		);
		return $code if is_CodeRef $code;
	}

	require Scalar::Util;
	$code = eval sprintf(
		q{ package isa::__LEGACY__; sub { Scalar::Util::blessed($_[0]) and $_[0]->isa(%s) } },
		perlstring($class),
	);
	return $code if is_CodeRef $code;

	return;
}

1;

__END__