File Coverage

blib/lib/Hash/Match.pm

Criterion	Covered	Total	%
statement	79	82	96.3
branch	30	32	93.7
condition	4	6	66.6
subroutine	20	20	100.0
pod	1	1	100.0
total	134	141	95.0

package Hash::Match;

# ABSTRACT: match contents of a hash against rules

use v5.10.0;

use strict;
use warnings;

our $VERSION = 'v0.7.2';

use Carp qw/ croak /;
use List::AllUtils qw/ natatime /;
use Ref::Util qw/ is_coderef is_hashref is_ref is_regexpref /;

# RECOMMEND PREREQ: List::SomeUtils::XS
# RECOMMEND PREREQ: Ref::Util::XS

use namespace::autoclean;


sub new {
    my ($class, %args) = @_;

    if (my $rules = $args{rules}) {

        my $root = is_hashref($rules) ? '-all' : '-any';
        my $self = _compile_rule( $root => $rules, $class );
        bless $self, $class;

    } else {

        croak "Missing 'rules' attribute";

    }
}

sub _compile_match {
    my ($value) = @_;

    if ( is_ref($value) ) {

        return sub { ($_[0] // '') =~ $value } if is_regexpref($value);

        return sub { $value->($_[0]) } if is_coderef($value);

        croak sprintf('Unsupported type: \'%s\'', ref $value);

    } else {

        return sub { ($_[0] // '') eq $value } if (defined $value);

        return sub { !defined $_[0] };

    }
}

my %KEY2FN = (
    '-all'	=> List::AllUtils->can('all'),
    '-and'	=> List::AllUtils->can('all'),
    '-any'	=> List::AllUtils->can('any'),
    '-notall'	=> List::AllUtils->can('notall'),
    '-notany'	=> List::AllUtils->can('none'),
    '-or'	=> List::AllUtils->can('any'),
);

sub _key2fn {
    my ($key, $ctx) = @_;

    # TODO: eventually add a warning message about -not being
    # deprecated.

    if ($key eq '-not') {
	$ctx //= '';
	$key = ($ctx eq 'HASH') ? '-notall' : '-notany';
    }

    $KEY2FN{$key} or croak "Unsupported key: '${key}'";
}

sub _compile_rule {
    my ( $key, $value, $ctx ) = @_;

    if ( my $key_ref = ( ref $key ) ) {

        if (is_regexpref($key)) {

            my $match = _compile_match($value);

            my $fn = _key2fn($ctx);

            return sub {
                my $hash = $_[0];
                $fn->( sub { $match->( $hash->{$_} ) },
                       grep { $_ =~ $key } (keys %{$hash}) );
            };

        } elsif (is_coderef($key)) {

            my $match = _compile_match($value);

            my $fn = _key2fn($ctx);

            return sub {
                my $hash = $_[0];
                $fn->( sub { $match->( $hash->{$_} ) },
                       grep { $key->($_) } (keys %{$hash}) );
            };

        } else {

            croak "Unsupported key type: '${key_ref}'";

        }

    } else {

        my $match_ref = ref $value;

	if ( $match_ref =~ /^(?:ARRAY|HASH)$/ ) {

            my $it = ( $match_ref eq 'ARRAY' )
		? natatime 2, @{$value}
	        : sub { each %{$value} };

            my @codes;
            while ( my ( $k, $v ) = $it->() ) {
                push @codes, _compile_rule( $k, $v, $key );
            }

            my $fn = _key2fn($key, $match_ref);

            return sub {
                my $hash = $_[0];
                $fn->( sub { $_->($hash) }, @codes );
            };

        } elsif ( $match_ref =~ /^(?:Regexp|CODE|)$/ ) {

            my $match = _compile_match($value);

            return sub {
                my $hash = $_[0];
                (exists $hash->{$key}) ? $match->($hash->{$key}) : 0;
            };

        } else {

            croak "Unsupported type: '${match_ref}'";

        }

    }

    croak "Unhandled condition";
}

1;

__END__