File Coverage

blib/lib/Search/Query/Dialect.pm

Criterion	Covered	Total	%
statement	105	119	88.2
branch	23	40	57.5
condition	5	15	33.3
subroutine	25	27	92.5
pod	13	13	100.0
total	171	214	79.9

package Search::Query::Dialect;
use Moo;
use Carp;
use Data::Dump qw( dump );
use overload
    '""'     => sub { $_[0]->stringify; },
    'bool'   => sub {1},
    fallback => 1;

use Data::Transformer;
use Scalar::Util qw( blessed );
use Types::Standard qw( Int Undef );
use Type::Utils qw( declare as where coerce inline_as from );
use namespace::autoclean;

my $PositiveInt = declare
    as Int,
    where { defined($_) and $_ >= 0 },
    inline_as {"defined($_) and $_ =~ /^[0-9]\$/ and $_ >= 0"};

coerce $PositiveInt, from Int, q{ abs( $_ || $ENV{PERL_DEBUG} || 0) },
    from Undef, q{ 0 };

has default_field => ( is => 'rw' );
has parser        => ( is => 'ro' );
has debug         => (
    is      => 'rw',
    isa     => $PositiveInt,
    lazy    => 1,
    coerce  => $PositiveInt->coercion,
    builder => '_init_debug',
);

sub _init_debug { $ENV{PERL_DEBUG} || 0 }

our $VERSION = '0.305';

=head1 NAME

Search::Query::Dialect - abstract base class for query language dialects

=head1 SYNOPSIS

 my $query = Search::Query->parser->parse('foo');
 print $query;

=head1 DESCRIPTION

Search::Query::Dialect is the base class from which all query dialects
inherit.

A Dialect subclass must implement at least two methods:

=over

=item stringify

Returns the serialized query tree.

=item stringify_clause( I )

Returns one clause of a serialized query tree.

=back

See Search::Query::Dialect::Native for a working example.

=head1 METHODS

=head2 debug

Get/set flag.

=head2 default_field

Standard attribute accessor. Default value is undef.

=head2 init

B. Use BUILD() instead.

=cut

sub init {
    my $self = shift;
    confess "Use BUILD() instead of init()";
}

=head2 stringify

All subclasses must override this method. The default behavior is to croak.

=cut

sub stringify { croak "must implement stringify() in $_[0]" }

=head2 tree

Returns the query Dialect instance as a hashref structure, similar
to that of Search::QueryParser.

=cut

sub tree {
    my $self = shift;
    my $clause_class
        = $self->parser
        ? $self->parser->clause_class
        : 'Search::Query::Clause';
    my $dialect_class = blessed($self);
    my %tree;

    #warn "before tree: " . dump($self);
    foreach my $prefix ( '+', '', '-' ) {
        next if !exists $self->{$prefix};
        my @clauses;
        for my $clause ( @{ $self->{$prefix} } ) {

            if ( !blessed($clause) ) {
                croak "unblessed clause in Dialect object: " . dump($clause);
            }

            if ( $clause->can('tree') ) {

                #warn "clause isa Dialect: " . dump($clause);
                push @clauses, $clause->tree;
            }
            elsif ( blessed( $clause->value ) ) {

                #warn "clause->value isa Dialect: " . dump($clause);
                my $clause_ref = {%$clause};
                $clause_ref->{value} = $clause->{value}->tree;
                push @clauses, $clause_ref;
            }
            else {

                #warn "clause isa Clause: " . dump($clause);
                push @clauses, {%$clause};
            }
        }
        $tree{$prefix} = \@clauses;
    }

    #warn "after tree: " . dump( \%tree );

    return \%tree;
}

=head2 walk( I )

Traverse a Dialect object, calling I on each Clause.
The I reference should expect 4 arguments:

=over

=item

The Clause object.

=item

The Dialect object.

=item

The I reference.

=item

The prefix ("+", "-", and "") for the Clause.

=back

=cut

sub walk {
    my $self = shift;
    my $code = shift;
    if ( !$code or !ref($code) or ref($code) ne 'CODE' ) {
        croak "CODE ref required";
    }
    my $tree = shift || $self;
    foreach my $prefix ( '+', '', '-' ) {
        next if !exists $tree->{$prefix};
        for my $clause ( @{ $tree->{$prefix} } ) {

            #warn "clause: " . dump $clause;
            $code->( $clause, $tree, $code, $prefix );
        }
    }
    return $tree;
}

