File Coverage

blib/lib/SolarBeam/Query.pm
Criterion Covered Total %
statement 15 119 12.6
branch 0 8 0.0
condition 0 17 0.0
subroutine 5 23 21.7
pod 2 2 100.0
total 22 169 13.0


line stmt bran cond sub pod time code
1             package SolarBeam::Query;
2 2     2   11 use Mojo::Base -base;
  2         4  
  2         10  
3              
4 2     2   882 use SolarBeam::Util qw(escape_chars unescape_chars);
  2         4  
  2         100  
5 2     2   11 use overload q("") => 'stringify';
  2         3  
  2         10  
6              
7             #has 'query' => ( is => 'ro', isa => 'ArrayRef', default => sub { [] } );
8             has query => sub { [] };
9              
10 2     2   150 use constant D => 0;
  2         4  
  2         95  
11 2     2   9 use Data::Dumper;
  2         7  
  2         3191  
12              
13             sub new {
14 0     0 1   my $class = shift;
15 0           my $self;
16              
17 0 0 0       if (@_ == 1 && ref $_[0] && ref $_[0] eq 'ARRAY') {
      0        
18 0           $self = {query => $_[0]};
19             }
20              
21 0           $self = {query => \@_};
22 0           bless $self, 'SolarBeam::Query';
23 0           return $self;
24             }
25              
26             sub stringify {
27 0     0 1   my $self = shift;
28              
29 0           return $self->_dispatch_struct($self->query);
30             }
31              
32             sub _dispatch_struct {
33 0     0     my ($self, $struct) = @_;
34              
35 0           my $method = '_struct_' . ref $struct;
36              
37 0           D && $self->___log("Dispatching to ->$method " . Dumper $struct );
38              
39 0           my $rv = $self->$method($struct);
40              
41 0           D && $self->___log("Returned: $rv");
42              
43 0           return $rv;
44             }
45              
46             sub _struct_HASH {
47 0     0     my ($self, $struct) = @_;
48              
49 0           my @clauses;
50              
51 0           for my $k (keys %$struct) {
52 0           my $v = $struct->{$k};
53              
54 0           D && $self->___log("Key => $k, value => " . Dumper($v));
55              
56 0 0         if ($k =~ m{^-(.+)}) {
57 0           my $method = "_op_$1";
58              
59 0           D && $self->___log("Dispatch ->$method " . Dumper($v));
60 0           push @clauses, $self->$method($v);
61             }
62             else {
63 0           D && $self->___log("Dispatch ->_dispatch_value $k, " . Dumper($v));
64 0           push @clauses, $self->_dispatch_value($k, $v);
65             }
66             }
67              
68 0           my $rv = join(' AND ', @clauses);
69              
70 0           D && $self->___log("Returning: $rv");
71              
72 0           return $rv;
73             }
74              
75             sub _struct_ARRAY {
76 0     0     my ($self, $struct) = @_;
77              
78 0           my $rv = '(' . join(" OR ", map { $self->_dispatch_struct($_) } @$struct) . ')';
  0            
79              
80 0           D && $self->___log("Returning: $rv");
81              
82 0           return $rv;
83             }
84              
85             sub _dispatch_value {
86 0     0     my ($self, $k, $v) = @_;
87              
88 0           my $rv;
89             ### it's an array ref, the first element MAY be an operator!
90             ### it would look something like this:
91             # [ '-and',
92             # { '-require' => 'star' },
93             # { '-require' => 'wars' }
94             # ];
95 0 0 0       if ( ref $v
      0        
      0        
96             and UNIVERSAL::isa($v, 'ARRAY')
97             and defined $v->[0]
98             and $v->[0] =~ /^ - ( AND|OR ) $/ix)
99             {
100             ### XXX we're assuming that all the next statements MUST
101             ### be hashrefs. is this correct?
102 0           shift @$v;
103 0           my $op = uc $1;
104              
105 0           D && $self->___log("Special operator detected: $op " . Dumper($v));
106              
107 0           my @clauses;
108 0           for my $href (@$v) {
109 0           D && $self->___log("Dispatch ->_dispatch_struct({ $k, " . Dumper($href) . '})');
110              
111             ### the individual directive ($href) pertains to the key,
112             ### so we should send that along.
113 0           my $part = $self->_dispatch_struct({$k => $href});
114              
115 0           D && $self->___log("Returned $part");
116              
117 0           push @clauses, '(' . $part . ')';
118             }
119              
120 0           $rv = '(' . join(" $op ", @clauses) . ')';
121              
122             ### nothing special about this combo, so do a usual dispatch
123             }
124             else {
125 0   0       my $method = '_value_' . (ref $v || 'SCALAR');
126              
127 0           D && $self->___log("Dispatch ->$method $k, " . Dumper($v));
128              
129 0           $rv = $self->$method($k, $v);
130             }
131              
132 0           D && $self->___log("Returning: $rv");
133              
134 0           return $rv;
135             }
136              
137             sub _value_SCALAR {
138 0     0     my ($self, $k, $v) = @_;
139 0 0         $v = ref $v ? $$v : sprintf '"%s"', escape_chars $v;
140              
141 0           my $r = qq($k:$v);
142 0           $r =~ s{^:}{};
143              
144 0           D && $self->___log("Returning: $r");
145              
146 0           return $r;
147             }
148              
149             sub _value_HASH {
150 0     0     my ($self, $k, $v) = @_;
151              
152 0           my @clauses;
153              
154 0           for my $op (keys %$v) {
155 0           my $struct = $v->{$op};
156 0           $op =~ s{^-(.+)}{_op_$1};
157              
158 0           D && $self->___log("Dispatch ->$op $k, " . Dumper($v));
159              
160 0           push @clauses, $self->$op($k, $struct);
161             }
162              
163 0           my $rv = join(' AND ', @clauses);
164              
165 0           D && $self->___log("Returning: $rv");
166              
167 0           return $rv;
168             }
169              
170             sub _value_ARRAY {
171 0     0     my ($self, $k, $v) = @_;
172              
173 0           my $rv = '(' . join(' OR ', map { $self->_value_SCALAR($k, $_) } @$v) . ')';
  0            
174              
175 0           D && $self->___log("Returning: $rv");
176              
177 0           return $rv;
178             }
179              
180             sub _op_default {
181 0     0     my ($self, $v) = @_;
182 0           return $self->_dispatch_value('', $v);
183             }
184              
185             sub _op_range {
186 0     0     my ($self, $k) = (shift, shift);
187 0           my @v = @{shift()};
  0            
188 0           return "$k:[$v[ 0 ] TO $v[ 1 ]]";
189             }
190              
191             *_op_range_inc = \&_op_range;
192              
193             sub _op_range_exc {
194 0     0     my ($self, $k) = (shift, shift);
195 0           my @v = @{shift()};
  0            
196 0           return "$k:{$v[ 0 ] TO $v[ 1 ]}";
197             }
198              
199             sub _op_boost {
200 0     0     my ($self, $k) = (shift, shift);
201 0           my ($v, $boost) = @{shift()};
  0            
202 0           return sprintf '%s:%s^%s', $k, escape_chars($v), $boost;
203             }
204              
205             sub _op_fuzzy {
206 0     0     my ($self, $k) = (shift, shift);
207 0           my ($v, $distance) = @{shift()};
  0            
208 0           return sprintf '%s:%s~%s', $k, escape_chars($v), $distance;
209             }
210              
211             sub _op_proximity {
212 0     0     my ($self, $k) = (shift, shift);
213 0           my ($v, $distance) = @{shift()};
  0            
214 0           return sprintf '%s:"%s"~%s', $k, escape_chars($v), $distance;
215             }
216              
217             sub _op_require {
218 0     0     my ($self, $k, $v) = @_;
219 0           return sprintf '+%s:"%s"', $k, escape_chars($v);
220             }
221              
222             sub _op_prohibit {
223 0     0     my ($self, $k, $v) = @_;
224 0           return sprintf '-%s:"%s"', $k, escape_chars($v);
225             }
226              
227             sub ___log {
228 0     0     my $self = shift;
229 0           my $msg = shift;
230              
231             ### subroutine the log call came from, and line number the log
232             ### call came from. that's 2 different caller frames :(
233 0           my $who = join ':', [caller(1)]->[3], [caller(0)]->[2];
234              
235             ### make sure we prefix every line with a #
236 0           $msg =~ s/\n/\n#/g;
237              
238 0           print "# $who: $msg\n";
239             }
240              
241             __END__