File Coverage

blib/lib/Lingua/Awkwords/Parser.pm

Criterion	Covered	Total	%
statement	97	99	97.9
branch	29	30	96.6
condition			n/a
subroutine	21	21	100.0
pod	1	1	100.0
total	148	151	98.0

# -*- Perl -*-
#
# Parser::MGC subclass that parses awkword patterns into a data structure

package Lingua::Awkwords::Parser;

use strict;
use warnings;

use parent qw( Parser::MGC );

use Lingua::Awkwords::ListOf;
use Lingua::Awkwords::OneOf;
use Lingua::Awkwords::String;
use Lingua::Awkwords::Subpattern;

our $VERSION = '0.10';

sub parse {
    my $self = shift;
    my $unit = $self->_parse_unit;

    my $filters =
      $self->sequence_of(sub { $self->expect('^'); $self->_parse_filter });
    $unit->add_filters(@$filters) if @$filters;

    return $unit;
}

# filters exclude strings from previous units
sub _parse_filter {
    my $self = shift;

    my $filter = '';

    1 while $self->any_of(
        # NOTE code for these duplicted from the unit parse
        sub {
            $filter .= ($self->expect(qr/"([^"]*)"/))[-1];
            1;
        },
        sub {
            $filter .= $self->generic_token('other', qr{[^ "A-Z\(\)\[\]/\*\^]+});
            1;
        },
        sub {
            0;
        }
    );

    return $filter;
}

# units, which might be a ::ListOf choices [VV] or ::OneOf [a/b] or both
# [VV/CV] or neither [asdf]. units can also contain other units
sub _parse_unit {
    my $self = shift;

    my ($oneof, $weight);
    my @terms = '';

    1 while $self->any_of(
        sub {
            $self->expect('*');

            # NOTE original version instead treats [a*10*20/b] as a
            # weight of 1020 then reduces that to 128 (with a warning)
            # as of 0.06 upper limit removed from this implementation
            $self->fail("weight already set") if $weight;

            my $num = $self->token_int;
            $self->fail("weight must be positive integer") if $num < 1;
            $weight = $num;
            1;
        },
        sub {
            $self->expect('/');

            $oneof = Lingua::Awkwords::OneOf->new if !defined $oneof;

            for my $term (@terms) {
                # TODO cache these strings so only one obj instance per str?
                $term = Lingua::Awkwords::String->new(string => $term) if !ref $term;
            }
            $oneof->add_choice(Lingua::Awkwords::ListOf->new(terms => [@terms]), $weight);

            # empty string here is so [a/] parses correctly as a choice
            # between a and nothing instead of dropping out of the unit
            # upon ]
            undef $weight;
            @terms = '';
            1;
        },
        sub {
            # recurse into sub-units [...] or (...)
            my $delim = $self->expect(qr/[ \[\( ]/x);
            $delim =~ tr/[(/])/;

            my $ret = $self->scope_of(undef, \&_parse_unit, $delim);
            if ($terms[-1] eq '') {
                $terms[-1] = $ret;
            } else {
                push @terms, $ret;
            }

            # () needs additional code as (a) is equivalent to [a/] so
            # we must add an empty string to what must become a oneof
            if ($delim eq ')') {
                my $newof;
                unless ($terms[-1]->can('add_choice')) {
                    $newof = Lingua::Awkwords::OneOf->new;
                    $newof->add_choice($terms[-1]);
                    $terms[-1] = $newof;
                } else {
                    $newof = $terms[-1];
                }

                # TODO cache this string in a hash so only one obj?
                $newof->add_choice(Lingua::Awkwords::String->new(string => ''));
            }

            # filters in [VV]^aa form (as opposed to the top-level
            # parse() VV^aa form which lack the trailing ] or ) of this
            # code path
            $self->maybe(
                sub {
                    my $filters =
                      $self->sequence_of(sub { $self->expect('^'); $self->_parse_filter });
                    $terms[-1]->add_filters(@$filters) if @$filters;
                }
            );
            1;
        },
        sub {
            my $pat = $self->generic_token('subpattern', qr{[A-Z]});
            $self->fail("not a defined pattern")
              if !Lingua::Awkwords::Subpattern->is_pattern($pat);

            my $ret = Lingua::Awkwords::Subpattern->new(pattern => $pat);
            if ($terms[-1] eq '') {
                $terms[-1] = $ret;
            } else {
                push @terms, $ret;
            }
            1;
        },
        # NOTE code from these two also used in _parse_filter
        sub {
            my $ret = ($self->expect(qr/"([^"]*)"/))[-1];
            if (ref $terms[-1]) {
                push @terms, $ret;
            } else {
                $terms[-1] .= $ret;
            }
            1;
        },
        sub {
            my $ret = $self->generic_token('other', qr{[^ "A-Z\(\)\[\]/\*\^]+});
            if (ref $terms[-1]) {
                push @terms, $ret;
            } else {
                $terms[-1] .= $ret;
            }
            1;
        },
        sub {
            0;
        }
    );

    for my $term (@terms) {
        # TODO cache these strings so only one obj instance per str?
        $term = Lingua::Awkwords::String->new(string => $term) if !ref $term;
    }

    if (defined $oneof) {
        $oneof->add_choice(Lingua::Awkwords::ListOf->new(terms => [@terms]), $weight);
        return $oneof;
    } else {
        return Lingua::Awkwords::ListOf->new(terms => \@terms);
    }
}

1;
__END__