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 dump_value modver_gt_or_eq );
18 # Can not use DBIx::Class::_Util::serialize as it is based on
19 # Storable and leaks through differences between PVIV and an identical IV
20 # Since SQLA itself is lossy in this regard (it does not make proper copies
21 # for efficiency) one could end up in a situation where semantically
22 # identical values aren't treated as such
24 sub lax_serialize ($) {
31 # Warnings without this on early loads under -w
32 # Why? Because fuck me, that's why :/
33 local $Data::Dumper::Indent = 0
34 unless defined $Data::Dumper::Indent;
36 # Make sure each option is spelled out with a value, so that
37 # global environment changes can not override any of these
38 # between two serialization calls
40 my $d = Data::Dumper->new([])
58 # FIXME - this is kinda ridiculous - there ought to be a
59 # Data::Dumper->new_with_defaults or somesuch...
61 if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) {
64 if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) {
67 if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) {
75 )->Values([$_[0]])->Dump;
77 $dd_obj->Reset->Values([]);
83 # Attempts to flatten a passed in SQLA condition as much as possible towards
84 # a plain hashref, *without* altering its semantics.
86 # FIXME - while relatively robust, this is still imperfect, one of the first
87 # things to tackle when we get access to a formalized AST. Note that this code
88 # is covered by a *ridiculous* amount of tests, so starting with porting this
89 # code would be a rather good exercise
90 sub normalize_sqla_condition {
91 my ($where, $where_is_anded_array) = @_;
98 elsif ($where_is_anded_array or ref $where eq 'HASH') {
102 my @pieces = $where_is_anded_array ? @$where : $where;
104 my $chunk = shift @pieces;
106 if (ref $chunk eq 'HASH') {
107 for (sort keys %$chunk) {
109 # Match SQLA 1.79 behavior
110 unless( length $_ ) {
111 is_literal_value($chunk->{$_})
112 ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead'
113 : croak 'Supplying an empty left hand side argument is not supported in hash-pairs'
117 push @pairs, $_ => $chunk->{$_};
120 elsif (ref $chunk eq 'ARRAY') {
121 push @pairs, -or => $chunk
124 elsif ( ! length ref $chunk) {
126 # Match SQLA 1.79 behavior
127 croak("Supplying an empty left hand side argument is not supported in array-pairs")
128 if $where_is_anded_array and (! defined $chunk or ! length $chunk);
130 push @pairs, $chunk, shift @pieces;
133 push @pairs, '', $chunk;
137 return unless @pairs;
139 my @conds = _normalize_cond_unroll_pairs(\@pairs)
142 # Consolidate various @conds back into something more compact
144 if (ref $c ne 'HASH') {
145 push @{$fin->{-and}}, $c;
148 for my $col (keys %$c) {
150 # consolidate all -and nodes
151 if ($col =~ /^\-and$/i) {
152 push @{$fin->{-and}},
153 ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}}
154 : ref $c->{$col} eq 'HASH' ? %{$c->{$col}}
155 : { $col => $c->{$col} }
158 elsif ($col =~ /^\-/) {
159 push @{$fin->{-and}}, { $col => $c->{$col} };
161 elsif (exists $fin->{$col}) {
162 $fin->{$col} = [ -and => map {
163 (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i )
167 } ($fin->{$col}, $c->{$col}) ];
170 $fin->{$col} = $c->{$col};
176 # a deduplication (and sort) pass on all individual -and/-or members
177 for my $op (qw( -and -or )) {
178 if( @{ $fin->{$op} || [] } > 1 ) {
179 my $seen_chunks = { map {
180 lax_serialize($_) => $_
183 $fin->{$op} = [ @{$seen_chunks}{ sort keys %$seen_chunks } ];
187 elsif (ref $where eq 'ARRAY') {
188 # we are always at top-level here, it is safe to dump empty *standalone* pieces
191 for (my $i = 0; $i <= $#$where; $i++ ) {
193 # Match SQLA 1.79 behavior
195 "Supplying an empty left hand side argument is not supported in array-pairs"
196 ) if (! defined $where->[$i] or ! length $where->[$i]);
198 my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' );
202 croak("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]")
203 unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY';
205 my $sub_elt = normalize_sqla_condition({ $logic_mod => $where->[$i] })
208 my @keys = keys %$sub_elt;
209 if ( @keys == 1 and $keys[0] !~ /^\-/ ) {
210 $fin_idx->{ "COL_$keys[0]_" . lax_serialize $sub_elt } = $sub_elt;
213 $fin_idx->{ "SER_" . lax_serialize $sub_elt } = $sub_elt;
216 elsif (! length ref $where->[$i] ) {
217 my $sub_elt = normalize_sqla_condition({ @{$where}[$i, $i+1] })
220 $fin_idx->{ "COL_$where->[$i]_" . lax_serialize $sub_elt } = $sub_elt;
224 $fin_idx->{ "SER_" . lax_serialize $where->[$i] } = normalize_sqla_condition( $where->[$i] ) || next;
231 elsif ( keys %$fin_idx == 1 ) {
232 $fin = (values %$fin_idx)[0];
237 # at this point everything is at most one level deep - unroll if needed
238 for (sort keys %$fin_idx) {
239 if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) {
240 my ($l, $r) = %{$fin_idx->{$_}};
246 ( @$r == 1 and $l =~ /^\-and$/i )
259 $l =~ /^\-(?:and|or)$/i
269 push @or, $fin_idx->{$_};
277 # not a hash not an array
278 $fin = { -and => [ $where ] };
281 # unroll single-element -and's
287 my $and = delete $fin->{-and};
290 # at this point we have @$and == 1
292 ref $and->[0] eq 'HASH'
294 ! grep { exists $fin->{$_} } keys %{$and->[0]}
306 # compress same-column conds found in $fin
307 for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) {
308 next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i;
309 my $val_bag = { map {
310 (! defined $_ ) ? ( UNDEF => undef )
311 : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ )
312 : ( ( 'SER_' . lax_serialize $_ ) => $_ )
313 } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] };
315 if (keys %$val_bag == 1 ) {
316 ($fin->{$col}) = values %$val_bag;
319 $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ];
323 return keys %$fin ? $fin : ();
326 sub _normalize_cond_unroll_pairs {
332 my ($lhs, $rhs) = splice @$pairs, 0, 2;
335 push @conds, normalize_sqla_condition($rhs);
337 elsif ( $lhs =~ /^\-and$/i ) {
338 push @conds, normalize_sqla_condition($rhs, (ref $rhs eq 'ARRAY'));
340 elsif ( $lhs =~ /^\-or$/i ) {
341 push @conds, normalize_sqla_condition(
342 (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs
346 if (ref $rhs eq 'HASH' and ! keys %$rhs) {
347 # FIXME - SQLA seems to be doing... nothing...?
349 # normalize top level -ident, for saner extract_equality_conditions() code
350 elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) {
351 push @conds, { $lhs => { '=', $rhs } };
353 elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) {
354 push @conds, { $lhs => $rhs->{-value} };
356 elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) {
357 if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) {
358 push @conds, { $lhs => $rhs };
361 for my $p (_normalize_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) {
365 local $Data::Dumper::Deepcopy = 1;
367 "Internal error: unexpected collapse unroll:"
368 . dump_value { in => { $lhs => $rhs }, out => $p }
377 # the unroller recursion may return a '=' prepended value already
378 ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}
383 : { $l => { '=' => $r } }
388 elsif (ref $rhs eq 'ARRAY') {
389 # some of these conditionals encounter multi-values - roll them out using
390 # an unshift, which will cause extra looping in the while{} above
392 push @conds, { $lhs => [] };
394 elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) {
395 croak("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ")
398 if( $rhs->[0] =~ /^\-and$/i ) {
399 unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs];
401 # if not an AND then it's an OR
403 unshift @$pairs, $lhs => $rhs->[1];
406 push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] };
410 unshift @$pairs, $lhs => $rhs->[0];
413 push @conds, { $lhs => $rhs };
416 # unroll func + { -value => ... }
420 ( my ($subop) = keys %$rhs ) == 1
422 length ref ((values %$rhs)[0])
424 my $vref = is_plain_value( (values %$rhs)[0] )
429 : { $lhs => { $subop => $$vref } }
433 push @conds, { $lhs => $rhs };
441 # Analyzes a given condition and attempts to extract all columns
442 # with a definitive fixed-condition criteria. Returns a hashref
443 # of k/v pairs suitable to be passed to set_columns(), with a
444 # MAJOR CAVEAT - multi-value (contradictory) equalities are still
445 # represented as a reference to the UNRESOVABLE_CONDITION constant
446 # The reason we do this is that some codepaths only care about the
447 # codition being stable, as opposed to actually making sense
449 # The normal mode is used to figure out if a resultset is constrained
450 # to a column which is part of a unique constraint, which in turn
451 # allows us to better predict how ordering will behave etc.
453 # With the optional "consider_nulls" boolean argument, the function
454 # is instead used to infer inambiguous values from conditions
455 # (e.g. the inheritance of resultset conditions on new_result)
457 sub extract_equality_conditions {
458 my ($where, $consider_nulls) = @_;
459 my $where_hash = normalize_sqla_condition($where);
463 for $c (keys %$where_hash) {
466 if (!defined ($v = $where_hash->{$c}) ) {
467 $vals->{UNDEF} = $v if $consider_nulls
474 if (exists $v->{-value}) {
475 if (defined $v->{-value}) {
476 $vals->{"VAL_$v->{-value}"} = $v->{-value}
478 elsif( $consider_nulls ) {
479 $vals->{UNDEF} = $v->{-value};
482 # do not need to check for plain values - normalize_sqla_condition did it for us
487 ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} )
489 is_literal_value($v->{'='})
492 $vals->{ 'SER_' . lax_serialize $v->{'='} } = $v->{'='};
500 $vals->{"VAL_$v"} = $v;
502 elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') {
503 for ( @{$v}[1..$#$v] ) {
504 my $subval = extract_equality_conditions({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion
505 next unless exists $subval->{$c}; # didn't find anything
507 ! defined $subval->{$c} ? 'UNDEF'
508 : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}"
509 : ( 'SER_' . lax_serialize $subval->{$c} )
514 if (keys %$vals == 1) {
515 ($res->{$c}) = (values %$vals)
516 unless !$consider_nulls and exists $vals->{UNDEF};
518 elsif (keys %$vals > 1) {
519 $res->{$c} = UNRESOLVABLE_CONDITION;