File Coverage

blib/lib/Data/PatternCompare.pm

Criterion	Covered	Total	%
statement	209	213	98.1
branch	107	116	92.2
condition	39	49	79.5
subroutine	26	28	92.8
pod	5	5	100.0
total	386	411	93.9

package Data::PatternCompare;

use strict;
use warnings;

use POSIX;
use Scalar::Util qw(looks_like_number refaddr blessed);
use Scalar::Util::Numeric qw(isfloat);

our $VERSION = '0.04';

sub EMPTY_KEY() { "empty \x{c0}\x{de}" }

our @EXPORT_OK = qw(any empty);
our $any   = Data::PatternCompare::Any->new;
our @empty = (EMPTY_KEY, Data::PatternCompare::Empty->new);

sub _any() {
    $any
}

sub _empty() {
    @empty
}

sub import_to {
    my ($caller, @export) = @_;

    no strict 'refs';
    no warnings 'redefine';

    for my $sub (@export) {
        my $dst = $caller .'::'. $sub;
        my $src = __PACKAGE__ .'::_'. $sub;

        *$dst = *$src;
    }
}

sub import {
    my $class  = shift;
    my $caller = caller;
    my @export;
    my %is_export_ok = map { $_ => 1 } @EXPORT_OK;

    for my $sub ( @_ ) {
        push @export, $sub if $is_export_ok{$sub};
    }

    import_to($caller, @export);
}

sub new {
    my $class  = shift;
    my %params = @_;

    @params{qw(_dup_addr _dup_addra _dup_addrb)} = ({}, {}, {});
    $params{'epsilon'} ||= POSIX::DBL_EPSILON;

    return bless(\%params, $class);
}

sub _is_any {
    my $val   = shift;
    my $class = blessed($val);

    if ($class && $class eq 'Data::PatternCompare::Any') {
        return $class;
    }

    return 0;
}

sub _is_empty {
    my $val = shift;

    if (ref $val eq 'ARRAY') {
        return 0 unless defined $val->[1];

        my $blessed = blessed($val->[1]) || '';
        return (
            defined $val->[0] && $val->[0] eq EMPTY_KEY
            && $blessed eq 'Data::PatternCompare::Empty'
        );
    } else {
        return 0 unless defined $val->{+EMPTY_KEY};

        my $blessed = blessed($val->{+EMPTY_KEY}) || '';
        return $blessed eq 'Data::PatternCompare::Empty';
    }
}

sub _match_ARRAY {
    my ($self, $got, $expected) = @_;

    if (_is_empty($expected)) {
        return scalar(@$got) == 0;
    }

    for (my $i = 0; $i < scalar(@$expected); ++$i) {
        if (_is_any($expected->[$i]) && !exists($got->[$i])) {
            return 0;
        }
        return 0 unless $self->_pattern_match($got->[$i], $expected->[$i]);
    }

    return 1;
}

sub _match_HASH {
    my ($self, $got, $expected) = @_;

    if (_is_empty($expected)) {
        return scalar(keys %$got) == 0;
    }

    for my $key ( keys %$expected ) {
        if (_is_any($expected->{$key}) && !exists($got->{$key})) {
            return 0;
        }
        return 0 unless $self->_pattern_match($got->{$key}, $expected->{$key});
    }

    return 1;
}

sub _pattern_match {
    my ($self, $got, $expected) = @_;

    my $ref = ref($expected);
    unless ($ref) {
        # simple type
        unless (defined $expected && defined $got) {
            unless (defined $expected || defined $got) {
                return 1;
            }
            return 0;
        }

        if (looks_like_number($expected)) {
            return 0 unless looks_like_number($got);

            if (isfloat($expected) || isfloat($got)) {
                return abs($expected - $got) < $self->{'epsilon'};
            }
            return $expected == $got;
        }

        return $expected eq $got;
    }

    my $addr   = refaddr($expected);
    my $is_dup = $self->{'_dup_addr'};
    if (exists $is_dup->{$addr}) {
        die "Cycle in pattern: $expected";
    }
    $is_dup->{$addr} = 1;

    my $class  = blessed($expected);
    if ($class) {
        return 1 if $class eq 'Data::PatternCompare::Any';

        return (
            $class eq blessed($got) &&
            $addr == refaddr($got)
        );
    }

    my $code = $self->can("_match_$ref");
    die "Don't know how to match $ref type" unless $code;

    return 0 unless ref($got) eq $ref;

    return $self->$code($got, $expected);
}

sub pattern_match {
    my $self = shift;

    my $res;
    eval {
        $res = $self->_pattern_match(@_);
    };
    $self->{'_dup_addr'} = {};
    die $@ if $@;

    return $res;
}

sub _compare_ARRAY {
    my ($self, $pa, $pb) = @_;

    my @tmp = map { _is_empty($_) } ($pa, $pb);
    if ($tmp[0] + $tmp[1]) {
        return $tmp[1] - $tmp[0];
    }

    my $sizea = scalar(@$pa);
    my $sizeb = scalar(@$pb);

    unless ($sizea eq $sizeb) {
        return $sizea > $sizeb ? -1 : 1;
    }

    for (my $i = 0; $i < $sizea; ++$i) {
        my $res = $self->_compare_pattern($pa->[$i], $pb->[$i]);

        return $res if $res;
    }

    return 0;
}

