File Coverage

blib/lib/match/simple.pm

Criterion	Covered	Total	%
statement	21	21	100.0
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	29	29	100.0

package match::simple;

use 5.006001;
use strict;
use warnings;

use Exporter::Tiny;
use List::Util 1.33 qw( any );
use Scalar::Util qw( blessed );

BEGIN {
	$match::simple::AUTHORITY = 'cpan:TOBYINK';
	$match::simple::VERSION   = '0.012';
}

our @ISA       = qw( Exporter::Tiny );
our @EXPORT    = qw( M );
our @EXPORT_OK = qw( match );

my $xs;
unless (($ENV{MATCH_SIMPLE_IMPLEMENTATION}||'') =~ /pp/i) {
	eval {
		require match::simple::XS;
		match::simple::XS->VERSION( 0.002 );  # minimum

		# Unless we're a development version...
		# Avoid using an unstable version of ::XS
		unless (match::simple->VERSION =~ /_/) {
			die if match::simple::XS->VERSION =~ /_/;
		}

		$xs = match::simple::XS->can('match');
	};
}

eval($xs ? <<'XS' : <<'PP');

sub IMPLEMENTATION () { "XS" }

*match = *match::simple::XS::match;

XS

sub IMPLEMENTATION () { "PP" }

sub match {
	no warnings qw( uninitialized numeric );

	my ( $a, $b ) = @_;
	my $method;

	return !defined $a                      if !defined($b);
	return $a eq $b                         if !ref($b);
	return $a =~ $b                         if ref($b) eq q(Regexp);
	return do { local $_ = $a; !!$b->($a) } if ref($b) eq q(CODE);
	return any { match( $a, $_ ) } @$b      if ref($b) eq q(ARRAY);
	return !!$b->$method( $a, 1 )           if blessed($b) && ( $method = _overloaded_smartmatch( $b ) );

	require Carp;
	Carp::croak( "match::simple cannot match anything against: $b" );
}

unless ( eval 'require re; 1' and exists &re::is_regexp ) {
	require B;
	*re::is_regexp = sub {
		eval { B::svref_2object( $_[0] )->MAGIC->TYPE eq 'r' };
	};
}

sub _overloaded_smartmatch {
	my ( $obj ) = @_;
	return if re::is_regexp( $obj );

	if ( $obj->isa( 'Type::Tiny' ) ) {
		return $obj->can( 'check' );
	}

	if ( my $match = $obj->can( 'MATCH' ) ) {
		return $match;
	}

	if ( $] lt '5.010' ) { require MRO::Compat; }
	else                 { require mro;         }

	my @mro = @{ mro::get_linear_isa( ref $obj ) };
	for my $class ( @mro ) {
		my $name = "$class\::(~~";
		my $overload = do {
			no strict 'refs';
			exists( &$name ) ? \&$name : undef;
		};
		return $overload if $overload;
	}

	return;
}

PP

sub _generate_M {
	require Sub::Infix;
	&Sub::Infix::infix( \&match );
}

1;

__END__