=head2 translate_to( I )

Translate from one Dialect to another. Returns an object
blessed into the I class.

=cut

sub translate_to {
    my $self         = shift;
    my $dialect      = shift or croak "Dialect required";
    my $query_class  = Search::Query->get_dialect($dialect);
    my $copy         = $self->tree;
    my $new_dialect  = bless( $copy, $query_class );
    my $clause_class = $self->parser->clause_class;
    my $code         = sub {
        my ( $clause, $dialect, $sub, $prefix ) = @_;

        #warn "before: " . dump($clause);
        if ( exists $clause->{field} ) {

            #warn "clause: " . dump $clause;
            $clause = bless( $clause, $clause_class );
        }
        else {
            $clause = bless( $clause, $query_class );
            $clause->walk($sub);
        }

        #warn "after : " . dump($clause);
    };
    $new_dialect->walk($code);
    return $new_dialect;
}

=head2 add_or_clause( I )

Add I as an "or" leaf to the Dialect object.

=cut

sub add_or_clause {

    # DO NOT shift
    my $self   = $_[0];
    my $clause = $_[1] or croak "Clause object required";
    my $str    = "($self) OR ($clause)";
    $_[0] = $self->parser->parse($str);
    return $_[0];
}

=head2 add_and_clause( I )

Add I as an "and" leaf to the Dialect object.

=cut

sub add_and_clause {

    # DO NOT shift
    my $self   = $_[0];
    my $clause = $_[1] or croak "Clause object required";
    my $str    = "($self) AND ($clause)";
    $_[0] = $self->parser->parse($str);
    return $_[0];
}

=head2 add_not_clause( I )

Add I as a "not" leaf to the Dialect object.

=cut

sub add_not_clause {

    # DO NOT shift
    my $self   = $_[0];
    my $clause = $_[1] or croak "Clause object required";
    my $str    = "($self) NOT ($clause)";
    $_[0] = $self->parser->parse($str);
    return $_[0];
}

=head2 add_sub_clause( I )

Add I as a sub clause to the Dialect object. In this
case, I should also be a Dialect object.

=cut

sub add_sub_clause {

    # DO NOT shift
    my $self     = $_[0];
    my $self_ref = \$_[0];
    my $clause   = $_[1];
    if (   !$clause
        or !blessed($clause)
        or !$clause->isa('Search::Query::Dialect') )
    {
        croak "Dialect object required";
    }
    my %methods = (
        ""  => 'add_or_clause',
        "+" => 'add_and_clause',
        "-" => 'add_not_clause',
    );
    $clause->walk(
        sub {
            my ( $subclause, $dialect, $code, $prefix ) = @_;
            my $method = $methods{$prefix};
            $$self_ref = $self->$method($subclause);
        }
    );

}

=head2 field_class

Should return the name of the Field class associated with the Dialect.
Default is 'Search::Query::Field'.

=cut

sub field_class {'Search::Query::Field'}

=head2 get_default_field

Returns the default field for this Dialect.

=cut

sub get_default_field {
    my $self  = shift;
    my $field = $self->default_field;
    $field = $self->parser->default_field unless defined $field;
    if ( !defined $field ) {
        confess "must define a default_field";
    }
    return ref $field ? $field : [$field];
}

=head2 get_field( I )

Returns a Field object instance for I. The object
will be an instance of B.

This is a shorthand wrapper around the method of the same
name in the internal B object.

=cut

sub get_field {
    my $self  = shift;
    my $name  = shift or croak "field name required";
    my $field = $self->parser->get_field($name);
    if ( !$field ) {
        if ( $self->parser->croak_on_error ) {
            confess "invalid field name: $name";
        }
        my $field_class = $self->field_class;
        $field = $field_class->new( name => $name );
    }
    return $field;
}

=head2 preprocess( I )

Called by Parser in parse() before actually building the Dialect object
from I.

This allows for any "cleaning up" or other munging of I
to support the official Parser syntax.

The default just returns I untouched. Subclasses should
return a parseable string.

=cut

sub preprocess { return $_[1] }

=head2 parser

Returns the Search::Query::Parser object that generated the Dialect
object.

=cut

1;

__END__