X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBIHacks.pm;h=317dbd85a5a616396da3b8717fe53382797d9d6f;hb=82c5f9168e30bc9dc7b681058298bb342582c5ec;hp=c700d54eb0a940ad1fbacd17dc2f79d340836a7e;hpb=7db939decd3929e2800c7ab5ec883cb859b68927;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm index c700d54..317dbd8 100644 --- a/lib/DBIx/Class/Storage/DBIHacks.pm +++ b/lib/DBIx/Class/Storage/DBIHacks.pm @@ -5,7 +5,7 @@ package #hide from PAUSE # This module contains code supporting a battery of special cases and tests for # many corner cases pushing the envelope of what DBIC can do. When work on # these utilities began in mid 2009 (51a296b402c) it wasn't immediately obvious -# that these pieces, despite their misleading on-first-sighe-flakiness, will +# that these pieces, despite their misleading on-first-sight-flakiness, will # become part of the generic query rewriting machinery of DBIC, allowing it to # both generate and process queries representing incredibly complex sets with # reasonable efficiency. @@ -29,8 +29,10 @@ use base 'DBIx::Class::Storage'; use mro 'c3'; use Scalar::Util 'blessed'; -use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize dump_value); -use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw( + dump_value fail_on_internal_call +); +use DBIx::Class::SQLMaker::Util 'extract_equality_conditions'; use DBIx::Class::Carp; use namespace::clean; @@ -992,7 +994,7 @@ sub _order_by_is_stable { my @cols = ( ( map { $_->[0] } $self->_extract_order_criteria($order_by) ), - ( $where ? keys %{ $self->_extract_fixed_condition_columns($where) } : () ), + ( $where ? keys %{ extract_equality_conditions( $where ) } : () ), ) or return 0; my $colinfo = $self->_resolve_column_info($ident, \@cols); @@ -1057,9 +1059,9 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { if $colinfo->{-source_alias} eq $attrs->{alias}; } - # FIXME the condition may be singling out things on its own, so we - # conceivable could come back wi "stable-ordered by nothing" - # not confient enough in the parser yet, so punt for the time being + # FIXME: the condition may be singling out things on its own, so we + # conceivably could come back with "stable-ordered by nothing" + # not confident enough in the parser yet, so punt for the time being return unless $seen_main_src_cols; my $main_src_fixed_cols_from_cond = [ $attrs->{where} @@ -1070,7 +1072,7 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ? $colinfos->{$_}{-colname} : () } - keys %{ $self->_extract_fixed_condition_columns($attrs->{where}) } + keys %{ extract_equality_conditions( $attrs->{where} ) } ) : () ]; @@ -1081,434 +1083,20 @@ sub _extract_colinfo_of_stable_main_source_order_by_portion { ]) ? $colinfos_to_return : (); } -# Attempts to flatten a passed in SQLA condition as much as possible towards -# a plain hashref, *without* altering its semantics. Required by -# create/populate being able to extract definitive conditions from preexisting -# resultset {where} stacks -# -# FIXME - while relatively robust, this is still imperfect, one of the first -# things to tackle when we get access to a formalized AST. Note that this code -# is covered by a *ridiculous* amount of tests, so starting with porting this -# code would be a rather good exercise -sub _collapse_cond { - my ($self, $where, $where_is_anded_array) = @_; - - my $fin; - - if (! $where) { - return; - } - elsif ($where_is_anded_array or ref $where eq 'HASH') { - - my @pairs; - - my @pieces = $where_is_anded_array ? @$where : $where; - while (@pieces) { - my $chunk = shift @pieces; - - if (ref $chunk eq 'HASH') { - for (sort keys %$chunk) { - - # Match SQLA 1.79 behavior - unless( length $_ ) { - is_literal_value($chunk->{$_}) - ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' - : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs") - ; - } - - push @pairs, $_ => $chunk->{$_}; - } - } - elsif (ref $chunk eq 'ARRAY') { - push @pairs, -or => $chunk - if @$chunk; - } - elsif ( ! length ref $chunk) { - - # Match SQLA 1.79 behavior - $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs") - if $where_is_anded_array and (! defined $chunk or ! length $chunk); - - push @pairs, $chunk, shift @pieces; - } - else { - push @pairs, '', $chunk; - } - } - - return unless @pairs; - - my @conds = $self->_collapse_cond_unroll_pairs(\@pairs) - or return; - - # Consolidate various @conds back into something more compact - for my $c (@conds) { - if (ref $c ne 'HASH') { - push @{$fin->{-and}}, $c; - } - else { - for my $col (sort keys %$c) { - - # consolidate all -and nodes - if ($col =~ /^\-and$/i) { - push @{$fin->{-and}}, - ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} - : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} - : { $col => $c->{$col} } - ; - } - elsif ($col =~ /^\-/) { - push @{$fin->{-and}}, { $col => $c->{$col} }; - } - elsif (exists $fin->{$col}) { - $fin->{$col} = [ -and => map { - (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) - ? @{$_}[1..$#$_] - : $_ - ; - } ($fin->{$col}, $c->{$col}) ]; - } - else { - $fin->{$col} = $c->{$col}; - } - } - } - } - } - elsif (ref $where eq 'ARRAY') { - # we are always at top-level here, it is safe to dump empty *standalone* pieces - my $fin_idx; - - for (my $i = 0; $i <= $#$where; $i++ ) { - - # Match SQLA 1.79 behavior - $self->throw_exception( - "Supplying an empty left hand side argument is not supported in array-pairs" - ) if (! defined $where->[$i] or ! length $where->[$i]); - - my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); - - if ($logic_mod) { - $i++; - $self->throw_exception("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") - unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; - - my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] }) - or next; - - my @keys = keys %$sub_elt; - if ( @keys == 1 and $keys[0] !~ /^\-/ ) { - $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; - } - else { - $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; - } - } - elsif (! length ref $where->[$i] ) { - my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] }) - or next; - - $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; - $i++; - } - else { - $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next; - } - } - - if (! $fin_idx) { - return; - } - elsif ( keys %$fin_idx == 1 ) { - $fin = (values %$fin_idx)[0]; - } - else { - my @or; - - # at this point everything is at most one level deep - unroll if needed - for (sort keys %$fin_idx) { - if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { - my ($l, $r) = %{$fin_idx->{$_}}; - - if ( - ref $r eq 'ARRAY' - and - ( - ( @$r == 1 and $l =~ /^\-and$/i ) - or - $l =~ /^\-or$/i - ) - ) { - push @or, @$r - } - - elsif ( - ref $r eq 'HASH' - and - keys %$r == 1 - and - $l =~ /^\-(?:and|or)$/i - ) { - push @or, %$r; - } - - else { - push @or, $l, $r; - } - } - else { - push @or, $fin_idx->{$_}; - } - } - - $fin->{-or} = \@or; - } - } - else { - # not a hash not an array - $fin = { -and => [ $where ] }; - } - - # unroll single-element -and's - while ( - $fin->{-and} - and - @{$fin->{-and}} < 2 - ) { - my $and = delete $fin->{-and}; - last if @$and == 0; - - # at this point we have @$and == 1 - if ( - ref $and->[0] eq 'HASH' - and - ! grep { exists $fin->{$_} } keys %{$and->[0]} - ) { - $fin = { - %$fin, %{$and->[0]} - }; - } - else { - $fin->{-and} = $and; - last; - } - } +sub _collapse_cond :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_collapse_cond() is deprecated, ask on IRC for a better alternative"); - # compress same-column conds found in $fin - for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { - next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; - my $val_bag = { map { - (! defined $_ ) ? ( UNDEF => undef ) - : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) - : ( ( 'SER_' . serialize $_ ) => $_ ) - } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; - - if (keys %$val_bag == 1 ) { - ($fin->{$col}) = values %$val_bag; - } - else { - $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; - } - } - - return keys %$fin ? $fin : (); + shift; + DBIx::Class::SQLMaker::Util::normalize_sqla_condition(@_); } -sub _collapse_cond_unroll_pairs { - my ($self, $pairs) = @_; - - my @conds; - - while (@$pairs) { - my ($lhs, $rhs) = splice @$pairs, 0, 2; - - if (! length $lhs) { - push @conds, $self->_collapse_cond($rhs); - } - elsif ( $lhs =~ /^\-and$/i ) { - push @conds, $self->_collapse_cond($rhs, (ref $rhs eq 'ARRAY')); - } - elsif ( $lhs =~ /^\-or$/i ) { - push @conds, $self->_collapse_cond( - (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs - ); - } - else { - if (ref $rhs eq 'HASH' and ! keys %$rhs) { - # FIXME - SQLA seems to be doing... nothing...? - } - # normalize top level -ident, for saner extract_fixed_condition_columns code - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { - push @conds, { $lhs => { '=', $rhs } }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-value} and is_plain_value $rhs->{-value}) { - push @conds, { $lhs => $rhs->{-value} }; - } - elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { - if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { - push @conds, { $lhs => $rhs }; - } - else { - for my $p ($self->_collapse_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { - - # extra sanity check - if (keys %$p > 1) { - local $Data::Dumper::Deepcopy = 1; - $self->throw_exception( - "Internal error: unexpected collapse unroll:" - . dump_value { in => { $lhs => $rhs }, out => $p } - ); - } - - my ($l, $r) = %$p; - - push @conds, ( - ! length ref $r - or - # the unroller recursion may return a '=' prepended value already - ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} - or - is_plain_value($r) - ) - ? { $l => $r } - : { $l => { '=' => $r } } - ; - } - } - } - elsif (ref $rhs eq 'ARRAY') { - # some of these conditionals encounter multi-values - roll them out using - # an unshift, which will cause extra looping in the while{} above - if (! @$rhs ) { - push @conds, { $lhs => [] }; - } - elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { - $self->throw_exception("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") - if @$rhs == 1; - - if( $rhs->[0] =~ /^\-and$/i ) { - unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; - } - # if not an AND then it's an OR - elsif(@$rhs == 2) { - unshift @$pairs, $lhs => $rhs->[1]; - } - else { - push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; - } - } - elsif (@$rhs == 1) { - unshift @$pairs, $lhs => $rhs->[0]; - } - else { - push @conds, { $lhs => $rhs }; - } - } - # unroll func + { -value => ... } - elsif ( - ref $rhs eq 'HASH' - and - ( my ($subop) = keys %$rhs ) == 1 - and - length ref ((values %$rhs)[0]) - and - my $vref = is_plain_value( (values %$rhs)[0] ) - ) { - push @conds, { $lhs => { $subop => $$vref } } - } - else { - push @conds, { $lhs => $rhs }; - } - } - } - - return @conds; -} - -# Analyzes a given condition and attempts to extract all columns -# with a definitive fixed-condition criteria. Returns a hashref -# of k/v pairs suitable to be passed to set_columns(), with a -# MAJOR CAVEAT - multi-value (contradictory) equalities are still -# represented as a reference to the UNRESOVABLE_CONDITION constant -# The reason we do this is that some codepaths only care about the -# codition being stable, as opposed to actually making sense -# -# The normal mode is used to figure out if a resultset is constrained -# to a column which is part of a unique constraint, which in turn -# allows us to better predict how ordering will behave etc. -# -# With the optional "consider_nulls" boolean argument, the function -# is instead used to infer inambiguous values from conditions -# (e.g. the inheritance of resultset conditions on new_result) -# -sub _extract_fixed_condition_columns { - my ($self, $where, $consider_nulls) = @_; - my $where_hash = $self->_collapse_cond($_[1]); - - my $res = {}; - my ($c, $v); - for $c (keys %$where_hash) { - my $vals; - - if (!defined ($v = $where_hash->{$c}) ) { - $vals->{UNDEF} = $v if $consider_nulls - } - elsif ( - ref $v eq 'HASH' - and - keys %$v == 1 - ) { - if (exists $v->{-value}) { - if (defined $v->{-value}) { - $vals->{"VAL_$v->{-value}"} = $v->{-value} - } - elsif( $consider_nulls ) { - $vals->{UNDEF} = $v->{-value}; - } - } - # do not need to check for plain values - _collapse_cond did it for us - elsif( - length ref $v->{'='} - and - ( - ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) - or - is_literal_value($v->{'='}) - ) - ) { - $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; - } - } - elsif ( - ! length ref $v - or - is_plain_value ($v) - ) { - $vals->{"VAL_$v"} = $v; - } - elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { - for ( @{$v}[1..$#$v] ) { - my $subval = $self->_extract_fixed_condition_columns({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion - next unless exists $subval->{$c}; # didn't find anything - $vals->{ - ! defined $subval->{$c} ? 'UNDEF' - : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" - : ( 'SER_' . serialize $subval->{$c} ) - } = $subval->{$c}; - } - } - - if (keys %$vals == 1) { - ($res->{$c}) = (values %$vals) - unless !$consider_nulls and exists $vals->{UNDEF}; - } - elsif (keys %$vals > 1) { - $res->{$c} = UNRESOLVABLE_CONDITION; - } - } +sub _extract_fixed_condition_columns :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + carp_unique("_extract_fixed_condition_columns() is deprecated, ask on IRC for a better alternative"); - $res; + shift; + extract_equality_conditions(@_); } 1;