view release on metacpan or  search on metacpan

lib/isa.pm  view on Meta::CPAN

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, @_ );