File Coverage

blib/lib/Search/Query/Dialect/SQL.pm
Criterion Covered Total %
statement 96 105 91.4
branch 57 70 81.4
condition 18 28 64.2
subroutine 10 10 100.0
pod 4 4 100.0
total 185 217 85.2


line stmt bran cond sub pod time code
1             package Search::Query::Dialect::SQL;
2 2     2   9 use Moo;
  2         4  
  2         14  
3             extends 'Search::Query::Dialect';
4 2     2   646 use Carp;
  2         3  
  2         130  
5 2     2   8 use Data::Dump qw( dump );
  2         13  
  2         95  
6 2     2   813 use Search::Query::Field::SQL;
  2         4  
  2         63  
7              
8 2     2   12 use namespace::autoclean;
  2         2  
  2         8  
9              
10             has 'wildcard' => ( is => 'rw', default => sub {'%'} );
11             has 'quote_fields' => ( is => 'rw', default => sub {''} );
12             has 'fuzzify' => ( is => 'rw' );
13             has 'fuzzify2' => ( is => 'rw' );
14             has 'like' => ( is => 'rw', default => sub {'ILIKE'}, );
15             has 'quote_char' => ( is => 'rw', default => sub {q/'/}, );
16             has 'fuzzy_space' => ( is => 'rw', default => sub {' '}, );
17              
18             our $VERSION = '0.305';
19              
20             =head1 NAME
21              
22             Search::Query::Dialect::SQL - SQL query dialect
23              
24             =head1 SYNOPSIS
25              
26             my $query = Search::Query->parser( dialect => 'SQL' )->parse('foo');
27             print $query;
28              
29             =head1 DESCRIPTION
30              
31             Search::Query::Dialect::SQL is a query dialect for Query
32             objects returned by a Search::Query::Parser instance.
33              
34             The SQL dialect class stringifies queries to work as SQL WHERE
35             clauses. This behavior is similar to Search::QueryParser::SQL.
36              
37             =head1 METHODS
38              
39             This class is a subclass of Search::Query::Dialect. Only new or overridden
40             methods are documented here.
41              
42             =cut
43              
44             =head2 BUILD
45              
46             Called by new(). The new() constructor can accept the following params, which
47             are also standard attribute accessors:
48              
49             =over
50              
51             =item wildcard
52              
53             Default value is C<%>.
54              
55             =item quote_fields
56              
57             Default value is "". Set to (for example) C<`> to quote each field name
58             in stringify() as some SQL variants require that syntax (e.g. mysql).
59              
60             =item default_field
61              
62             Override the default field set in Search::Query::Parser.
63              
64             =item fuzzify
65              
66             Append wildcard() to all terms.
67              
68             =item fuzzify2
69              
70             Prepend and append wildcard() to all terms.
71              
72             =item like
73              
74             The SQL reserved word for wildcard comparison. Default value is C.
75              
76             =item quote_char
77              
78             The string to use for quoting strings. Default is C<'>.
79              
80             =item fuzzy_space
81              
82             The string to use to pad fuzzified terms. Default is a single space C< >.
83              
84             =back
85              
86             =cut
87              
88             sub BUILD {
89 43     43 1 336 my $self = shift;
90              
91             #carp dump $self;
92 43 50       234 if ( !defined $self->parser->fields ) {
93 0         0 croak "You must set fields in the Search::Query::Parser";
94             }
95             $self->{default_field} ||= $self->parser->default_field
96 43   100     334 || [ sort keys %{ $self->parser->fields } ];
      66        
97 43 100 66     269 if ( $self->{default_field} and !ref( $self->{default_field} ) ) {
98 22         68 $self->{default_field} = [ $self->{default_field} ];
99             }
100 43         1166 return $self;
101             }
102              
103             =head2 stringify
104              
105             Returns the Query object as a normalized string.
106              
107             =cut
108              
109             my %op_map = (
110             '+' => 'AND',
111             '' => 'OR',
112             '-' => 'AND', # operator is munged
113             );
114              
115             sub stringify {
116 34     34 1 60 my $self = shift;
117 34   66     169 my $tree = shift || $self;
118              
119 34         59 my @q;
120 34         75 foreach my $prefix ( '+', '', '-' ) {
121 102         133 my @clauses;
122 102         186 my $joiner = $op_map{$prefix};
123 102 100       293 next unless exists $tree->{$prefix};
124 36         44 for my $clause ( @{ $tree->{$prefix} } ) {
  36         81  
125 46         158 push( @clauses, $self->stringify_clause( $clause, $prefix ) );
126             }
127 36 50       87 next if !@clauses;
128              
129 36 50       93 push @q, join( " $joiner ", grep { defined and length } @clauses );
  46         263  
130             }
131              
132 34         440 return join " AND ", @q;
133             }
134              
135             sub _doctor_value {
136 41     41   56 my ( $self, $clause ) = @_;
137              
138 41         80 my $value = $clause->{value};
139              
140 41 100       94 return $value unless defined $value;
141              
142 39 100       159 if ( $self->fuzzify ) {
    100          
143 6 100       28 $value .= '*' unless $value =~ m/[\*\%]/;
144             }
145             elsif ( $self->fuzzify2 ) {
146 2 50       11 $value = "*$value*" unless $value =~ m/[\*\%]/;
147             }
148              
149             # normalize wildcard
150 39         169 my $wildcard = $self->wildcard;
151 39         113 $value =~ s/\*/$wildcard/g;
152              
153 39         108 return $value;
154             }
155              
156             =head2 stringify_clause( I, I )
157              
158             Called by stringify() to handle each Clause in the Query tree.
159              
160             =cut
161              
162             sub stringify_clause {
163 46     46 1 62 my $self = shift;
164 46         59 my $clause = shift;
165 46         55 my $prefix = shift;
166              
167 46 100       198 if ( $clause->{op} eq '()' ) {
168 5 100 66     26 if ( $clause->has_children and $clause->has_children == 1 ) {
169              
170             # muck about in the internals because SQL relies on the operator,
171             # not the prefix, to indicate the "NOT"-ness of a clause.
172 2 50 33     23 if ( $prefix eq '-' and exists $clause->{value}->{'+'} ) {
173 0         0 $clause->{value}->{'-'} = delete $clause->{value}->{'+'};
174             }
175 2         12 return '(' . $self->stringify( $clause->{value} ) . ')';
176             }
177             else {
178             return
179 3 50       24 ( $prefix eq '-' ? 'NOT ' : '' ) . "("
180             . $self->stringify( $clause->{value} ) . ")";
181             }
182             }
183              
184             # optional
185 41         114 my $quote_fields = $self->quote_fields;
186 41         90 my $fuzzy_space = $self->fuzzy_space;
187              
188             # TODO proximity - anything special and SQL-specific?
189              
190             # make sure we have a field
191             my @fields
192 8         42 = $clause->{field}
193             ? ( $clause->{field} )
194 41 100       153 : ( @{ $self->get_default_field } );
195              
196             # what value
197 41         112 my $value = $self->_doctor_value($clause);
198              
199             # normalize operator
200 41   100     139 my $op = $clause->{op} || "=";
201 41 100       96 if ( $op eq ':' ) {
202 18         29 $op = '=';
203             }
204 41 100       87 if ( $prefix eq '-' ) {
205 4         10 $op = '!' . $op;
206             }
207 41 100 100     222 if ( defined $value and $value =~ m/\%/ ) {
208 8 50       15 $op = $prefix eq '-' ? '!~' : '~';
209             }
210              
211 41         52 my @buf;
212 41         69 NAME: for my $name (@fields) {
213 55         1836 my $field = $self->get_field($name);
214 55 100       151 $value =~ s/\%//g if $field->is_int;
215 55         69 my $this_op;
216              
217             # whether we quote depends on the field (column) type
218 55 100       171 my $quote = $field->is_int ? "" : $self->quote_char;
219              
220             #warn dump [ $prefix, $field, $value, $op, $quote ];
221              
222             # range
223 55 100       278 if ( $op eq '..' ) {
    100          
    100          
    100          
224 2 50 33     18 if ( ref $value ne 'ARRAY' or @$value != 2 ) {
225 0         0 croak "range of values must be a 2-element ARRAY";
226             }
227              
228 2         12 my @range = ( $value->[0] .. $value->[1] );
229 10         28 push(
230             @buf,
231             join( '',
232             $quote_fields, $name, $quote_fields, ' IN ', '(',
233 2         8 join( ', ', map { $quote . $_ . $quote } @range ), ')' )
234             );
235 2         10 next NAME;
236              
237             }
238              
239             # invert range
240             elsif ( $op eq '!..' ) {
241 2 50 33     19 if ( ref $value ne 'ARRAY' or @$value != 2 ) {
242 0         0 croak "range of values must be a 2-element ARRAY";
243             }
244              
245 2         14 my @range = ( $value->[0] .. $value->[1] );
246 10         30 push(
247             @buf,
248             join( '',
249             $quote_fields, $name, $quote_fields, ' NOT IN ', '( ',
250 2         8 join( ', ', map { $quote . $_ . $quote } @range ), ' )' )
251             );
252 2         11 next NAME;
253             }
254              
255             # fuzzy
256             elsif ( $op =~ m/\~/ ) {
257              
258             # negation
259 8 50       14 if ( $op eq '!~' ) {
260 0 0       0 if ( $field->is_int ) {
261 0         0 $this_op = $field->fuzzy_not_op;
262             }
263             else {
264 0         0 $this_op
265             = $fuzzy_space . $field->fuzzy_not_op . $fuzzy_space;
266             }
267             }
268              
269             # standard fuzzy
270             else {
271 8 100       19 if ( $field->is_int ) {
272 4         11 $this_op = $field->fuzzy_op;
273             }
274             else {
275 4         13 $this_op = $fuzzy_space . $field->fuzzy_op . $fuzzy_space;
276             }
277             }
278             }
279              
280             # null
281             elsif ( !defined $value ) {
282 2 100       6 if ( $op eq '=' ) {
283 1         4 $this_op = ' is ';
284             }
285             else {
286 1         3 $this_op = ' is not ';
287             }
288 2         4 $value = 'NULL';
289 2         3 $quote = '';
290             }
291              
292             # default, pass through
293             else {
294 41         56 $this_op = $op;
295             }
296              
297 51 50       168 if ( defined $field->callback ) {
298 0         0 push( @buf, $field->callback->( $field, $this_op, $value ) );
299 0         0 next NAME;
300             }
301              
302             #warn dump [ $quote_fields, $name, $this_op, $quote, $value ];
303              
304             push(
305 51         220 @buf,
306             join( '',
307             $quote_fields, $name, $quote_fields, $this_op,
308             $quote, $value, $quote )
309             );
310              
311             }
312 41 100       118 my $joiner = $prefix eq '-' ? ' AND ' : ' OR ';
313             return
314 41 100       286 ( scalar(@buf) > 1 ? '(' : '' )
    100          
315             . join( $joiner, @buf )
316             . ( scalar(@buf) > 1 ? ')' : '' );
317             }
318              
319             =head2 get_field
320              
321             Overrides default to set fuzzy_op and fuzzy_not_op.
322              
323             =cut
324              
325             around get_field => sub {
326             my $orig = shift;
327             my $self = shift;
328             my $field = $orig->( $self, @_ );
329              
330             # fix up the operator based on our like() setting
331             if ( !$field->is_int and $self->like ) {
332             $field->fuzzy_op( $self->like );
333             $field->fuzzy_not_op( 'NOT ' . $self->like );
334             }
335              
336             return $field;
337             };
338              
339             =head2 field_class
340              
341             Returns "Search::Query::Field::SQL".
342              
343             =cut
344              
345 16     16 1 71 sub field_class {'Search::Query::Field::SQL'}
346              
347             1;
348              
349             __END__