X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=43383926ca3835ddcdeca62759d855f47d4402d0;hb=e2741c7fd695dca054614f297b01d351a45bbf38;hp=0a6c002c7713ba69d4fb77351ae4a767683f06eb;hpb=ddcc02d14d03169c54c65db9f0f446836483ba55;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0a6c002..4338392 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2,19 +2,18 @@ package DBIx::Class::ResultSet; use strict; use warnings; -use base qw/DBIx::Class/; + +use base 'DBIx::Class'; + use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultClass::HashRefInflator; -use Scalar::Util qw/blessed weaken reftype/; +use Scalar::Util qw( blessed reftype ); use DBIx::Class::_Util qw( - dbic_internal_try + dbic_internal_try dbic_internal_catch dump_value fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION ); -use Try::Tiny; - -# not importing first() as it will clash with our own method -use List::Util (); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference @@ -466,7 +465,7 @@ sub search_rs { # see if we can keep the cache (no $rs changes) my $cache; my %safe = (alias => 1, cache => 1); - if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and ( + if ( ! grep { !$safe{$_} } keys %$call_attrs and ( ! defined $call_cond or ref $call_cond eq 'HASH' && ! keys %$call_cond @@ -490,9 +489,8 @@ sub search_rs { my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; # reset the current selector list if new selectors are supplied - if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) { - delete @{$old_attrs}{(@selector_attrs, '_dark_selector')}; - } + delete @{$old_attrs}{(@selector_attrs, '_dark_selector')} + if grep { exists $call_attrs->{$_} } qw(columns cols select as); # Normalize the new selector list (operates on the passed-in attr structure) # Need to do it on every chain instead of only once on _resolved_attrs, in @@ -554,7 +552,6 @@ sub search_rs { return $rs; } -my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; @@ -619,11 +616,10 @@ sub _normalize_selection { else { $attrs->{_dark_selector} = { plus_stage => $pref, - string => ($dark_sel_dumper ||= do { - require Data::Dumper::Concise; - Data::Dumper::Concise::DumperObject()->Indent(0); - })->Values([$_])->Dump - , + string => do { + local $Data::Dumper::Indent = 0; + dump_value $_; + }, }; last SELECTOR; } @@ -657,17 +653,15 @@ sub _stack_cond { (ref $_ eq 'HASH' and ! keys %$_) ) and $_ = undef for ($left, $right); - # either one of the two undef - if ( (defined $left) xor (defined $right) ) { - return defined $left ? $left : $right; - } - # both undef - elsif ( ! defined $left ) { - return undef - } - else { - return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); - } + return( + # either one of the two undef + ( (defined $left) xor (defined $right) ) ? ( defined $left ? $left : $right ) + + # both undef + : ( ! defined $left ) ? undef + + : { -and => [$left, $right] } + ); } =head2 search_literal @@ -780,7 +774,7 @@ See also L and L. sub find { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $rsrc = $self->result_source; @@ -824,7 +818,7 @@ sub find { my $relinfo = $rsrc->relationship_info($key) and # implicitly skip has_many's (likely MC) - (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) + ( ref( my $val = delete $call_cond->{$key} ) ne 'ARRAY' ) ) { my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( $relinfo->{cond}, $val, $key, $key @@ -844,7 +838,7 @@ sub find { if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $constraint_name, values => ($self->_merge_with_rscond($call_cond))[0], carp_on_nulls => 1, @@ -881,15 +875,15 @@ sub find { dbic_internal_try { push @unique_queries, $self->_qualify_cond_columns( - $self->result_source->_minimal_valueset_satisfying_constraint( + $rsrc->_minimal_valueset_satisfying_constraint( constraint_name => $c_name, values => ($self->_merge_with_rscond($call_cond))[0], - columns_info => ($ci ||= $self->result_source->columns_info), + columns_info => ($ci ||= $rsrc->columns_info), ), $alias ); } - catch { + dbic_internal_catch { push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; }; } @@ -990,7 +984,8 @@ See also L. =cut -sub search_related { +sub search_related :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search(@_); } @@ -1001,7 +996,8 @@ it guarantees a resultset, even in list context. =cut -sub search_related_rs { +sub search_related_rs :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->related_resultset(shift)->search_rs(@_); } @@ -1025,7 +1021,7 @@ sub cursor { return $self->{cursor} ||= do { my $attrs = $self->_resolved_attrs; - $self->result_source->storage->select( + $self->result_source->schema->storage->select( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); }; @@ -1098,7 +1094,7 @@ sub single { } } - my $data = [ $self->result_source->storage->select_single( + my $data = [ $self->result_source->schema->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs )]; @@ -1125,9 +1121,7 @@ Returns a L instance for a column of the ResultSet =cut sub get_column { - my ($self, $column) = @_; - my $new = DBIx::Class::ResultSetColumn->new($self, $column); - return $new; + DBIx::Class::ResultSetColumn->new(@_); } =head2 search_like @@ -1167,7 +1161,7 @@ sub search_like { .' Instead use ->search({ x => { -like => "y%" } })' .' (note the outer pair of {}s - they are important!)' ); - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_}; $query->{$_} = { 'like' => $query->{$_} } for keys %$query; return $class->search($query, { %$attrs }); @@ -1415,7 +1409,7 @@ sub _construct_results { : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' ), ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) - ); + ) . '; 1' or die; } } else { @@ -1425,60 +1419,30 @@ sub _construct_results { : 'classic_nonpruning' ; - # $args and $attrs to _mk_row_parser are separated to delineate what is - # core collapser stuff and what is dbic $rs specific - @{$self->{_row_parser}{$parser_type}}{qw(cref nullcheck)} = $rsrc->_mk_row_parser({ - eval => 1, - inflate_map => $infmap, - collapse => $attrs->{collapse}, - premultiplied => $attrs->{_main_source_premultiplied}, - hri_style => $self->{_result_inflator}{is_hri}, - prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, - }, $attrs) unless $self->{_row_parser}{$parser_type}{cref}; - - # column_info metadata historically hasn't been too reliable. - # We need to start fixing this somehow (the collapse resolver - # can't work without it). Add an explicit check for the *main* - # result, hopefully this will gradually weed out such errors - # - # FIXME - this is a temporary kludge that reduces performance - # It is however necessary for the time being - my ($unrolled_non_null_cols_to_check, $err); + unless( $self->{_row_parser}{$parser_type}{cref} ) { - if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) { + # $args and $attrs to _mk_row_parser are separated to delineate what is + # core collapser stuff and what is dbic $rs specific + $self->{_row_parser}{$parser_type}{src} = $rsrc->_mk_row_parser({ + inflate_map => $infmap, + collapse => $attrs->{collapse}, + premultiplied => $attrs->{_main_source_premultiplied}, + hri_style => $self->{_result_inflator}{is_hri}, + prune_null_branches => $self->{_result_inflator}{is_hri} || $self->{_result_inflator}{is_core_row}, + }, $attrs); - $err = - 'Collapse aborted due to invalid ResultSource metadata - the following ' - . 'selections are declared non-nullable but NULLs were retrieved: ' - ; + $self->{_row_parser}{$parser_type}{cref} = do { + package # hide form PAUSE + DBIx::Class::__GENERATED_ROW_PARSER__; - my @violating_idx; - COL: for my $i (@$check_non_null_cols) { - ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; - } - - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - if @violating_idx; - - $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); - - utf8::upgrade($unrolled_non_null_cols_to_check) - if DBIx::Class::_ENV_::STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE; + eval $self->{_row_parser}{$parser_type}{src}; + } || die $@; } - my $next_cref = - ($did_fetch_all or ! $attrs->{collapse}) ? undef - : defined $unrolled_non_null_cols_to_check ? eval sprintf <<'EOS', $unrolled_non_null_cols_to_check -sub { - # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref - my @r = $cursor->next or return; - if (my @violating_idx = grep { ! defined $r[$_] } (%s) ) { - $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) - } - \@r -} -EOS - : sub { + # this needs to close over the *current* cursor, hence why it is not cached above + my $next_cref = ($did_fetch_all or ! $attrs->{collapse}) + ? undef + : sub { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref my @r = $cursor->next or return; \@r @@ -1487,9 +1451,25 @@ EOS $self->{_row_parser}{$parser_type}{cref}->( $rows, - $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), + $next_cref, + ( $self->{_stashed_rows} = [] ), + ( my $null_violations = {} ), ); + $self->throw_exception( + 'Collapse aborted - the following columns are declared (or defaulted to) ' + . 'non-nullable within DBIC but NULLs were retrieved from storage: ' + . join( ', ', map { "'$infmap->[$_]'" } sort { $a <=> $b } keys %$null_violations ) + . ' within data row ' . dump_value({ + map { + $infmap->[$_] => + ( ! defined $self->{_stashed_rows}[0][$_] or length $self->{_stashed_rows}[0][$_] < 50 ) + ? $self->{_stashed_rows}[0][$_] + : substr( $self->{_stashed_rows}[0][$_], 0, 50 ) . '...' + } 0 .. $#{$self->{_stashed_rows}[0]} + }) + ) if keys %$null_violations; + # simple in-place substitution, does not regrow $rows if ($self->{_result_inflator}{is_core_row}) { $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows @@ -1666,7 +1646,7 @@ sub _count_rs { # overwrite the selector (supplied by the storage) $rsrc->resultset_class->new($rsrc, { %$tmp_attrs, - select => $rsrc->storage->_count_select ($rsrc, $attrs), + select => $rsrc->schema->storage->_count_select ($rsrc, $attrs), as => 'count', })->get_column ('count'); } @@ -1697,7 +1677,7 @@ sub _count_subq_rs { # Calculate subquery selector if (my $g = $sub_attrs->{group_by}) { - my $sql_maker = $rsrc->storage->sql_maker; + my $sql_maker = $rsrc->schema->storage->sql_maker; # necessary as the group_by may refer to aliased functions my $sel_index; @@ -1764,7 +1744,7 @@ sub _count_subq_rs { return $rsrc->resultset_class ->new ($rsrc, $sub_attrs) ->as_subselect_rs - ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } }) + ->search ({}, { columns => { count => $rsrc->schema->storage->_count_select ($rsrc, $attrs) } }) ->get_column ('count'); } @@ -1787,7 +1767,10 @@ with the passed arguments, then L. =cut -sub count_literal { shift->search_literal(@_)->count; } +sub count_literal :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->search_literal(@_)->count +} =head2 all @@ -1864,7 +1847,8 @@ an object for the first result (or C if the resultset is empty). =cut -sub first { +sub first :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return $_[0]->reset->next; } @@ -1904,7 +1888,7 @@ sub _rs_update_delete { $storage->_prune_unused_joins ($attrs); # any non-pruneable non-local restricting joins imply subq - $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; + $needs_subq = grep { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; } # check if the head is composite (by now all joins are thrown out unless $needs_subq) @@ -1921,7 +1905,7 @@ sub _rs_update_delete { # a condition containing 'me' or other table prefixes will not work # at all. Tell SQLMaker to dequalify idents via a gross hack. $cond = do { - my $sqla = $rsrc->storage->sql_maker; + my $sqla = $rsrc->schema->storage->sql_maker; local $sqla->{_dequalify_idents} = 1; \[ $sqla->_recurse_where($self->{cond}) ]; }; @@ -2235,6 +2219,8 @@ sub populate { # FIXME - no cref handling # At this point assume either hashes or arrays + my $rsrc = $self->result_source; + if(defined wantarray) { my (@results, $guard); @@ -2242,7 +2228,7 @@ sub populate { # column names only, nothing to do return if @$data == 1; - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $rsrc->schema->storage->txn_scope_guard if @$data > 2; @results = map @@ -2252,7 +2238,7 @@ sub populate { } else { - $guard = $self->result_source->schema->storage->txn_scope_guard + $guard = $rsrc->schema->storage->txn_scope_guard if @$data > 1; @results = map { $self->new_result($_)->insert } @$data; @@ -2266,7 +2252,6 @@ sub populate { # this means we have to walk the data structure twice # whether we want this or not # jnap, I hate you ;) - my $rsrc = $self->result_source; my $rel_info = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; my ($colinfo, $colnames, $slices_with_rels); @@ -2429,7 +2414,7 @@ sub populate { ### main source data # FIXME - need to switch entirely to a coderef-based thing, # so that large sets aren't copied several times... I think - $rsrc->storage->_insert_bulk( + $rsrc->schema->storage->_insert_bulk( $rsrc, [ @$colnames, sort keys %$rs_data ], [ map { @@ -2580,11 +2565,8 @@ Passes the hashref of input on to L. sub new_result { my ($self, $values) = @_; - $self->throw_exception( "new_result takes only one argument - a hashref of values" ) - if @_ > 2; - - $self->throw_exception( "Result object instantiation requires a hashref as argument" ) - unless (ref $values eq 'HASH'); + $self->throw_exception( "Result object instantiation requires a single hashref argument" ) + if @_ > 2 or ref $values ne 'HASH'; my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2634,7 +2616,7 @@ sub _merge_with_rscond { @cols_from_relations = keys %{ $implied_data || {} }; } else { - my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); + my $eqs = extract_equality_conditions( $self->{cond}, 'consider_nulls' ); $implied_data = { map { ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) } keys %$eqs }; @@ -2748,7 +2730,7 @@ sub as_query { my $attrs = { %{ $self->_resolved_attrs } }; - my $aq = $self->result_source->storage->_select_args_to_query ( + my $aq = $self->result_source->schema->storage->_select_args_to_query ( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); @@ -2794,7 +2776,7 @@ all in the call to C, even when set to C. sub find_or_new { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -2883,7 +2865,7 @@ L. =cut -sub create { +sub create :DBIC_method_is_indirect_sugar { #my ($self, $col_data) = @_; DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; return shift->new_result(shift)->insert; @@ -2963,7 +2945,7 @@ database! sub find_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; @@ -3029,7 +3011,7 @@ database! sub update_or_create { my $self = shift; - my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $attrs = (@_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {}); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find($cond, $attrs); @@ -3092,7 +3074,7 @@ See also L, L and L. sub update_or_new { my $self = shift; - my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} ); + my $attrs = ( @_ > 1 && ref $_[-1] eq 'HASH' ? pop(@_) : {} ); my $cond = ref $_[0] eq 'HASH' ? shift : {@_}; my $row = $self->find( $cond, $attrs ); @@ -3201,7 +3183,7 @@ sub is_paged { sub is_ordered { my ($self) = @_; - return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by}); + return scalar $self->result_source->schema->storage->_extract_order_criteria($self->{attrs}{order_by}); } =head2 related_resultset @@ -3544,10 +3526,13 @@ sub _resolved_attrs { if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 ); } + # normalize where condition + $attrs->{where} = normalize_sqla_condition( $attrs->{where} ) + if $attrs->{where}; # default selection list $attrs->{columns} = [ $source->columns ] - unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/; + unless grep { exists $attrs->{$_} } qw/columns cols select as/; # merge selectors together for (qw/columns select as/) { @@ -3708,7 +3693,7 @@ sub _resolved_attrs { if ( ! $attrs->{_main_source_premultiplied} and - ! List::Util::first { ! $_->[0]{-is_single} } @fromlist + ! grep { ! $_->[0]{-is_single} } @fromlist ) { $attrs->{collapse} = 0; } @@ -3730,7 +3715,7 @@ sub _resolved_attrs { else { $attrs->{_grouped_by_distinct} = 1; # distinct affects only the main selection part, not what prefetch may add below - ($attrs->{group_by}, my $new_order) = $source->storage->_group_over_selection($attrs); + ($attrs->{group_by}, my $new_order) = $source->schema->storage->_group_over_selection($attrs); # FIXME possibly ignore a rewritten order_by (may turn out to be an issue) # The thinking is: if we are collapsing the subquerying prefetch engine will @@ -3938,7 +3923,7 @@ sub _merge_joinpref_attr { }, ARRAY => sub { return $_[1] if !defined $_[0]; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [$_[0], @{$_[1]}] }, HASH => sub { @@ -3951,7 +3936,7 @@ sub _merge_joinpref_attr { ARRAY => { SCALAR => sub { return $_[0] if !defined $_[1]; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [@{$_[0]}, $_[1]] }, ARRAY => sub { @@ -3964,7 +3949,7 @@ sub _merge_joinpref_attr { HASH => sub { return [ $_[1] ] if ! @{$_[0]}; return $_[0] if !keys %{$_[1]}; - return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return $_[0] if __HM_DEDUP and grep { $_ eq $_[1] } @{$_[0]}; return [ @{$_[0]}, $_[1] ]; }, }, @@ -3979,7 +3964,7 @@ sub _merge_joinpref_attr { return [] if !keys %{$_[0]} and !@{$_[1]}; return [ $_[0] ] if !@{$_[1]}; return $_[1] if !keys %{$_[0]}; - return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return $_[1] if __HM_DEDUP and grep { $_ eq $_[0] } @{$_[1]}; return [ $_[0], @{$_[1]} ]; }, HASH => sub {