sub _compare_HASH {
    my ($self, $pa, $pb) = @_;

    my @tmp = map { _is_empty($_) } ($pa, $pb);
    if ($tmp[0] + $tmp[1]) {
        return $tmp[1] - $tmp[0];
    }

    my $sizea = scalar keys(%$pa);
    my $sizeb = scalar keys(%$pb);

    unless ($sizea eq $sizeb) {
        return $sizea > $sizeb ? -1 : 1;
    }

    for my $key ( keys %$pa ) {
        next unless exists $pb->{$key};

        my $res = $self->_compare_pattern($pa->{$key}, $pb->{$key});

        return $res if $res;
    }

    return 0;
}

sub _compare_pattern {
    my ($self, $pa, $pb) = @_;

    my $refa = ref($pa);
    my $refb = ref($pb);
    my @tmp  = grep { $_ } ($refa, $refb);
    my $cnt  = scalar(@tmp);

    # simple type - equal
    return 0 unless $cnt;

    # 1 ref
    if ($cnt == 1) {
        # any ref (including any) is wider than simple type
        return $refb ? -1 : 1;
    }

    my $addra  = refaddr($pa);
    my $addrb  = refaddr($pb);
    my $classa = blessed($pa);
    my $classb = blessed($pb);

    my $is_dupa = $self->{'_dup_addra'};
    my $is_dupb = $self->{'_dup_addrb'};
    if (exists $is_dupa->{$addra} || exists $is_dupb->{$addrb}) {
        die "Cycle in pattern";
    }
    $is_dupa->{$addra} = 1;
    $is_dupb->{$addrb} = 1;

    @tmp = grep { $_ && $_ eq 'Data::PatternCompare::Any' } ($classa, $classb);
    $cnt = scalar @tmp;

    # 1 "any"
    if ($cnt == 1) {
        return $classb eq 'Data::PatternCompare::Any' ? -1 : 1;
    }

    # both are "any"
    return 0 if $cnt == 2;

    # different types, no reason to go deeper
    return 0 unless $refa eq $refb;

    my $code = __PACKAGE__->can("_compare_$refa");
    die "Don't know how to compare $refa type" unless $code;

    return $self->$code($pa, $pb);
}

sub compare_pattern {
    my $self = shift;

    my $res;
    eval {
        $res = $self->_compare_pattern(@_);
    };
    $self->{'_dup_addra'} = {};
    $self->{'_dup_addrb'} = {};

    die $@ if $@;

    return $res;
}

sub _eq_ARRAY {
    my ($self, $got, $expected) = @_;

    return 0 unless scalar(@$got) == scalar(@$expected);

    for (my $i = 0; $i < scalar(@$expected); ++$i) {
        return 0 unless $self->_eq_pattern($got->[$i], $expected->[$i]);
    }

    return 1;
}

sub _eq_HASH {
    my ($self, $got, $expected) = @_;

    return 0 unless scalar(keys %$got) == scalar(keys %$expected);

    for my $key ( keys %$expected ) {
        return 0 unless $self->_eq_pattern($got->{$key}, $expected->{$key});
    }

    return 1;
}

sub _eq_pattern {
    my ($self, $got, $expected) = @_;

    my $ref = ref($expected);
    unless ($ref) {
        # simple type
        unless (defined $expected && defined $got) {
            unless (defined $expected || defined $got) {
                return 1;
            }
            return 0;
        }

        if (looks_like_number($expected)) {
            return 0 unless looks_like_number($got);

            if (isfloat($expected) || isfloat($got)) {
                return abs($expected - $got) < $self->{'epsilon'};
            }
            return $expected == $got;
        }

        return $expected eq $got;
    }

    my $addr   = refaddr($expected);
    my $is_dup = $self->{'_dup_addr'};
    if (exists $is_dup->{$addr}) {
        die "Cycle in pattern: $expected";
    }
    $is_dup->{$addr} = 1;

    my $class  = blessed($expected);
    if ($class) {
        my $got_blessed = blessed($got) || '';
        my $got_addr = refaddr($got) || 0;
        return (
            $class eq $got_blessed &&
            $addr == $got_addr
        );
    }

    my $code = $self->can("_eq_$ref");
    die "Don't know how to eq $ref type" unless $code;

    return 0 unless ref($got) eq $ref;

    return $self->$code($got, $expected);
}

sub eq_pattern {
    my $self = shift;

    my $res;
    eval {
        $res = $self->_eq_pattern(@_);
    };
    $self->{'_dup_addr'} = {};

    die $@ if $@;

    return $res;
}

package Data::PatternCompare::Any;

sub new { bless({}); }

package Data::PatternCompare::Empty;

sub new { bless({}); }

42;

__END__