File Coverage

blib/lib/Search/Elasticsearch/Compat/QueryParser.pm

Criterion	Covered	Total	%
statement	237	247	95.9
branch	153	160	95.6
condition	52	63	82.5
subroutine	28	29	96.5
pod	3	3	100.0
total	473	502	94.2

package Search::Elasticsearch::Compat::QueryParser;
$Search::Elasticsearch::Compat::QueryParser::VERSION = '0.10';
use strict;
use warnings FATAL => 'all';
use Search::Elasticsearch::Util qw(parse_params throw);
use Scalar::Util qw(weaken);
@Search::Elasticsearch::Error::QueryParser::ISA
    = 'Search::Elasticsearch::Error';

# ABSTRACT: Check or filter query strings


#===================================
sub new {
#===================================
    my ( $proto, $params ) = parse_params(@_);
    my $class = ref $proto || $proto;
    $params = {
        escape_reserved => 0,
        fields          => 0,
        wildcard_prefix => 1,
        allow_bool      => 1,
        allow_boost     => 1,
        allow_fuzzy     => 1,
        allow_slop      => 1,
        allow_ranges    => 0,
        %$params,
    };
    return bless {
        _default_opts => $params,
        _opts         => $params,
    }, $class;
}

#===================================
sub filter {
#===================================
    my $self = shift;
    my $text = shift;
    my ( undef, $opts ) = parse_params( $self, @_ );
    $opts->{fix} = 1;
    return $self->_parse( $text, $opts );
}

#===================================
sub check {
#===================================
    my $self = shift;
    my $text = shift;
    my ( undef, $opts ) = parse_params( $self, @_ );
    $opts->{fix} = 0;
    return $self->_parse( $text, $opts );
}

#===================================
sub _parse {
#===================================
    my $self = shift;
    my $text = shift;
    $text = '' unless defined $text;
    utf8::upgrade($text);

    my $opts = shift;
    $self->{_opts} = { %{ $self->{_default_opts} }, %$opts };

    $self->{_tokeniser} = $self->_init_tokeniser($text);
    $self->{_tokens}    = [];
    $self->{_stack}     = [ {} ];
    $self->{_start_pos} = 0;
    $self->{_done}      = 0;

    my $phrase;
    eval {
        $phrase = $self->_multi_clauses;
        die "Syntax error\n"
            unless $self->{_done} || $opts->{fix};
    };
    if ($@) {
        $@ =~ s/\n$/:\n/;
        substr( $text, $self->{_start_pos}, 0, '  ' );
        throw( 'QueryParser', "$@$text" );
    }
    return $phrase;
}

#===================================
sub _dump_tokens {
#===================================
    my $self = shift;
    my $text = shift;
    $text = '' unless defined $text;
    utf8::upgrade($text);

    my $tokeniser = $self->_init_tokeniser($text);

    while ( my $next = $tokeniser->() ) {
        printf "TOKEN: %-15s VARS: %s\n", shift @$next,
            join( ', ', grep { defined $_ } @$next );
    }
}

#===================================
sub _next_token {
#===================================
    my $self = shift;
    my $next = shift @{ $self->{_tokens} }
        || $self->{_tokeniser}->();
    return $next if $next;
    $self->{_done} = 1;
    return;
}

#===================================
sub _return_token {
#===================================
    my $self = shift;
    push @{ $self->{_tokens} }, shift;
    $self->{_done} = 0;
}

# 1     = Can follow
# 0     = Cannot follow, drop token and try next token
# undef = Cannot follow, stop looking

my %Clauses = (
    _LPAREN     => 1,
    _PLUS_MINUS => 1,
    _EXISTS     => 1,
    _FIELD      => 1,
    _TERM       => 1,
    _PHRASE     => 1,
    _WILDTERM   => 1,
    _RANGE      => 1,
    _NOT        => 1,
    _AND_OR     => 1,
    _SPACE      => 1,
    _RESERVED   => 1,
    _ESCAPE     => 1,
);

my %Boost = ( _BOOST => 1 );

