X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=1231a07c19145242320c630cfbfbf51b27a7bf87;hb=d009cb7d393292037eff527a9f8bab93860224fb;hp=defbe9aea8c0ab40efac21dda48894ca90f7c673;hpb=47dba3e30a261fec0bdbeac022c161183c876f49;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index defbe9a..1231a07 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -2,19 +2,20 @@ package DBIx::Class::ResultSet; use strict; use warnings; -use base qw/DBIx::Class/; + +use base 'DBIx::Class'; +use mro 'c3'; + 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 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 (); - BEGIN { # De-duplication in _merge_attr() is disabled, but left in for reference # (the merger is used for other things that ought not to be de-duped) @@ -442,7 +443,7 @@ sub search_rs { $call_cond = shift; } # fish out attrs in the ($condref, $attr) case - elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) { + elsif (@_ == 2 and ( ! defined $_[0] or length ref $_[0] ) ) { ($call_cond, $call_attrs) = @_; } elsif (@_ % 2) { @@ -456,7 +457,7 @@ sub search_rs { for my $i (0 .. $#_) { next if $i % 2; $self->throw_exception ('All keys in condition key/value pairs must be plain scalars') - if (! defined $_[$i] or ref $_[$i] ne ''); + if (! defined $_[$i] or length ref $_[$i] ); } $call_cond = { @_ }; @@ -465,7 +466,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 @@ -489,9 +490,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 @@ -553,7 +553,6 @@ sub search_rs { return $rs; } -my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; @@ -618,11 +617,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; } @@ -843,7 +841,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, @@ -878,12 +876,12 @@ sub find { join "\x00", sort $rsrc->unique_constraint_columns($c_name) }++; - try { + 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 ); @@ -1414,7 +1412,7 @@ sub _construct_results { : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' ), ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) - ); + ) . '; 1' or die; } } else { @@ -1424,60 +1422,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); - - if (my $check_non_null_cols = $self->{_row_parser}{$parser_type}{nullcheck} ) { + unless( $self->{_row_parser}{$parser_type}{cref} ) { - $err = - 'Collapse aborted due to invalid ResultSource metadata - the following ' - . 'selections are declared non-nullable but NULLs were retrieved: ' - ; + # $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); - my @violating_idx; - COL: for my $i (@$check_non_null_cols) { - ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; - } + $self->{_row_parser}{$parser_type}{cref} = do { + package # hide form PAUSE + DBIx::Class::__GENERATED_ROW_PARSER__; - $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 @@ -1486,9 +1454,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 @@ -1903,7 +1887,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) @@ -2234,6 +2218,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); @@ -2241,7 +2227,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 @@ -2251,7 +2237,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; @@ -2265,7 +2251,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); @@ -3220,10 +3205,16 @@ Returns a related resultset for the supplied relationship name. =cut sub related_resultset { - my ($self, $rel) = @_; + $_[0]->throw_exception( + 'Extra arguments to $rs->related_resultset() were always quietly ' + . 'discarded without consideration, you need to switch to ' + . '...->related_resultset( $relname )->search_rs( $search, $args ) instead.' + ) if @_ > 2; - return $self->{related_resultsets}{$rel} - if defined $self->{related_resultsets}{$rel}; + return $_[0]->{related_resultsets}{$_[1]} + if defined $_[0]->{related_resultsets}{$_[1]}; + + my ($self, $rel) = @_; return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; @@ -3236,22 +3227,25 @@ sub related_resultset { my $attrs = $self->_chain_relationship($rel); - my $join_count = $attrs->{seen_join}{$rel}; + my $storage = $rsrc->schema->storage; - my $alias = $self->result_source->storage - ->relname_to_table_alias($rel, $join_count); + # Previously this atribute was deleted (instead of being set as it is now) + # Doing so seems to be harmless in all available test permutations + # See also 01d59a6a6 and mst's comment below + # + $attrs->{alias} = $storage->relname_to_table_alias( + $rel, + $attrs->{seen_join}{$rel} + ); # since this is search_related, and we already slid the select window inwards # (the select/as attrs were deleted in the beginning), we need to flip all # left joins to inner, so we get the expected results # read the comment on top of the actual function to see what this does - $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias); - + $attrs->{from} = $storage->_inner_join_to_node( $attrs->{from}, $attrs->{alias} ); #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi - delete @{$attrs}{qw(result_class alias)}; - - my $rel_source = $rsrc->related_source($rel); + delete $attrs->{result_class}; my $new = do { @@ -3260,16 +3254,19 @@ sub related_resultset { # source you need to know what alias it's -going- to have for things # to work sanely (e.g. RestrictWithObject wants to be able to add # extra query restrictions, and these may need to be $alias.) - - my $rel_attrs = $rel_source->resultset_attributes; - local $rel_attrs->{alias} = $alias; - - $rel_source->resultset - ->search_rs( - undef, { - %$attrs, - where => $attrs->{where}, - }); + # -- mst ~ 2007 (01d59a6a6) + # + # FIXME - this seems to be no longer neccessary (perhaps due to the + # advances in relcond resolution. Testing DBIC::S::RWO and its only + # dependent (as of Jun 2015 ) does not yield any difference with or + # without this line. Nevertheless keep it as is for now, to minimize + # churn, there is enough potential for breakage in 0.0829xx as it is + # -- ribasushi Jun 2015 + # + my $rel_source = $rsrc->related_source($rel); + local $rel_source->resultset_attributes->{alias} = $attrs->{alias}; + + $rel_source->resultset->search_rs( undef, $attrs ); }; if (my $cache = $self->get_cache) { @@ -3519,9 +3516,22 @@ sub _resolved_attrs { $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported") if $attrs->{collapse} and $attrs->{distinct}; + + # Sanity check the paging attributes + # SQLMaker does it too, but in case of a software_limit we'll never get there + if (defined $attrs->{offset}) { + $self->throw_exception('A supplied offset attribute must be a non-negative integer') + if ( $attrs->{offset} =~ /[^0-9]/ or $attrs->{offset} < 0 ); + } + if (defined $attrs->{rows}) { + $self->throw_exception("The rows attribute must be a positive integer if present") + if ( $attrs->{rows} =~ /[^0-9]/ or $attrs->{rows} <= 0 ); + } + + # 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/) { @@ -3682,7 +3692,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; } @@ -3912,7 +3922,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 { @@ -3925,7 +3935,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 { @@ -3938,7 +3948,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] ]; }, }, @@ -3953,7 +3963,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 { @@ -4620,7 +4630,7 @@ revisit rows in your ResultSet: ... do stuff ... } - $rs->first; # without cache, this would issue a query + $resultset->first; # without cache, this would issue a query By default, searches are not cached.