File Coverage

blib/lib/match/smart.pm

Criterion	Covered	Total	%
statement	98	100	98.0
branch	64	68	94.1
condition	17	17	100.0
subroutine	24	24	100.0
pod	1	1	100.0
total	204	210	97.1

package match::smart;

use 5.006001;
use strict;
use warnings;

use B qw();
use Exporter::Tiny;
use List::Util 1.33 qw( any all );
use Scalar::Util qw( blessed looks_like_number refaddr );

BEGIN {
	$match::smart::AUTHORITY = 'cpan:TOBYINK';
	$match::smart::VERSION   = '0.011';
}

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

sub match {
	no warnings qw( uninitialized numeric );

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

	return !defined $a                     if !defined( $b );
	return !!$b->$method( $a, 1 )          if blessed( $b ) && ( $method = _overloaded_smartmatch( $b ) );

	if ( blessed($b) and not $b->isa("Regexp") ) {
		require Carp;
		Carp::croak( "Smart matching a non-overloaded object breaks encapsulation" );
	}

	$seen ||= {};
	my $refb = refaddr($b);
	return refaddr( $a ) == $refb if $refb && $seen->{$refb}++;

	if ( ref($b) eq q(ARRAY) ) {
		if ( ref($a) eq q(ARRAY) ) {
			return !!0 unless @$a == @$b;
			for my $i ( 0 .. $#$a ) {
				return !!0 unless match( $a->[$i], $b->[$i], $seen );
			}
			return !!1;
		}

		return any { exists $a->{$_} } @$b  if ref( $a ) eq q(HASH);
		return any { $_ =~ $a } @$b         if ref( $a ) eq q(Regexp);
		return any { !defined( $_ ) } @$b   if !defined( $a );
		return any { match( $a, $_ ) } @$b;
	}

	if ( ref($b) eq q(HASH) ) {
		return match( [ sort map "$_", keys %$a ], [ sort map "$_", keys %$b ] )
			if ref($a) eq q(HASH);

		return any { exists $b->{$_} } @$a  if ref( $a ) eq q(ARRAY);
		return any { $_ =~ $a } keys %$b    if ref( $a ) eq q(Regexp);
		return !!0                          if !defined( $a );
		return exists $b->{$a};
	}

	if ( ref($b) eq q(CODE) ) {
		return all { !!$b->($_) } @$a       if ref( $a ) eq q(ARRAY);
		return all { !!$b->($_) } keys %$a  if ref( $a ) eq q(HASH);
		return $b->( $a );
	}

	if ( ref($b) eq q(Regexp) ) {
		return any { $_ =~ $b } @$a       if ref( $a ) eq q(ARRAY);
		return any { $_ =~ $b } keys %$a  if ref( $a ) eq q(HASH);
		return $a =~ $b;
	}

	return !!$a->$method( $b, 0 )           if blessed( $a ) && ( $method = _overloaded_smartmatch( $a ) );
	return !defined( $b )                   if !defined( $a );
	return $a == $b                         if _is_number( $b );
	return $a == $b                         if _is_number( $a ) && looks_like_number( $b );

	return $a eq $b;
}

sub _is_number {
	my $value = shift;
	return if ref $value;
	my $flags = B::svref_2object( \$value )->FLAGS;
	$flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK );
}

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

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 defined $overload;
	}

	return;
}

1;

__END__