File Coverage

blib/lib/Hash/Match.pm

Criterion	Covered	Total	%
statement	75	78	96.1
branch	30	32	93.7
condition	15	16	93.7
subroutine	19	19	100.0
pod	1	1	100.0
total	140	146	95.8

package Hash::Match;

# ABSTRACT: match contents of a hash against rules

use v5.14;
use warnings;

our $VERSION = 'v0.8.0';

use Carp qw/ croak /;
use List::AllUtils qw/ natatime /;
use Ref::Util qw/ is_arrayref is_blessed_ref 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] };

    }
}

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

    state $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'),
    };

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

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

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

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

    if ( is_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 sprintf( "Unsupported key type: '\%s'", ref $key );

        }

    } else {

        if ( !is_blessed_ref($value) && ( is_arrayref($value) || is_hashref($value) ) ) {

            my $it = is_arrayref($value)
                ? natatime 2, @{$value}
                : sub { each %{$value} };

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

            my $fn = _key2fn($key, is_hashref($value));

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

        } elsif ( is_coderef($value) || is_regexpref($value) || !is_ref($value) ) {

            my $match = _compile_match($value);

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

        } else {

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

        }

    }

    croak "Unhandled condition";
}

1;

__END__