my %Allowed = (
    _CLAUSE     => \%Clauses,
    _LPAREN     => { %Clauses, _RPAREN => 1 },
    _AND_OR     => { %Clauses, _AND_OR => 0 },
    _NOT        => { %Clauses, _NOT => 0, _AND_OR => 0 },
    _PLUS_MINUS => {
        %Clauses,
        _NOT        => 0,
        _AND_OR     => 0,
        _PLUS_MINUS => 0,
        _SPACE      => undef,
    },
    _FIELD => {
        _LPAREN   => 1,
        _TERM     => 1,
        _WILDTERM => 1,
        _PHRASE   => 1,
        _RANGE    => 1,
    },
    _PHRASE   => { _BOOST => 1, _FUZZY => 1 },
    _TERM     => { _BOOST => 1, _FUZZY => 1 },
    _WILDTERM => \%Boost,
    _RANGE    => \%Boost,
    _FUZZY    => \%Boost,
    _RPAREN   => \%Boost,
    _EXISTS   => \%Boost,
    _BOOST    => {},
    _SPACE    => {},
    _RESERVED => {},
    _ESCAPE   => {},
);

#===================================
sub _parse_context {
#===================================
    my $self    = shift;
    my $context = shift;
    my $allowed = $Allowed{$context};

TOKEN: {
        my $token = $self->_next_token or return;

        my ( $type, @args ) = @$token;
        if ( $allowed->{$type} ) {
            redo TOKEN if $type eq '_SPACE';
            return $self->$type(@args);
        }
        elsif ( defined $allowed->{$type} ) {
            die "Syntax error\n" unless $self->{_opts}{fix};
            redo TOKEN;
        }
        else {
            $self->_return_token($token);
            return undef;
        }
    }
}

#===================================
sub _multi_clauses {
#===================================
    my $self = shift;
    my @clauses;
    while (1) {
        my $clause = $self->_parse_context('_CLAUSE');
        if ( !defined $clause ) {
            last
                if @{ $self->{_stack} } > 1
                || !$self->{_opts}{fix}
                || $self->{_done};
            $self->_next_token;
            next;
        }
        next unless length $clause;
        push @clauses, $clause;
        $self->{_stack}[-1]{clauses}++;
    }
    return join( ' ', @clauses );
}

#===================================
sub _AND_OR {
#===================================
    my $self = shift;
    my $op   = shift;
    my $opts = $self->{_opts};

    unless ( $self->{_stack}[-1]{clauses} ) {
        return '' if $opts->{fix};
        die "$op must be preceded by another clause\n";
    }
    unless ( $opts->{allow_bool} ) {
        die qq("$op" not allowed) unless $opts->{fix};
        return '';
    }

    my $next = $self->_parse_context('_AND_OR');
    return "$op $next"
        if defined $next && length $next;

    return '' if $opts->{fix};
    die "$op must be followed by a clause\n";
}

#===================================
sub _NOT {
#===================================
    my $self = shift;
    my $op   = shift;

    my $opts = $self->{_opts};
    unless ( $opts->{allow_bool} ) {
        die qq("$op" not allowed) unless $opts->{fix};
        return '';
    }

    my $next = $self->_parse_context('_NOT');
    $next = '' unless defined $next;

    die "$op cannot be followed by + or -"
        if $next =~ s/^[+-]+// && !$opts->{fix};

    return "$op $next"
        if length $next;

    return '' if $opts->{fix};
    die "$op must be followed by a clause\n";
}

#===================================
sub _PLUS_MINUS {
#===================================
    my $self = shift;
    my $op   = shift;
    my $next = $self->_parse_context('_PLUS_MINUS');

    return "$op$next" if defined $next && length $next;

    return '' if $self->{_opts}{fix};
    die "$op must be followed by a clause";
}

#===================================
sub _LPAREN {
#===================================
    my $self = shift;
    push @{ $self->{_stack} }, {};
    my $clause = $self->_multi_clauses;

    my $close  = ')';
    my $rparen = $self->_next_token;
    if ( $rparen && $rparen->[0] eq '_RPAREN' ) {
        my $next = $self->_parse_context('_RPAREN') || '';
        $close .= $next if $next;
        pop @{ $self->{_stack} };
    }
    elsif ( $self->{_opts}{fix} ) {
        $self->_return_token($rparen);
    }
    else {
        die "Missing closing parenthesis\n";
    }
    return $clause ? "(${clause}${close}" : '';
}

