File Coverage

blib/lib/isa.pm

Criterion	Covered	Total	%
statement	43	45	95.5
branch	6	12	50.0
condition	3	7	42.8
subroutine	11	11	100.0
pod	0	3	0.0
total	63	78	80.7

use 5.006;
use strict;
use warnings;

package isa;

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

BEGIN {
	*HAS_XS     = eval { require Type::Tiny::XS; 1 } ? 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]) };
};

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

	my $imports;
	if ( @_==1 and ref($_[0]) eq 'HASH' ) {
		$imports = $_[0];
	}
	else {
		my %imports = map { $me->subname_for($_) => $_ } @_;
		$imports = \%imports;
	}

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

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

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

	while ( my ($subname, $class) = each %$imports ) {
		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 $coderef;
	if ( HAS_XS ) {
		my $native_will_be_faster = 0;

		if ( HAS_NATIVE ) {
			my $class_isa = eval { $class->can('isa') };
			if ( $class_isa and $class_isa != \&UNIVERSAL::isa ) {
				$native_will_be_faster = 1;
			}
		}

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

	my $code;
	if ( HAS_NATIVE ) {
		$code = sprintf(
			q{ package isa::__NATIVE__; use feature q[isa]; no warnings q[experimental::isa]; sub { $_[0] isa %s } },
			perlstring($class),
		);
	}
	else {
		require Scalar::Util;
		$code = sprintf(
			q{ package isa::__LEGACY__; sub { Scalar::Util::blessed($_[0]) and $_[0]->isa(%s) } },
			perlstring($class),
		);
	}

	$coderef = eval $code;
	ref($coderef) ? $coderef : ();
}

1;

__END__