File Coverage

blib/lib/Message/Match.pm

Criterion	Covered	Total	%
statement	48	50	96.0
branch	23	28	82.1
condition	22	30	73.3
subroutine	6	6	100.0
pod	1	1	100.0
total	100	115	86.9

package Message::Match;
{
  $Message::Match::VERSION = '1.132270';
}

use strict;use warnings;
require Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(mmatch);

sub mmatch {
    my ($message, $match) = @_;
    die 'Message::Match::mmatch: two HASH references required'
        if  scalar @_ < 2 or
            scalar @_ > 2 or
            not ref $message or
            not ref $match or
            ref $message ne 'HASH' or
            ref $match ne 'HASH';

    return _match($message, $match);
}

sub _special {
    my ($message, $match) = @_;
    substr($match, 0, 8, '');
    if($match =~ m{^/}) { #regex type
        my $re;
        eval "\$re = qr$match;";    #this is hideously inefficient
                                    #but it is highly cacheable, later on
        if($message =~ $re) {
            return 1
        } else {
            return 0;
        }
    }
    die "Message::Match::mmatch: special of unknown type passed: $match";
}

sub _match {
    my ($message, $match) = @_;
    my $ref_message = ref $message; my $ref_match = ref $match;
    if(not $ref_message and not $ref_match) { #scalar on both sides
        if(substr($match, 0, 8) eq ' special') { #special handling
            return _special($message, $match);
        }
        return $message eq $match; #otherwise, brain-dead comparison
    }
    if($ref_message eq 'JSON::PP::Boolean' and $ref_match eq 'JSON::PP::Boolean') {
        return "$message" eq "$match";
    }
    if($ref_message eq 'HASH' and $ref_match eq 'HASH') {
        foreach my $key (keys %$match) {
            my $message = $message->{$key};
            my $match = $match->{$key};
            return 0 if not defined $message;
            return 0 if not defined $match;
            return 0 unless _match($message, $match);
        }
        return 1;
    }
    if($ref_message eq 'ARRAY' and not $ref_match) {    #check for scalar inside the array
        foreach my $item (@$message) {
            return 1 if $item eq $match;
        }
        return 0;
    }
    if($ref_message eq 'ARRAY' and $ref_match eq 'ARRAY') {  #check the entire array
        foreach my $item (@$match) {
            my $match = $item;
            my $message = shift @{$message};
            return 0 unless _match($message, $match);
        }
        return 1;
    }
    return 0; #anything we don't know about fails
}
1;
__END__