#===================================
sub _BOOST {
#===================================
    my $self = shift;
    unless ( $self->{_opts}{allow_boost} ) {
        die "Boost not allowed" unless $self->{_opts}{fix};
        return '';
    }
    my $val = shift;
    unless ( defined $val && length $val ) {
        return '' if $self->{_opts}{fix};
        die "Missing boost value\n";
    }
    return "^$val";
}

#===================================
sub _FUZZY {
#===================================
    my $self  = shift;
    my $fuzzy = shift;
    my $opts  = $self->{_opts};
    my $fix   = $opts->{fix};

    if ( $self->{current} eq '_PHRASE' ) {

        # phrase slop
        if ( $opts->{allow_slop} ) {
            $fuzzy = int( $fuzzy || 0 );
            $fuzzy = $fuzzy ? "~$fuzzy" : '';
        }
        else {
            die "Phrase slop not allowed\n" unless $fix;
            $fuzzy = '';
        }
    }
    else {

        # fuzzy
        if ( $opts->{allow_fuzzy} ) {
            if ( defined $fuzzy ) {
                if ( $fuzzy <= 1 ) {
                    $fuzzy = "~$fuzzy";
                }
                else {
                    die "Fuzzy value must be between 0.0 and 1.0\n"
                        unless $fix;
                    $fuzzy = '';
                }
            }
            else {
                $fuzzy = '~';
            }
        }
        else {
            die "Fuzzy not allowed\n"
                unless $fix;
            $fuzzy = '';
        }
    }

    my $next = $self->_parse_context('_FUZZY') || '';
    return "$fuzzy$next";
}

#===================================
sub _PHRASE {
#===================================
    my $self   = shift;
    my $string = shift;

    local $self->{current} = '_PHRASE';
    my $next = $self->_parse_context('_PHRASE') || '';

    return qq("$string"$next);
}

