File Coverage

blib/lib/match/smart.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	60	64	93.7
condition	29	35	82.8
subroutine	22	22	100.0
pod	1	1	100.0
total	199	209	95.2

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.010';
}

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

	return(!defined $a)                    if !defined($b);
	return !!$b->check($a)                 if blessed($b) && $b->isa("Type::Tiny");
	return !!$b->MATCH($a, 1)              if blessed($b) && $b->can("MATCH");
	return eval 'no warnings; !!($a~~$b)'  if blessed($b) && $] >= 5.010 && do { require overload; overload::Method($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->check($b)                 if blessed($a) && $a->isa("Type::Tiny");
	return !!$a->MATCH($b)                 if blessed($a) && $a->can("MATCH");
	return eval 'no warnings; !!($a~~$b)'  if blessed($a) && $] >= 5.010 && do { require overload; overload::Method($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);
}

1;

__END__