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__ |