1 package #hide from PAUSE
2 DBIx::Class::SQLMaker::Util;
9 normalize_sqla_condition
10 extract_equality_conditions
13 use DBIx::Class::Carp;
15 use SQL::Abstract qw( is_literal_value is_plain_value );
16 use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION serialize dump_value );
19 # Attempts to flatten a passed in SQLA condition as much as possible towards
20 # a plain hashref, *without* altering its semantics.
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) = @_;
34 elsif ($where_is_anded_array or ref $where eq 'HASH') {
38 my @pieces = $where_is_anded_array ? @$where : $where;
40 my $chunk = shift @pieces;
42 if (ref $chunk eq 'HASH') {
43 for (sort keys %$chunk) {
45 # Match SQLA 1.79 behavior
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'
53 push @pairs, $_ => $chunk->{$_};
56 elsif (ref $chunk eq 'ARRAY') {
57 push @pairs, -or => $chunk
60 elsif ( ! length ref $chunk) {
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);
66 push @pairs, $chunk, shift @pieces;
69 push @pairs, '', $chunk;
75 my @conds = _normalize_cond_unroll_pairs(\@pairs)
78 # Consolidate various @conds back into something more compact
80 if (ref $c ne 'HASH') {
81 push @{$fin->{-and}}, $c;
84 for my $col (sort keys %$c) {
86 # consolidate all -and nodes
87 if ($col =~ /^\-and$/i) {
89 ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}}
90 : ref $c->{$col} eq 'HASH' ? %{$c->{$col}}
91 : { $col => $c->{$col} }
94 elsif ($col =~ /^\-/) {
95 push @{$fin->{-and}}, { $col => $c->{$col} };
97 elsif (exists $fin->{$col}) {
98 $fin->{$col} = [ -and => map {
99 (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i )
103 } ($fin->{$col}, $c->{$col}) ];
106 $fin->{$col} = $c->{$col};
112 elsif (ref $where eq 'ARRAY') {
113 # we are always at top-level here, it is safe to dump empty *standalone* pieces
116 for (my $i = 0; $i <= $#$where; $i++ ) {
118 # Match SQLA 1.79 behavior
120 "Supplying an empty left hand side argument is not supported in array-pairs"
121 ) if (! defined $where->[$i] or ! length $where->[$i]);
123 my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' );
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';
130 my $sub_elt = normalize_sqla_condition({ $logic_mod => $where->[$i] })
133 my @keys = keys %$sub_elt;
134 if ( @keys == 1 and $keys[0] !~ /^\-/ ) {
135 $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt;
138 $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt;
141 elsif (! length ref $where->[$i] ) {
142 my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] })
145 $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt;
149 $fin_idx->{ "SER_" . serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next;
156 elsif ( keys %$fin_idx == 1 ) {
157 $fin = (values %$fin_idx)[0];
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->{$_}};
171 ( @$r == 1 and $l =~ /^\-and$/i )
184 $l =~ /^\-(?:and|or)$/i
194 push @or, $fin_idx->{$_};
202 # not a hash not an array
203 $fin = { -and => [ $where ] };
206 # unroll single-element -and's
212 my $and = delete $fin->{-and};
215 # at this point we have @$and == 1
217 ref $and->[0] eq 'HASH'
219 ! grep { exists $fin->{$_} } keys %{$and->[0]}
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}}] };
240 if (keys %$val_bag == 1 ) {
241 ($fin->{$col}) = values %$val_bag;
244 $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ];
248 return keys %$fin ? $fin : ();
251 sub _normalize_cond_unroll_pairs {
257 my ($lhs, $rhs) = splice @$pairs, 0, 2;
260 push @conds, normalize_sqla_condition($rhs);
262 elsif ( $lhs =~ /^\-and$/i ) {
263 push @conds, normalize_sqla_condition($rhs, (ref $rhs eq 'ARRAY'));
265 elsif ( $lhs =~ /^\-or$/i ) {
266 push @conds, normalize_sqla_condition(
267 (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs
271 if (ref $rhs eq 'HASH' and ! keys %$rhs) {
272 # FIXME - SQLA seems to be doing... nothing...?
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 } };
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} };
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 };
286 for my $p (_normalize_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) {
290 local $Data::Dumper::Deepcopy = 1;
292 "Internal error: unexpected collapse unroll:"
293 . dump_value { in => { $lhs => $rhs }, out => $p }
302 # the unroller recursion may return a '=' prepended value already
303 ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}
308 : { $l => { '=' => $r } }
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
317 push @conds, { $lhs => [] };
319 elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) {
320 croak("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ")
323 if( $rhs->[0] =~ /^\-and$/i ) {
324 unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs];
326 # if not an AND then it's an OR
328 unshift @$pairs, $lhs => $rhs->[1];
331 push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] };
335 unshift @$pairs, $lhs => $rhs->[0];
338 push @conds, { $lhs => $rhs };
341 # unroll func + { -value => ... }
345 ( my ($subop) = keys %$rhs ) == 1
347 length ref ((values %$rhs)[0])
349 my $vref = is_plain_value( (values %$rhs)[0] )
354 : { $lhs => { $subop => $$vref } }
358 push @conds, { $lhs => $rhs };
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
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.
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)
382 sub extract_equality_conditions {
383 my ($where, $consider_nulls) = @_;
384 my $where_hash = normalize_sqla_condition($where);
388 for $c (keys %$where_hash) {
391 if (!defined ($v = $where_hash->{$c}) ) {
392 $vals->{UNDEF} = $v if $consider_nulls
399 if (exists $v->{-value}) {
400 if (defined $v->{-value}) {
401 $vals->{"VAL_$v->{-value}"} = $v->{-value}
403 elsif( $consider_nulls ) {
404 $vals->{UNDEF} = $v->{-value};
407 # do not need to check for plain values - normalize_sqla_condition did it for us
412 ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} )
414 is_literal_value($v->{'='})
417 $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='};
425 $vals->{"VAL_$v"} = $v;
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
432 ! defined $subval->{$c} ? 'UNDEF'
433 : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}"
434 : ( 'SER_' . serialize $subval->{$c} )
439 if (keys %$vals == 1) {
440 ($res->{$c}) = (values %$vals)
441 unless !$consider_nulls and exists $vals->{UNDEF};
443 elsif (keys %$vals > 1) {
444 $res->{$c} = UNRESOLVABLE_CONDITION;