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


line stmt bran cond sub pod time code
1             package Search::Query::Dialect;
2 8     8   5473 use Moo;
  8         16  
  8         62  
3 8     8   2645 use Carp;
  8         17  
  8         676  
4 8     8   49 use Data::Dump qw( dump );
  8         10  
  8         821  
5             use overload
6 113     113   6145 '""' => sub { $_[0]->stringify; },
7 749     749   3024 'bool' => sub {1},
8 8     8   50 fallback => 1;
  8         11  
  8         114  
9              
10 8     8   5854 use Data::Transformer;
  8         5748  
  8         326  
11 8     8   55 use Scalar::Util qw( blessed );
  8         14  
  8         834  
12 8     8   5755 use Types::Standard qw( Int Undef );
  8         585280  
  8         112  
13 8     8   13084 use Type::Utils qw( declare as where coerce inline_as from );
  8         37335  
  8         89  
14 8     8   11368 use namespace::autoclean;
  8         103334  
  8         84  
15              
16             my $PositiveInt = declare
17             as Int,
18             where { defined($_) and $_ >= 0 },
19             inline_as {"defined($_) and $_ =~ /^[0-9]\$/ and $_ >= 0"};
20              
21             coerce $PositiveInt, from Int, q{ abs( $_ || $ENV{PERL_DEBUG} || 0) },
22             from Undef, q{ 0 };
23              
24             has default_field => ( is => 'rw' );
25             has parser => ( is => 'ro' );
26             has debug => (
27             is => 'rw',
28             isa => $PositiveInt,
29             lazy => 1,
30             coerce => $PositiveInt->coercion,
31             builder => '_init_debug',
32             );
33              
34 1 50   1   1412 sub _init_debug { $ENV{PERL_DEBUG} || 0 }
35              
36             our $VERSION = '0.305';
37              
38             =head1 NAME
39              
40             Search::Query::Dialect - abstract base class for query language dialects
41              
42             =head1 SYNOPSIS
43              
44             my $query = Search::Query->parser->parse('foo');
45             print $query;
46              
47             =head1 DESCRIPTION
48              
49             Search::Query::Dialect is the base class from which all query dialects
50             inherit.
51              
52             A Dialect subclass must implement at least two methods:
53              
54             =over
55              
56             =item stringify
57              
58             Returns the serialized query tree.
59              
60             =item stringify_clause( I )
61              
62             Returns one clause of a serialized query tree.
63              
64             =back
65              
66             See Search::Query::Dialect::Native for a working example.
67              
68             =head1 METHODS
69              
70             =head2 debug
71              
72             Get/set flag.
73              
74             =head2 default_field
75              
76             Standard attribute accessor. Default value is undef.
77              
78             =head2 init
79              
80             B. Use BUILD() instead.
81              
82             =cut
83              
84             sub init {
85 0     0 1 0 my $self = shift;
86 0         0 confess "Use BUILD() instead of init()";
87             }
88              
89             =head2 stringify
90              
91             All subclasses must override this method. The default behavior is to croak.
92              
93             =cut
94              
95 0     0 1 0 sub stringify { croak "must implement stringify() in $_[0]" }
96              
97             =head2 tree
98              
99             Returns the query Dialect instance as a hashref structure, similar
100             to that of Search::QueryParser.
101              
102             =cut
103              
104             sub tree {
105 14     14 1 13 my $self = shift;
106 14 100       54 my $clause_class
107             = $self->parser
108             ? $self->parser->clause_class
109             : 'Search::Query::Clause';
110 14         34 my $dialect_class = blessed($self);
111 14         16 my %tree;
112              
113             #warn "before tree: " . dump($self);
114 14         19 foreach my $prefix ( '+', '', '-' ) {
115 42 100       75 next if !exists $self->{$prefix};
116 15         12 my @clauses;
117 15         14 for my $clause ( @{ $self->{$prefix} } ) {
  15         21  
118              
119 28 50       60 if ( !blessed($clause) ) {
120 0         0 croak "unblessed clause in Dialect object: " . dump($clause);
121             }
122              
123 28 50       99 if ( $clause->can('tree') ) {
    100          
124              
125             #warn "clause isa Dialect: " . dump($clause);
126 0         0 push @clauses, $clause->tree;
127             }
128             elsif ( blessed( $clause->value ) ) {
129              
130             #warn "clause->value isa Dialect: " . dump($clause);
131 4         13 my $clause_ref = {%$clause};
132 4         13 $clause_ref->{value} = $clause->{value}->tree;
133 4         8 push @clauses, $clause_ref;
134             }
135             else {
136              
137             #warn "clause isa Clause: " . dump($clause);
138 24         90 push @clauses, {%$clause};
139             }
140             }
141 15         29 $tree{$prefix} = \@clauses;
142             }
143              
144             #warn "after tree: " . dump( \%tree );
145              
146 14         39 return \%tree;
147             }
148              
149             =head2 walk( I )
150              
151             Traverse a Dialect object, calling I on each Clause.
152             The I reference should expect 4 arguments:
153              
154             =over
155              
156             =item
157              
158             The Clause object.
159              
160             =item
161              
162             The Dialect object.
163              
164             =item
165              
166             The I reference.
167              
168             =item
169              
170             The prefix ("+", "-", and "") for the Clause.
171              
172             =back
173              
174             =cut
175              
176             sub walk {
177 283     283 1 322 my $self = shift;
178 283         274 my $code = shift;
179 283 50 33     1887 if ( !$code or !ref($code) or ref($code) ne 'CODE' ) {
      33        
180 0         0 croak "CODE ref required";
181             }
182 283   33     1106 my $tree = shift || $self;
183 283         501 foreach my $prefix ( '+', '', '-' ) {
184 845 100       1841 next if !exists $tree->{$prefix};
185 295         270 for my $clause ( @{ $tree->{$prefix} } ) {
  295         519  
186              
187             #warn "clause: " . dump $clause;
188 436         1146 $code->( $clause, $tree, $code, $prefix );
189             }
190             }
191 281         1065 return $tree;
192             }
193              
194             =head2 translate_to( I )
195              
196             Translate from one Dialect to another. Returns an object
197             blessed into the I class.
198              
199             =cut
200              
201             sub translate_to {
202 1     1 1 1 my $self = shift;
203 1 50       4 my $dialect = shift or croak "Dialect required";
204 1         7 my $query_class = Search::Query->get_dialect($dialect);
205 1         8 my $copy = $self->tree;
206 1         3 my $new_dialect = bless( $copy, $query_class );
207 1         5 my $clause_class = $self->parser->clause_class;
208             my $code = sub {
209 2     2   2 my ( $clause, $dialect, $sub, $prefix ) = @_;
210              
211             #warn "before: " . dump($clause);
212 2 50       6 if ( exists $clause->{field} ) {
213              
214             #warn "clause: " . dump $clause;
215 2         6 $clause = bless( $clause, $clause_class );
216             }
217             else {
218 0         0 $clause = bless( $clause, $query_class );
219 0         0 $clause->walk($sub);
220             }
221              
222             #warn "after : " . dump($clause);
223 1         5 };
224 1         4 $new_dialect->walk($code);
225 1         10 return $new_dialect;
226             }
227              
228             =head2 add_or_clause( I )
229              
230             Add I as an "or" leaf to the Dialect object.
231              
232             =cut
233              
234             sub add_or_clause {
235              
236             # DO NOT shift
237 1     1 1 3 my $self = $_[0];
238 1 50       8 my $clause = $_[1] or croak "Clause object required";
239 1         5 my $str = "($self) OR ($clause)";
240 1         8 $_[0] = $self->parser->parse($str);
241 1         32 return $_[0];
242             }
243              
244             =head2 add_and_clause( I )
245              
246             Add I as an "and" leaf to the Dialect object.
247              
248             =cut
249              
250             sub add_and_clause {
251              
252             # DO NOT shift
253 2     2 1 38 my $self = $_[0];
254 2 50       10 my $clause = $_[1] or croak "Clause object required";
255 2         9 my $str = "($self) AND ($clause)";
256 2         15 $_[0] = $self->parser->parse($str);
257 2         41 return $_[0];
258             }
259              
260             =head2 add_not_clause( I )
261              
262             Add I as a "not" leaf to the Dialect object.
263              
264             =cut
265              
266             sub add_not_clause {
267              
268             # DO NOT shift
269 1     1 1 43 my $self = $_[0];
270 1 50       5 my $clause = $_[1] or croak "Clause object required";
271 1         4 my $str = "($self) NOT ($clause)";
272 1         10 $_[0] = $self->parser->parse($str);
273 1         30 return $_[0];
274             }
275              
276             =head2 add_sub_clause( I )
277              
278             Add I as a sub clause to the Dialect object. In this
279             case, I should also be a Dialect object.
280              
281             =cut
282              
283             sub add_sub_clause {
284              
285             # DO NOT shift
286 1     1 1 3 my $self = $_[0];
287 1         2 my $self_ref = \$_[0];
288 1         3 my $clause = $_[1];
289 1 50 33     4 if ( !$clause
      33        
290             or !blessed($clause)
291             or !$clause->isa('Search::Query::Dialect') )
292             {
293 0         0 croak "Dialect object required";
294             }
295 1         7 my %methods = (
296             "" => 'add_or_clause',
297             "+" => 'add_and_clause',
298             "-" => 'add_not_clause',
299             );
300             $clause->walk(
301             sub {
302 1     1   2 my ( $subclause, $dialect, $code, $prefix ) = @_;
303 1         3 my $method = $methods{$prefix};
304 1         9 $$self_ref = $self->$method($subclause);
305             }
306 1         9 );
307              
308             }
309              
310             =head2 field_class
311              
312             Should return the name of the Field class associated with the Dialect.
313             Default is 'Search::Query::Field'.
314              
315             =cut
316              
317 10     10 1 39 sub field_class {'Search::Query::Field'}
318              
319             =head2 get_default_field
320              
321             Returns the default field for this Dialect.
322              
323             =cut
324              
325             sub get_default_field {
326 16     16 1 23 my $self = shift;
327 16         39 my $field = $self->default_field;
328 16 50       32 $field = $self->parser->default_field unless defined $field;
329 16 50       41 if ( !defined $field ) {
330 0         0 confess "must define a default_field";
331             }
332 16 50       73 return ref $field ? $field : [$field];
333             }
334              
335             =head2 get_field( I )
336              
337             Returns a Field object instance for I. The object
338             will be an instance of B.
339              
340             This is a shorthand wrapper around the method of the same
341             name in the internal B object.
342              
343             =cut
344              
345             sub get_field {
346 151     151 1 177 my $self = shift;
347 151 50       352 my $name = shift or croak "field name required";
348 151         625 my $field = $self->parser->get_field($name);
349 151 50       334 if ( !$field ) {
350 0 0       0 if ( $self->parser->croak_on_error ) {
351 0         0 confess "invalid field name: $name";
352             }
353 0         0 my $field_class = $self->field_class;
354 0         0 $field = $field_class->new( name => $name );
355             }
356 151         310 return $field;
357             }
358              
359             =head2 preprocess( I )
360              
361             Called by Parser in parse() before actually building the Dialect object
362             from I.
363              
364             This allows for any "cleaning up" or other munging of I
365             to support the official Parser syntax.
366              
367             The default just returns I untouched. Subclasses should
368             return a parseable string.
369              
370             =cut
371              
372 82     82 1 186 sub preprocess { return $_[1] }
373              
374             =head2 parser
375              
376             Returns the Search::Query::Parser object that generated the Dialect
377             object.
378              
379             =cut
380              
381             1;
382              
383             __END__