Commit | Line | Data |
497d0451 |
1 | package #hide from PAUSE |
2 | DBIx::Class::SQLMaker::Util; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use base 'Exporter'; |
8 | our @EXPORT_OK = qw( |
9 | normalize_sqla_condition |
10 | extract_equality_conditions |
11 | ); |
12 | |
13 | use DBIx::Class::Carp; |
14 | use Carp 'croak'; |
15 | use SQL::Abstract qw( is_literal_value is_plain_value ); |
16 | use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION serialize dump_value ); |
17 | |
18 | |
19 | # Attempts to flatten a passed in SQLA condition as much as possible towards |
20 | # a plain hashref, *without* altering its semantics. |
21 | # |
22 | # FIXME - while relatively robust, this is still imperfect, one of the first |
23 | # things to tackle when we get access to a formalized AST. Note that this code |
24 | # is covered by a *ridiculous* amount of tests, so starting with porting this |
25 | # code would be a rather good exercise |
26 | sub normalize_sqla_condition { |
27 | my ($where, $where_is_anded_array) = @_; |
28 | |
29 | my $fin; |
30 | |
31 | if (! $where) { |
32 | return; |
33 | } |
34 | elsif ($where_is_anded_array or ref $where eq 'HASH') { |
35 | |
36 | my @pairs; |
37 | |
38 | my @pieces = $where_is_anded_array ? @$where : $where; |
39 | while (@pieces) { |
40 | my $chunk = shift @pieces; |
41 | |
42 | if (ref $chunk eq 'HASH') { |
43 | for (sort keys %$chunk) { |
44 | |
45 | # Match SQLA 1.79 behavior |
46 | unless( length $_ ) { |
47 | is_literal_value($chunk->{$_}) |
48 | ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' |
49 | : croak 'Supplying an empty left hand side argument is not supported in hash-pairs' |
50 | ; |
51 | } |
52 | |
53 | push @pairs, $_ => $chunk->{$_}; |
54 | } |
55 | } |
56 | elsif (ref $chunk eq 'ARRAY') { |
57 | push @pairs, -or => $chunk |
58 | if @$chunk; |
59 | } |
60 | elsif ( ! length ref $chunk) { |
61 | |
62 | # Match SQLA 1.79 behavior |
63 | croak("Supplying an empty left hand side argument is not supported in array-pairs") |
64 | if $where_is_anded_array and (! defined $chunk or ! length $chunk); |
65 | |
66 | push @pairs, $chunk, shift @pieces; |
67 | } |
68 | else { |
69 | push @pairs, '', $chunk; |
70 | } |
71 | } |
72 | |
73 | return unless @pairs; |
74 | |
75 | my @conds = _normalize_cond_unroll_pairs(\@pairs) |
76 | or return; |
77 | |
78 | # Consolidate various @conds back into something more compact |
79 | for my $c (@conds) { |
80 | if (ref $c ne 'HASH') { |
81 | push @{$fin->{-and}}, $c; |
82 | } |
83 | else { |
84 | for my $col (sort keys %$c) { |
85 | |
86 | # consolidate all -and nodes |
87 | if ($col =~ /^\-and$/i) { |
88 | push @{$fin->{-and}}, |
89 | ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} |
90 | : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} |
91 | : { $col => $c->{$col} } |
92 | ; |
93 | } |
94 | elsif ($col =~ /^\-/) { |
95 | push @{$fin->{-and}}, { $col => $c->{$col} }; |
96 | } |
97 | elsif (exists $fin->{$col}) { |
98 | $fin->{$col} = [ -and => map { |
99 | (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) |
100 | ? @{$_}[1..$#$_] |
101 | : $_ |
102 | ; |
103 | } ($fin->{$col}, $c->{$col}) ]; |
104 | } |
105 | else { |
106 | $fin->{$col} = $c->{$col}; |
107 | } |
108 | } |
109 | } |
110 | } |
111 | } |
112 | elsif (ref $where eq 'ARRAY') { |
113 | # we are always at top-level here, it is safe to dump empty *standalone* pieces |
114 | my $fin_idx; |
115 | |
116 | for (my $i = 0; $i <= $#$where; $i++ ) { |
117 | |
118 | # Match SQLA 1.79 behavior |
119 | croak( |
120 | "Supplying an empty left hand side argument is not supported in array-pairs" |
121 | ) if (! defined $where->[$i] or ! length $where->[$i]); |
122 | |
123 | my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); |
124 | |
125 | if ($logic_mod) { |
126 | $i++; |
127 | croak("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") |
128 | unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; |
129 | |
130 | my $sub_elt = normalize_sqla_condition({ $logic_mod => $where->[$i] }) |
131 | or next; |
132 | |
133 | my @keys = keys %$sub_elt; |
134 | if ( @keys == 1 and $keys[0] !~ /^\-/ ) { |
135 | $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; |
136 | } |
137 | else { |
138 | $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; |
139 | } |
140 | } |
141 | elsif (! length ref $where->[$i] ) { |
142 | my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] }) |
143 | or next; |
144 | |
145 | $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; |
146 | $i++; |
147 | } |
148 | else { |
149 | $fin_idx->{ "SER_" . serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next; |
150 | } |
151 | } |
152 | |
153 | if (! $fin_idx) { |
154 | return; |
155 | } |
156 | elsif ( keys %$fin_idx == 1 ) { |
157 | $fin = (values %$fin_idx)[0]; |
158 | } |
159 | else { |
160 | my @or; |
161 | |
162 | # at this point everything is at most one level deep - unroll if needed |
163 | for (sort keys %$fin_idx) { |
164 | if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { |
165 | my ($l, $r) = %{$fin_idx->{$_}}; |
166 | |
167 | if ( |
168 | ref $r eq 'ARRAY' |
169 | and |
170 | ( |
171 | ( @$r == 1 and $l =~ /^\-and$/i ) |
172 | or |
173 | $l =~ /^\-or$/i |
174 | ) |
175 | ) { |
176 | push @or, @$r |
177 | } |
178 | |
179 | elsif ( |
180 | ref $r eq 'HASH' |
181 | and |
182 | keys %$r == 1 |
183 | and |
184 | $l =~ /^\-(?:and|or)$/i |
185 | ) { |
186 | push @or, %$r; |
187 | } |
188 | |
189 | else { |
190 | push @or, $l, $r; |
191 | } |
192 | } |
193 | else { |
194 | push @or, $fin_idx->{$_}; |
195 | } |
196 | } |
197 | |
198 | $fin->{-or} = \@or; |
199 | } |
200 | } |
201 | else { |
202 | # not a hash not an array |
203 | $fin = { -and => [ $where ] }; |
204 | } |
205 | |
206 | # unroll single-element -and's |
207 | while ( |
208 | $fin->{-and} |
209 | and |
210 | @{$fin->{-and}} < 2 |
211 | ) { |
212 | my $and = delete $fin->{-and}; |
213 | last if @$and == 0; |
214 | |
215 | # at this point we have @$and == 1 |
216 | if ( |
217 | ref $and->[0] eq 'HASH' |
218 | and |
219 | ! grep { exists $fin->{$_} } keys %{$and->[0]} |
220 | ) { |
221 | $fin = { |
222 | %$fin, %{$and->[0]} |
223 | }; |
224 | } |
225 | else { |
226 | $fin->{-and} = $and; |
227 | last; |
228 | } |
229 | } |
230 | |
231 | # compress same-column conds found in $fin |
232 | for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { |
233 | next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; |
234 | my $val_bag = { map { |
235 | (! defined $_ ) ? ( UNDEF => undef ) |
236 | : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) |
237 | : ( ( 'SER_' . serialize $_ ) => $_ ) |
238 | } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; |
239 | |
240 | if (keys %$val_bag == 1 ) { |
241 | ($fin->{$col}) = values %$val_bag; |
242 | } |
243 | else { |
244 | $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; |
245 | } |
246 | } |
247 | |
248 | return keys %$fin ? $fin : (); |
249 | } |
250 | |
251 | sub _normalize_cond_unroll_pairs { |
252 | my $pairs = shift; |
253 | |
254 | my @conds; |
255 | |
256 | while (@$pairs) { |
257 | my ($lhs, $rhs) = splice @$pairs, 0, 2; |
258 | |
259 | if (! length $lhs) { |
260 | push @conds, normalize_sqla_condition($rhs); |
261 | } |
262 | elsif ( $lhs =~ /^\-and$/i ) { |
263 | push @conds, normalize_sqla_condition($rhs, (ref $rhs eq 'ARRAY')); |
264 | } |
265 | elsif ( $lhs =~ /^\-or$/i ) { |
266 | push @conds, normalize_sqla_condition( |
267 | (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs |
268 | ); |
269 | } |
270 | else { |
271 | if (ref $rhs eq 'HASH' and ! keys %$rhs) { |
272 | # FIXME - SQLA seems to be doing... nothing...? |
273 | } |
274 | # normalize top level -ident, for saner extract_fixed_condition_columns code |
275 | elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { |
276 | push @conds, { $lhs => { '=', $rhs } }; |
277 | } |
278 | elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { |
279 | push @conds, { $lhs => $rhs->{-value} }; |
280 | } |
281 | elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { |
282 | if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { |
283 | push @conds, { $lhs => $rhs }; |
284 | } |
285 | else { |
286 | for my $p (_normalize_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { |
287 | |
288 | # extra sanity check |
289 | if (keys %$p > 1) { |
290 | local $Data::Dumper::Deepcopy = 1; |
291 | croak( |
292 | "Internal error: unexpected collapse unroll:" |
293 | . dump_value { in => { $lhs => $rhs }, out => $p } |
294 | ); |
295 | } |
296 | |
297 | my ($l, $r) = %$p; |
298 | |
299 | push @conds, ( |
300 | ! length ref $r |
301 | or |
302 | # the unroller recursion may return a '=' prepended value already |
303 | ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} |
304 | or |
305 | is_plain_value($r) |
306 | ) |
307 | ? { $l => $r } |
308 | : { $l => { '=' => $r } } |
309 | ; |
310 | } |
311 | } |
312 | } |
313 | elsif (ref $rhs eq 'ARRAY') { |
314 | # some of these conditionals encounter multi-values - roll them out using |
315 | # an unshift, which will cause extra looping in the while{} above |
316 | if (! @$rhs ) { |
317 | push @conds, { $lhs => [] }; |
318 | } |
319 | elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { |
320 | croak("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") |
321 | if @$rhs == 1; |
322 | |
323 | if( $rhs->[0] =~ /^\-and$/i ) { |
324 | unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; |
325 | } |
326 | # if not an AND then it's an OR |
327 | elsif(@$rhs == 2) { |
328 | unshift @$pairs, $lhs => $rhs->[1]; |
329 | } |
330 | else { |
331 | push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; |
332 | } |
333 | } |
334 | elsif (@$rhs == 1) { |
335 | unshift @$pairs, $lhs => $rhs->[0]; |
336 | } |
337 | else { |
338 | push @conds, { $lhs => $rhs }; |
339 | } |
340 | } |
341 | # unroll func + { -value => ... } |
342 | elsif ( |
343 | ref $rhs eq 'HASH' |
344 | and |
345 | ( my ($subop) = keys %$rhs ) == 1 |
346 | and |
347 | length ref ((values %$rhs)[0]) |
348 | and |
349 | my $vref = is_plain_value( (values %$rhs)[0] ) |
350 | ) { |
aa072cab |
351 | push @conds, ( |
352 | (length ref $$vref) |
353 | ? { $lhs => $rhs } |
354 | : { $lhs => { $subop => $$vref } } |
355 | ); |
497d0451 |
356 | } |
357 | else { |
358 | push @conds, { $lhs => $rhs }; |
359 | } |
360 | } |
361 | } |
362 | |
363 | return @conds; |
364 | } |
365 | |
366 | # Analyzes a given condition and attempts to extract all columns |
367 | # with a definitive fixed-condition criteria. Returns a hashref |
368 | # of k/v pairs suitable to be passed to set_columns(), with a |
369 | # MAJOR CAVEAT - multi-value (contradictory) equalities are still |
370 | # represented as a reference to the UNRESOVABLE_CONDITION constant |
371 | # The reason we do this is that some codepaths only care about the |
372 | # codition being stable, as opposed to actually making sense |
373 | # |
374 | # The normal mode is used to figure out if a resultset is constrained |
375 | # to a column which is part of a unique constraint, which in turn |
376 | # allows us to better predict how ordering will behave etc. |
377 | # |
378 | # With the optional "consider_nulls" boolean argument, the function |
379 | # is instead used to infer inambiguous values from conditions |
380 | # (e.g. the inheritance of resultset conditions on new_result) |
381 | # |
382 | sub extract_equality_conditions { |
383 | my ($where, $consider_nulls) = @_; |
384 | my $where_hash = normalize_sqla_condition($where); |
385 | |
386 | my $res = {}; |
387 | my ($c, $v); |
388 | for $c (keys %$where_hash) { |
389 | my $vals; |
390 | |
391 | if (!defined ($v = $where_hash->{$c}) ) { |
392 | $vals->{UNDEF} = $v if $consider_nulls |
393 | } |
394 | elsif ( |
395 | ref $v eq 'HASH' |
396 | and |
397 | keys %$v == 1 |
398 | ) { |
399 | if (exists $v->{-value}) { |
400 | if (defined $v->{-value}) { |
401 | $vals->{"VAL_$v->{-value}"} = $v->{-value} |
402 | } |
403 | elsif( $consider_nulls ) { |
404 | $vals->{UNDEF} = $v->{-value}; |
405 | } |
406 | } |
407 | # do not need to check for plain values - normalize_sqla_condition did it for us |
408 | elsif( |
409 | length ref $v->{'='} |
410 | and |
411 | ( |
412 | ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) |
413 | or |
414 | is_literal_value($v->{'='}) |
415 | ) |
416 | ) { |
417 | $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; |
418 | } |
419 | } |
420 | elsif ( |
421 | ! length ref $v |
422 | or |
423 | is_plain_value ($v) |
424 | ) { |
425 | $vals->{"VAL_$v"} = $v; |
426 | } |
427 | elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { |
428 | for ( @{$v}[1..$#$v] ) { |
429 | my $subval = extract_equality_conditions({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion |
430 | next unless exists $subval->{$c}; # didn't find anything |
431 | $vals->{ |
432 | ! defined $subval->{$c} ? 'UNDEF' |
433 | : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" |
434 | : ( 'SER_' . serialize $subval->{$c} ) |
435 | } = $subval->{$c}; |
436 | } |
437 | } |
438 | |
439 | if (keys %$vals == 1) { |
440 | ($res->{$c}) = (values %$vals) |
441 | unless !$consider_nulls and exists $vals->{UNDEF}; |
442 | } |
443 | elsif (keys %$vals > 1) { |
444 | $res->{$c} = UNRESOLVABLE_CONDITION; |
445 | } |
446 | } |
447 | |
448 | $res; |
449 | } |
450 | |
451 | 1; |