File Coverage

blib/lib/Search/Query/Dialect/SWISH.pm
Criterion Covered Total %
statement 92 104 88.4
branch 48 66 72.7
condition 17 24 70.8
subroutine 11 12 91.6
pod 4 4 100.0
total 172 210 81.9


line stmt bran cond sub pod time code
1             package Search::Query::Dialect::SWISH;
2 3     3   15 use Moo;
  3         4  
  3         24  
3             extends 'Search::Query::Dialect';
4 3     3   1100 use Carp;
  3         5  
  3         256  
5 3     3   17 use Data::Dump qw( dump );
  3         5  
  3         150  
6 3     3   1441 use Search::Query::Field::SWISH;
  3         6  
  3         102  
7 3     3   20 use Try::Tiny;
  3         4  
  3         3723  
8              
9             our $VERSION = '0.305';
10              
11             has 'wildcard' => ( is => 'rw', default => '*' );
12             has 'fuzzify' => ( is => 'rw' );
13             has '+default_field' => ( is => 'rw', default => 'swishdefault' );
14              
15             =head1 NAME
16              
17             Search::Query::Dialect::SWISH - Swish query dialect
18              
19             =head1 SYNOPSIS
20              
21             my $query = Search::Query->parser( dialect => 'SWISH' )->parse('foo');
22             print $query;
23              
24             =head1 DESCRIPTION
25              
26             Search::Query::Dialect::SWISH is a query dialect for Query
27             objects returned by a Search::Query::Parser instance.
28              
29             The SWISH dialect class stringifies queries to work with Swish-e
30             and Swish3 Native search engines.
31              
32             =head1 METHODS
33              
34             This class is a subclass of Search::Query::Dialect. Only new or overridden
35             methods are documented here.
36              
37             =cut
38              
39             =head2 BUILD
40              
41             Sets SWISH-appropriate defaults.
42              
43             Can take the following params, also available as standard attribute
44             methods.
45              
46             =over
47              
48             =item wildcard
49              
50             Default is '*'.
51              
52             =item fuzzify
53              
54             If true, a wildcard is automatically appended to each query term.
55              
56             =item default_field
57              
58             Default is 'swishdefault'.
59              
60             =back
61              
62             =cut
63              
64             sub BUILD {
65 79     79 1 5943 my $self = shift;
66              
67             #carp dump $self;
68              
69             # make sure we have our default field defined amongst all parser fields.
70             my $swishdefault_field = try {
71 79     79   2989 $self->parser->get_field('swishdefault');
72             }
73             catch {
74 0     0   0 carp "swishdefault not amongst parser fields: $_";
75 79         604 };
76 79 100       1205 if ( !$swishdefault_field ) {
77 8         209 $self->parser->set_field( 'swishdefault',
78             Search::Query::Field::SWISH->new( name => 'swishdefault' ) );
79             }
80              
81             #carp "swishdefault_field=" . dump($swishdefault_field);
82              
83 79 100 66     422 if ( $self->{default_field} and !ref( $self->{default_field} ) ) {
84 78         190 $self->{default_field} = [ $self->{default_field} ];
85             }
86              
87             #carp dump $self;
88              
89 79         1900 return $self;
90             }
91              
92             =head2 stringify
93              
94             Returns the Query object as a normalized string.
95              
96             =cut
97              
98             my %op_map = (
99             '+' => ' AND ',
100             '' => ' OR ',
101             '-' => ' ',
102             );
103              
104             sub stringify {
105 99     99 1 121 my $self = shift;
106 99   66     361 my $tree = shift || $self;
107              
108 99         122 my @q;
109 99         140 foreach my $prefix ( '+', '', '-' ) {
110 296         232 my @clauses;
111 296         381 my $joiner = $op_map{$prefix};
112 296 100       691 next unless exists $tree->{$prefix};
113 104         92 for my $clause ( @{ $tree->{$prefix} } ) {
  104         191  
114 149         333 push( @clauses, $self->stringify_clause( $clause, $prefix ) );
115             }
116 103 50       211 next if !@clauses;
117              
118 103 50       150 push @q, join( $joiner, grep { defined and length } @clauses );
  148         619  
119             }
120              
121 98         619 return join " ", @q; # Swish-e defaults to AND but we can't predict.
122             }
123              
124             sub _doctor_value {
125 94     94   135 my ( $self, $clause ) = @_;
126              
127 94         130 my $value = $clause->{value};
128              
129 94 100       215 return $value unless defined $value;
130              
131 93 100       242 if ( $self->fuzzify ) {
132 8 100       28 $value .= '*' unless $value =~ m/[\*\%]/;
133             }
134              
135             # normalize wildcard
136 93         155 my $wildcard = $self->wildcard;
137 93         210 $value =~ s/[\*\%]/$wildcard/g;
138              
139 93         270 return $value;
140             }
141              
142             =head2 stringify_clause( I, I )
143              
144             Called by stringify() to handle each Clause in the Query tree.
145              
146             =cut
147              
148             sub stringify_clause {
149 149     149 1 150 my $self = shift;
150 149         130 my $clause = shift;
151 149         141 my $prefix = shift;
152              
153             #warn dump $clause;
154             #warn "prefix = '$prefix'";
155              
156 149 100       362 if ( $clause->{op} eq '()' ) {
157 53         134 my $str = $self->stringify( $clause->{value} );
158 53 100       102 if ( $prefix eq '-' ) {
159 5         20 return "NOT ($str)";
160             }
161             else {
162 48         164 return "($str)";
163             }
164             }
165              
166             # make sure we have a field
167             my @fields
168 8         26 = $clause->{field}
169             ? ( $clause->{field} )
170 96 100       289 : ( @{ $self->get_default_field } );
171              
172             # what value
173 96 100       266 my $value
174             = ref $clause->{value}
175             ? $clause->{value}
176             : $self->_doctor_value($clause);
177              
178 96         153 my $wildcard = $self->wildcard;
179              
180             # normalize operator
181 96   100     214 my $op = $clause->{op} || "=";
182 96 100       185 if ( $op eq ':' ) {
183 26         34 $op = '=';
184             }
185 96 100       169 if ( $prefix eq '-' ) {
186 4         6 $op = '!' . $op;
187             }
188 96 50 66     426 if ( defined $value and $value =~ m/\%/ ) {
189 0 0       0 $op = $prefix eq '-' ? '!~' : '~';
190             }
191              
192 96   100     341 my $quote = $clause->quote || '';
193 96         141 my $left_quote = $quote;
194 96         92 my $right_quote = $quote;
195 96   100     310 my $proximity = $clause->proximity || '';
196 96 100       160 if ($proximity) {
197 2         12 $value =~ s/\s+/ NEAR$proximity /g;
198 2         3 $left_quote = '(';
199 2         3 $right_quote = ')';
200             }
201              
202 96         104 my @buf;
203 96         140 NAME: for my $name (@fields) {
204 96         286 my $field = $self->get_field($name);
205              
206 96 50       260 if ( defined $field->callback ) {
207 0         0 push( @buf, $field->callback->( $field, $op, $value ) );
208 0         0 next NAME;
209             }
210              
211             #warn dump [ $name, $op, $quote, $value ];
212              
213             # invert fuzzy
214 96 50 100     652 if ( $op eq '!~' ) {
    50          
    100          
    100          
    100          
    100          
215 0 0       0 $value .= $wildcard unless $value =~ m/\Q$wildcard/;
216 0         0 push(
217             @buf,
218             join( '',
219             'NOT ', $name,
220             '=', qq/${left_quote}${value}${right_quote}/ )
221             );
222             }
223              
224             # fuzzy
225             elsif ( $op eq '~' ) {
226 0 0       0 $value .= $wildcard unless $value =~ m/\Q$wildcard/;
227 0         0 push(
228             @buf,
229             join( '',
230             $name, '=', qq/${left_quote}${value}${right_quote}/ )
231             );
232             }
233              
234             # invert
235             elsif ( defined $value and $op eq '!=' ) {
236 4         14 push(
237             @buf,
238             join( '',
239             'NOT ', $name,
240             '=', qq/${left_quote}${value}${right_quote}/ )
241             );
242             }
243              
244             # range
245             elsif ( $op eq '..' ) {
246 1 50 33     9 if ( ref $value ne 'ARRAY' or @$value != 2 ) {
247 0         0 croak "range of values must be a 2-element ARRAY";
248             }
249              
250             # we support only numbers at this point
251 1         2 for my $v (@$value) {
252 2 50       16 if ( $v =~ m/\D/ ) {
253 0         0 croak "non-numeric range values are not supported: $v";
254             }
255             }
256              
257 1         7 my @range = ( $value->[0] .. $value->[1] );
258 1         8 push( @buf,
259             join( '', $name, '=', '(', join( ' OR ', @range ), ')' ) );
260              
261             }
262              
263             # invert range
264             elsif ( $op eq '!..' ) {
265 1 50 33     7 if ( ref $value ne 'ARRAY' or @$value != 2 ) {
266 0         0 croak "range of values must be a 2-element ARRAY";
267             }
268              
269             # we support only numbers at this point
270 1         3 for my $v (@$value) {
271 2 50       8 if ( $v =~ m/\D/ ) {
272 0         0 croak "non-numeric range values are not supported: $v";
273             }
274             }
275              
276 1         6 my @range = ( $value->[0] .. $value->[1] );
277 1         6 push(
278             @buf,
279             join( '',
280             'NOT ', $name, '=', '( ', join( ' ', @range ), ' )' )
281             );
282             }
283              
284             # null query
285             elsif ( !defined $value ) {
286 1         202 croak "SWISH dialect does not support NULL query term";
287             }
288              
289             # standard
290             else {
291 89         422 push(
292             @buf,
293             join( '',
294             $name, '=', qq/${left_quote}${value}${right_quote}/ )
295             );
296             }
297             }
298 95 100       190 my $joiner = $prefix eq '-' ? ' AND ' : ' OR ';
299             return
300 95 50       498 ( scalar(@buf) > 1 ? '(' : '' )
    50          
301             . join( $joiner, @buf )
302             . ( scalar(@buf) > 1 ? ')' : '' );
303             }
304              
305             =head2 field_class
306              
307             Returns "Search::Query::Field::SWISH".
308              
309             =cut
310              
311 18     18 1 68 sub field_class {'Search::Query::Field::SWISH'}
312              
313             1;
314              
315             __END__