#===================================
sub _EXISTS {
#===================================
    my $self   = shift;
    my $prefix = shift;
    my $field  = shift;

    my $opts = $self->{_opts};
    my $next = $self->_parse_context('_EXISTS') || '';
    unless ( $opts->{fields}
        and ( !ref $opts->{fields} || $opts->{fields}{$field} ) )
    {
        return '' if $opts->{fix};
        die qq("Field "$field" not allowed);
    }

    return "$prefix:$field$next"
        if $field;
    return '' if $self->{_opts}{fix};
    die "Missing field name for $prefix\n";
}

#===================================
sub _FIELD {
#===================================
    my $self  = shift;
    my $field = shift;

    my $opts = $self->{_opts};
    my $next = $self->_parse_context('_FIELD');

    unless ( defined $next && length $next ) {
        die "Missing clause after field $field\n"
            unless $opts->{fix};
        return '';
    }

    return "$field:$next"
        if $opts->{fields}
        and !ref $opts->{fields} || $opts->{fields}{$field};

    die qq("Field "$field" not allowed)
        unless $opts->{fix};

    return $next;
}

#===================================
sub _TERM {
#===================================
    my $self = shift;
    local $self->{current} = '_TERM';
    my $next = $self->_parse_context('_TERM') || '';
    return shift(@_) . $next;
}

#===================================
sub _WILDTERM {
#===================================
    my $self = shift;
    my $term = shift;
    my $min  = $self->{_opts}{wildcard_prefix};
    my $next = $self->_parse_context('_WILDTERM') || '';
    if ( $term !~ /^[^*?]{$min}/ ) {
        die "Wildcard cannot have * or ? "
            . (
            $min == 1 ? 'as first character' : "in first $min characters" )
            unless $self->{_opts}{fix};
        $term =~ s/[*?].*//;
        return '' unless length $term;
    }
    return "$term$next";
}

#===================================
sub _RANGE {
#===================================
    my $self = shift;
    my ( $open, $close, $from, $to ) = @_;
    my $opts = $self->{_opts};
    my $next = $self->_parse_context('_RANGE') || '';
    unless ( $opts->{allow_ranges} ) {
        die "Ranges not allowed\n"
            unless $opts->{fix};
        return '';
    }
    unless ( defined $to ) {
        die "Malformed range\n" unless $opts->{fix};
        return '';
    }
    return "$open$from TO $to$close$next";
}

#===================================
sub _RESERVED {
#===================================
    my $self = shift;
    my $char = shift;
    die "Reserved character $char\n"
        unless $self->{_opts}{fix};
    return $self->{_opts}{escape_reserved}
        ? "\\$char"
        : '';
}

#===================================
sub _ESCAPE {
#===================================
    my $self = shift;
    die qq(Cannot end with "\\"\n)
        unless $self->{_opts}{fix};
    return '';
}

my $DECIMAL  = qr/[0-9]+(?:[.][0-9]+)?/;
my $NUM_CHAR = qr/[0-9]/;
my $ESC_CHAR = qr/\\./;
my $WS       = qr/[ \t\n\r\x{3000}]/;
my $TERM_START_CHAR
    = qr/[^ \t\n\r\x{3000}+\-!():^[\]"{}~*?\\&|] | $ESC_CHAR/x;
my $TERM_CHAR   = qr/$TERM_START_CHAR |$ESC_CHAR | [-+]/x;
my $QUOTE_RANGE = qr/(?: " (?: \\" | [^"] )* ")/x;
my $RANGE_SEP   = qr/ \s+ (?: TO \s+)?/x;

#===================================
sub _init_tokeniser {
#===================================
    my $self = shift;
    my $text = shift;

    my $weak_self = $self;
    Scalar::Util::weaken($weak_self);
    return sub {
    TOKEN: {
            $weak_self->{_start_pos} = pos($text) || 0;
            return ['_SPACE']
                if $text =~ m/\G$WS/gc;
            return [ '_AND_OR', $1 ]
                if $text =~ m/\G(AND\b | && | OR\b | \|{2})/gcx;
            return [ '_NOT', $1 ]
                if $text =~ m/\G(NOT\b | !)/gcx;
            return [ '_PLUS_MINUS', $1 ]
                if $text =~ m/\G([-+])/gc;
            return ['_LPAREN']
                if $text =~ m/\G[(]/gc;
            return ['_RPAREN']
                if $text =~ m/\G[)]/gc;
            return [ '_BOOST', $1 ]
                if $text =~ m/\G\^($DECIMAL)?/gc;
            return [ '_FUZZY', $1 ]
                if $text =~ m/\G[~]($DECIMAL)?/gc;
            return [ '_PHRASE', $1, $2 ]
                if $text =~ m/\G " ( (?: $ESC_CHAR | [^"\\])*) "/gcx;
            return [ '_EXISTS', $1, $2 ]
                if $text =~ m/\G
                                (_exists_|_missing_):
                                ((?:$TERM_START_CHAR $TERM_CHAR*)?)
                            /gcx;
            return [ '_FIELD', $1 ]
                if $text =~ m/\G ($TERM_START_CHAR $TERM_CHAR*):/gcx;
            return [ '_TERM', $1 ]
                if $text =~ m/\G
                                ( $TERM_START_CHAR $TERM_CHAR*)
                                (?!$TERM_CHAR | [*?])
                            /gcx;
            return [ '_WILDTERM', $1 ]
                if $text =~ m/\G (
                                    (?:$TERM_START_CHAR | [*?])
                                    (?:$TERM_CHAR | [*?])*
                            )/gcx;
            return [ '_RANGE', '[', ']', $1, $2 ]
                if $text =~ m/\G \[
                                ( $QUOTE_RANGE | [^ \]]+ )
                                (?: $RANGE_SEP
                                    ( $QUOTE_RANGE | [^ \]]* )
                                )?
                            \]
                            /gcx;
            return [ '_RANGE', '{', '}', $1, $2 ]
                if $text =~ m/\G \{
                                ( $QUOTE_RANGE | [^ }]+ )
                                (?:
                                    $RANGE_SEP
                                    ( $QUOTE_RANGE | [^ }]* )
                                )?
                            \}
                            /gcx;

            return [ '_RESERVED', $1 ]
                if $text =~ m/\G ( ["&|!(){}[\]~^:+\-] )/gcx;

            return ['_ESCAPE']
                if $text =~ m/\G\\$/gc;
        }
        return;

    };
}

1;

__END__