File Coverage

blib/lib/FlyBy.pm

Criterion	Covered	Total	%
statement	157	161	97.5
branch	63	72	87.5
condition	28	48	58.3
subroutine	19	21	90.4
pod	4	5	80.0
total	271	307	88.2

package FlyBy;

use strict;
use warnings;
use 5.010;
our $VERSION = '0.093';

use Moo;

use Carp qw(croak);
use Parse::Lex;
use Scalar::Util qw(reftype);
use Set::Scalar;
use Try::Tiny;

has index_sets => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {}; },
);

has records => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { []; },
);

has _full_set => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { Set::Scalar->new; },
);

has query_lexer => (
    is       => 'ro',
    init_arg => undef,
    lazy     => 1,
    builder  => '_build_query_lexer',
);

my $negation = '!';

sub _build_query_lexer {
    my $self = shift;

    my @tokens = (
        "NOTEQUAL"      => "(is not|IS NOT)",
        "EQUAL"         => "is|IS",
        "AND"           => "and|AND",
        "OR"            => "or|OR",
        "REDUCE"        => "->",
        "COMMA"         => ",",
        "QUOTED_STRING" => qq~(?:\'(?:[^\\\']*(?:\\.[^\\\']*)*)\'|\"(?:[^\\\"]*(?:\\.[^\\\"]*)*)\")~,    # From Text::Balanced
        "ERROR"         => ".*",
        sub { die qq!cannot analyze: "$_[1]"!; });

    return Parse::Lex->new(@tokens);
}

sub add_records {
    my ($self, @new_records) = @_;

    my $index_sets = $self->index_sets;
    my $records    = $self->records;

    foreach my $record (@new_records) {
        my $whatsit = reftype($record) // 'no reference';
        croak 'Records must be hash references, got: ' . $whatsit unless ($whatsit eq 'HASH');

        my $rec_index = $#$records + 1;    # Even if we accidentally made this sparse, we can insert here.
        my $add_it    = 0;                 # Do not add until we know there is at least one defined value;
        while (my ($k, $v) = each %$record) {
            if (defined $v) {
                $self->_from_index($k, $v, 1)->insert($rec_index);
                $add_it ||= 1;
            } else {
                delete $record->{$k};      # A missing key denotes an undefined value.
            }
        }
        if ($add_it) {
            $records->[$rec_index] = $record;
            $self->_full_set->insert($rec_index);
        }
    }

    return 1;
}

sub _from_index {
    my ($self, $key, $value, $add_missing_key) = @_;
    my $index_sets = $self->index_sets;

    my ($result, $negated);

    if (substr($value, 0, 1) eq $negation) {
        $negated = 1;
        $value = substr($value, 1);
    }

    if (not $add_missing_key and not exists $index_sets->{$key}) {
        $result = ($negated) ? $self->_full_set : $self->_full_set->empty_clone;    # Avoiding auto-viv on request
    } else {
        $index_sets->{$key}{$value} //= $self->_full_set->empty_clone;              # Sets which do not (yet) exist in the index are null.
        $result = $index_sets->{$key}{$value};
        $result = $self->_full_set->difference($result) if ($negated);
    }

    return $result;
}

sub query {
    my ($self, $query_clauses, $reduce_list) = @_;

    if (not reftype($query_clauses)) {
        my $err;                                                                    # To let us notice parsing errors;
        croak 'String queries should have a single parameter' if (defined $reduce_list);
        ($query_clauses, $reduce_list, $err) = $self->parse_query($query_clauses);
        croak $err if $err;
    } else {
        # Trust the parser above, so we only verify on 'hand-made' queries.
        croak 'Query clauses should be a non-empty hash reference.'
            unless ($query_clauses and (reftype($query_clauses) // '') eq 'HASH' and keys %$query_clauses);
        croak 'Reduce list should be a non-empty array reference.'
            unless (not $reduce_list or ((reftype($reduce_list) // '') eq 'ARRAY' and scalar @$reduce_list));

        # Now convert the supplied hashref to an array reference we can use.
        my %qhash = %$query_clauses;
        $query_clauses = [map { [$_ => $qhash{$_}] } grep { defined $qhash{$_} } keys %qhash];
    }

    my $match_set = $self->_full_set;
    my @qc        = @$query_clauses;

    while (my $addl_clause = shift @qc) {
        my ($key, $value) = @$addl_clause;
        my $whatsit = reftype($value);
        my $change_set;
        if ($whatsit && $whatsit eq 'ARRAY') {
            # OR syntax.
            my @ors = @$value;
            $value = shift @ors;
            # Allow for negation, even though it seems unlikely.
            $change_set = $self->_from_index($key, $value, 0);
            foreach my $or (@ors) {
                $change_set = $change_set->union($self->_from_index($key, $or, 0));
            }
        } else {
            $change_set = $self->_from_index($key, $value, 0);
        }

        $match_set = $match_set->intersection($change_set);
    }

    my $records = $self->records;
    # Sort may only be important for testing.  Reconsider if large slow sets appear.
    my @indices = sort { $a <=> $b } ($match_set->elements);
    my @results;

    if ($reduce_list) {
        my @keys      = @$reduce_list;
        my $key_count = scalar @keys;
        my %seen;
        foreach my $idx (@indices) {
            my @reduced_element = map { ($records->[$idx]->{$_} // '') } @keys;
            my $seen_key = join('->', @reduced_element);
            if (not $seen{$seen_key}) {
                push @results, ($key_count > 1) ? \@reduced_element : @reduced_element;
                $seen{$seen_key}++;
            }
        }
    } else {
        @results = map {
            { %{$records->[$_]} }
        } @indices;
    }

    return @results;
}

sub parse_query {
    my ($self, $query) = @_;

    my (%values, $err);
    my $lexer = $self->query_lexer;
    my $parse_err = sub { return 'Improper query at: ' . shift; };

    try {
        croak 'Empty query' unless $query;
        my @clause = ();
        my @tokens = $lexer->analyze($query);
        my ($in_reduce, $negated, $in_or) = (0, 0);
        $values{query} = [];
        TOKEN:
        while (my $name = shift @tokens) {
            my $text = shift @tokens;
            if ($name eq 'EOI') {
                # We must be done.
                if (@clause and $in_reduce) {
                    $values{reduce} = [@clause];
                } elsif (@clause) {
                    push @{$values{query}}, [@clause];
                }

                last TOKEN;
            }
            next TOKEN if ($name eq 'COMMA');    # They can put commas anywhere, we don't care.
            my $expected_length = 2;
            if ($name eq 'QUOTED_STRING') {
                my $value = ($negated) ? $negation . substr($text, 1, -1) : substr($text, 1, -1);
                if ($in_or) {
                    $clause[-1] = [$clause[-1]] unless (reftype($clause[-1]));
                    push @{$clause[-1]}, $value;
                } else {
                    push @clause, $value;
                }
                ($in_or, $negated) = 0;
            } elsif ($name eq 'AND') {
                croak $parse_err->($text) if ($in_reduce or scalar @clause != $expected_length);
                push @{$values{query}}, [@clause];
                @clause = ();    # Starting a new clause.
            } elsif ($name eq 'OR') {
                croak $parse_err->($text) if ($in_reduce or scalar @clause != $expected_length);
                $in_or = 1;
            } elsif ($name eq 'EQUAL') {
                croak $parse_err->($text) if ($in_reduce or scalar @clause != $expected_length - 1);
            } elsif ($name eq 'NOTEQUAL') {
                croak $parse_err->($text) if ($in_reduce or scalar @clause != $expected_length - 1);
                $negated = 1;
            } elsif ($name eq 'REDUCE') {
                croak $parse_err->($text) if ($in_reduce);
                $in_reduce = 1;
                push @{$values{query}}, [@clause] if (@clause);
                @clause = ();
            }
        }
    }
    catch {
        $err = $_;
    };

    return $values{query}, $values{reduce}, $err;
}

sub _check_clause {
    my ($self, $thing) = @_;

    my $whatsit = reftype $thing;
    return ($whatsit and $whatsit eq 'ARRAY' and scalar @$thing == 2);
}

sub all_keys {
    my $self = shift;
    return (sort { $a cmp $b } keys %{$self->index_sets});
}

sub values_for_key {
    my ($self, $key) = @_;
    return (sort { $a cmp $b } keys %{$self->index_sets->{$key}});
}

1;
__END__