X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=3d1a3a154e63127b7df0d0559931b62f2601f45c;hb=8bb3f33907790bf19e86e7e10280636b6818c113;hp=cedb9820255c8e1ff7654c2aae705a685f8e469a;hpb=56653891210c588f8b894ef4968ac6476ca3325d;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index cedb982..3d1a3a1 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -5,9 +5,12 @@ use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; +use DBIx::Class::ResultClass::HashRefInflator; use Scalar::Util qw/blessed weaken reftype/; +use DBIx::Class::_Util qw( + fail_on_internal_wantarray fail_on_internal_call UNRESOLVABLE_CONDITION +); use Try::Tiny; -use Data::Compare (); # no imports!!! guard against insane architecture # not importing first() as it will clash with our own method use List::Util (); @@ -56,7 +59,7 @@ just stores all the conditions needed to create the query. A basic ResultSet representing the data of an entire table is returned by calling C on a L and passing in a -L name. +L name. my $users_rs = $schema->resultset('User'); @@ -77,34 +80,6 @@ However, if it is used in a boolean context it is B true. So if you want to check if a resultset has any results, you must use C. -=head1 CUSTOM ResultSet CLASSES THAT USE Moose - -If you want to make your custom ResultSet classes with L, use a template -similar to: - - package MyApp::Schema::ResultSet::User; - - use Moose; - use namespace::autoclean; - use MooseX::NonMoose; - extends 'DBIx::Class::ResultSet'; - - sub BUILDARGS { $_[2] } - - ...your code... - - __PACKAGE__->meta->make_immutable; - - 1; - -The L is necessary so that the L constructor does not -clash with the regular ResultSet constructor. Alternatively, you can use: - - __PACKAGE__->meta->make_immutable(inline_constructor => 0); - -The L is necessary because the -signature of the ResultSet C is C<< ->new($source, \%args) >>. - =head1 EXAMPLES =head2 Chaining resultsets @@ -141,8 +116,8 @@ another. =head3 Resolving conditions and attributes -When a resultset is chained from another resultset (ie: -Csearch(\%extra_cond, \%attrs)>), conditions +When a resultset is chained from another resultset (e.g.: +C<< my $new_rs = $old_rs->search(\%extra_cond, \%attrs) >>), conditions and attributes with the same keys need resolving. If any of L, L, L are present, they reset the @@ -192,6 +167,93 @@ Which is the same as: See: L, L, L, L, L. +=head2 Custom ResultSet classes + +To add methods to your resultsets, you can subclass L, similar to: + + package MyApp::Schema::ResultSet::User; + + use strict; + use warnings; + + use base 'DBIx::Class::ResultSet'; + + sub active { + my $self = shift; + $self->search({ $self->current_source_alias . '.active' => 1 }); + } + + sub unverified { + my $self = shift; + $self->search({ $self->current_source_alias . '.verified' => 0 }); + } + + sub created_n_days_ago { + my ($self, $days_ago) = @_; + $self->search({ + $self->current_source_alias . '.create_date' => { + '<=', + $self->result_source->schema->storage->datetime_parser->format_datetime( + DateTime->now( time_zone => 'UTC' )->subtract( days => $days_ago ) + )} + }); + } + + sub users_to_warn { shift->active->unverified->created_n_days_ago(7) } + + 1; + +See L on how DBIC can discover and +automatically attach L-specific +L classes. + +=head3 ResultSet subclassing with Moose and similar constructor-providers + +Using L or L in your ResultSet classes is usually overkill, but +you may find it useful if your ResultSets contain a lot of business logic +(e.g. C, C, etc) or if you just prefer to organize +your code via roles. + +In order to write custom ResultSet classes with L you need to use the +following template. The L is necessary due to the +unusual signature of the L C<< ->new($source, \%args) >>. + + use Moo; + extends 'DBIx::Class::ResultSet'; + sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_ + + ...your code... + + 1; + +If you want to build your custom ResultSet classes with L, you need +a similar, though a little more elaborate template in order to interface the +inlining of the L-provided +L, +with the DBIC one. + + package MyApp::Schema::ResultSet::User; + + use Moose; + use MooseX::NonMoose; + extends 'DBIx::Class::ResultSet'; + + sub BUILDARGS { $_[2] } # ::RS::new() expects my ($class, $rsrc, $args) = @_ + + ...your code... + + __PACKAGE__->meta->make_immutable; + + 1; + +The L is necessary so that the L constructor does not +entirely overwrite the DBIC one (in contrast L does this automatically). +Alternatively, you can skip L and get by with just L +instead by doing: + + __PACKAGE__->meta->make_immutable(inline_constructor => 0); + =head1 METHODS =head2 new @@ -239,12 +301,18 @@ creation B. See also warning pertaining to L. sub new { my $class = shift; - return $class->new_result(@_) if ref $class; + + if (ref $class) { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return $class->new_result(@_); + } my ($source, $attrs) = @_; $source = $source->resolve if $source->isa('DBIx::Class::ResultSourceHandle'); + $attrs = { %{$attrs||{}} }; + delete @{$attrs}{qw(_last_sqlmaker_alias_map _simple_passthrough_construction)}; if ($attrs->{page}) { $attrs->{rows} ||= 10; @@ -302,8 +370,8 @@ call it as C. For a list of attributes that can be passed to C, see L. For more examples of using this function, see -L. For a complete -documentation for the first argument, see L +L. For a complete +documentation for the first argument, see L and its extension L. For more help on using joins with search, see L. @@ -325,6 +393,7 @@ sub search { my $rs = $self->search_rs( @_ ); if (wantarray) { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; return $rs->all; } elsif (defined wantarray) { @@ -407,8 +476,7 @@ sub search_rs { } my $old_attrs = { %{$self->{attrs}} }; - my $old_having = delete $old_attrs->{having}; - my $old_where = delete $old_attrs->{where}; + my ($old_having, $old_where) = delete @{$old_attrs}{qw(having where)}; my $new_attrs = { %$old_attrs }; @@ -443,6 +511,7 @@ sub search_rs { # older deprecated name, use only if {columns} is not there if (my $c = delete $new_attrs->{cols}) { + carp_unique( "Resultset attribute 'cols' is deprecated, use 'columns' instead" ); if ($new_attrs->{columns}) { carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'"; } @@ -489,8 +558,12 @@ sub _normalize_selection { my ($self, $attrs) = @_; # legacy syntax - $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns}) - if exists $attrs->{include_columns}; + if ( exists $attrs->{include_columns} ) { + carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" ); + $attrs->{'+columns'} = $self->_merge_attr( + $attrs->{'+columns'}, delete $attrs->{include_columns} + ); + } # columns are always placed first, however @@ -577,59 +650,22 @@ sub _normalize_selection { sub _stack_cond { my ($self, $left, $right) = @_; - # collapse single element top-level conditions - # (single pass only, unlikely to need recursion) - for ($left, $right) { - if (ref $_ eq 'ARRAY') { - if (@$_ == 0) { - $_ = undef; - } - elsif (@$_ == 1) { - $_ = $_->[0]; - } - } - elsif (ref $_ eq 'HASH') { - my ($first, $more) = keys %$_; - - # empty hash - if (! defined $first) { - $_ = undef; - } - # one element hash - elsif (! defined $more) { - if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') { - $_ = $_->{'-and'}; - } - elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') { - $_ = $_->{'-or'}; - } - } - } - } - - # merge hashes with weeding out of duplicates (simple cases only) - if (ref $left eq 'HASH' and ref $right eq 'HASH') { - - # shallow copy to destroy - $right = { %$right }; - for (grep { exists $right->{$_} } keys %$left) { - # the use of eq_deeply here is justified - the rhs of an - # expression can contain a lot of twisted weird stuff - delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} ); - } - - $right = undef unless keys %$right; - } - + ( + (ref $_ eq 'ARRAY' and !@$_) + or + (ref $_ eq 'HASH' and ! keys %$_) + ) and $_ = undef for ($left, $right); - if (defined $left xor defined $right) { + # either one of the two undef + if ( (defined $left) xor (defined $right) ) { return defined $left ? $left : $right; } - elsif (! defined $left) { - return undef; + # both undef + elsif ( ! defined $left ) { + return undef } else { - return { -and => [ $left, $right ] }; + return $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); } } @@ -640,7 +676,7 @@ should only be used in that context. C is a convenience method. It is equivalent to calling C<< $schema->search(\[]) >>, but if you want to ensure columns are bound correctly, use L. -See L and +See L and L for searching techniques that do not require C. @@ -776,40 +812,41 @@ sub find { . "corresponding to the columns of the specified unique constraint '$constraint_name'" ) unless @c_cols == @_; - $call_cond = {}; @{$call_cond}{@c_cols} = @_; } - my %related; + # process relationship data if any for my $key (keys %$call_cond) { if ( - my $keyref = ref($call_cond->{$key}) + length ref($call_cond->{$key}) and my $relinfo = $rsrc->relationship_info($key) + and + # implicitly skip has_many's (likely MC) + (ref (my $val = delete $call_cond->{$key}) ne 'ARRAY' ) ) { - my $val = delete $call_cond->{$key}; - - next if $keyref eq 'ARRAY'; # has_many for multi_create - - my $rel_q = $rsrc->_resolve_condition( + my ($rel_cond, $crosstable) = $rsrc->_resolve_condition( $relinfo->{cond}, $val, $key, $key ); - die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH'; - @related{keys %$rel_q} = values %$rel_q; + + $self->throw_exception("Complex condition via relationship '$key' is unsupported in find()") + if $crosstable or ref($rel_cond) ne 'HASH'; + + # supplement condition + # relationship conditions take precedence (?) + @{$call_cond}{keys %$rel_cond} = values %$rel_cond; } } - # relationship conditions take precedence (?) - @{$call_cond}{keys %related} = values %related; - my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias}; my $final_cond; if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( - $self->_build_unique_cond ( - $constraint_name, - $call_cond, + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $constraint_name, + values => ($self->_merge_with_rscond($call_cond))[0], + carp_on_nulls => 1, ), $alias, @@ -824,23 +861,42 @@ sub find { # relationship } else { + my (@unique_queries, %seen_column_combinations, $ci, @fc_exceptions); + # no key was specified - fall down to heuristics mode: # run through all unique queries registered on the resultset, and # 'OR' all qualifying queries together - my (@unique_queries, %seen_column_combinations); - for my $c_name ($rsrc->unique_constraint_names) { + # + # always start from 'primary' if it exists at all + for my $c_name ( sort { + $a eq 'primary' ? -1 + : $b eq 'primary' ? 1 + : $a cmp $b + } $rsrc->unique_constraint_names) { + next if $seen_column_combinations{ join "\x00", sort $rsrc->unique_constraint_columns($c_name) }++; - push @unique_queries, try { - $self->_build_unique_cond ($c_name, $call_cond, 'croak_on_nulls') - } || (); + try { + push @unique_queries, $self->_qualify_cond_columns( + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $c_name, + values => ($self->_merge_with_rscond($call_cond))[0], + columns_info => ($ci ||= $self->result_source->columns_info), + ), + $alias + ); + } + catch { + push @fc_exceptions, $_ if $_ =~ /\bFilterColumn\b/; + }; } - $final_cond = @unique_queries - ? [ map { $self->_qualify_cond_columns($_, $alias) } @unique_queries ] - : $self->_non_unique_find_fallback ($call_cond, $attrs) + $final_cond = + @unique_queries ? \@unique_queries + : @fc_exceptions ? $self->throw_exception(join "; ", map { $_ =~ /(.*) at .+ line \d+$/s } @fc_exceptions ) + : $self->_non_unique_find_fallback ($call_cond, $attrs) ; } @@ -893,51 +949,20 @@ sub _qualify_cond_columns { } sub _build_unique_cond { - my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_; - - my @c_cols = $self->result_source->unique_constraint_columns($constraint_name); - - # combination may fail if $self->{cond} is non-trivial - my ($final_cond) = try { - $self->_merge_with_rscond ($extra_cond) - } catch { - +{ %$extra_cond } - }; - - # trim out everything not in $columns - $final_cond = { map { - exists $final_cond->{$_} - ? ( $_ => $final_cond->{$_} ) - : () - } @c_cols }; - - if (my @missing = grep - { ! ($croak_on_null ? defined $final_cond->{$_} : exists $final_cond->{$_}) } - (@c_cols) - ) { - $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s", - $constraint_name, - join (', ', map { "'$_'" } @missing), - ) ); - } - - if ( - !$croak_on_null - and - !$ENV{DBIC_NULLABLE_KEY_NOWARN} - and - my @undefs = sort grep { ! defined $final_cond->{$_} } (keys %$final_cond) - ) { - carp_unique ( sprintf ( - "NULL/undef values supplied for requested unique constraint '%s' (NULL " - . 'values in column(s): %s). This is almost certainly not what you wanted, ' - . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', - $constraint_name, - join (', ', map { "'$_'" } @undefs), - )); - } - - return $final_cond; + carp_unique sprintf + '_build_unique_cond is a private method, and moreover is about to go ' + . 'away. Please contact the development team at %s if you believe you ' + . 'have a genuine use for this method, in order to discuss alternatives.', + DBIx::Class::_ENV_::HELP_URL, + ; + + my ($self, $constraint_name, $cond, $croak_on_null) = @_; + + $self->result_source->_minimal_valueset_satisfying_constraint( + constraint_name => $constraint_name, + values => $cond, + carp_on_nulls => !$croak_on_null + ); } =head2 search_related @@ -998,7 +1023,7 @@ sub cursor { my $self = shift; return $self->{cursor} ||= do { - my $attrs = { %{$self->_resolved_attrs } }; + my $attrs = $self->_resolved_attrs; $self->result_source->storage->select( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs ); @@ -1057,7 +1082,7 @@ sub single { my $attrs = { %{$self->_resolved_attrs} }; $self->throw_exception( - 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' + 'single() can not be used on resultsets collapsing a has_many. Use find( \%cond ) or next() instead' ) if $attrs->{collapse}; if ($where) { @@ -1076,44 +1101,12 @@ sub single { $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs )]; + return undef unless @$data; $self->{_stashed_rows} = [ $data ]; $self->_construct_results->[0]; } - -# _collapse_query -# -# Recursively collapse the query, accumulating values for each column. - -sub _collapse_query { - my ($self, $query, $collapsed) = @_; - - $collapsed ||= {}; - - if (ref $query eq 'ARRAY') { - foreach my $subquery (@$query) { - next unless ref $subquery; # -or - $collapsed = $self->_collapse_query($subquery, $collapsed); - } - } - elsif (ref $query eq 'HASH') { - if (keys %$query and (keys %$query)[0] eq '-and') { - foreach my $subquery (@{$query->{-and}}) { - $collapsed = $self->_collapse_query($subquery, $collapsed); - } - } - else { - foreach my $col (keys %$query) { - my $value = $query->{$col}; - $collapsed->{$col}{$value}++; - } - } - } - - return $collapsed; -} - =head2 get_column =over 4 @@ -1155,7 +1148,7 @@ You most likely want to use L with specific operators. For more information, see L. -This method is deprecated and will be removed in 0.09. Use L +This method is deprecated and will be removed in 0.09. Use L instead. An example conversion is: ->search_like({ foo => 'bar' }); @@ -1204,8 +1197,6 @@ sub slice { $attrs->{offset} += $min; $attrs->{rows} = ($max ? ($max - $min + 1) : 1); return $self->search(undef, $attrs); - #my $slice = (ref $self)->new($self->result_source, $attrs); - #return (wantarray ? $slice->all : $slice); } =head2 next @@ -1277,57 +1268,51 @@ sub _construct_results { my $rsrc = $self->result_source; my $attrs = $self->_resolved_attrs; - if (!$fetch_all and ! $attrs->{order_by} and $attrs->{collapse}) { + if ( + ! $fetch_all + and + ! $attrs->{order_by} + and + $attrs->{collapse} + and + my @pcols = $rsrc->primary_columns + ) { # default order for collapsing unless the user asked for something - $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} $rsrc->primary_columns ]; + $attrs->{order_by} = [ map { join '.', $attrs->{alias}, $_} @pcols ]; $attrs->{_ordered_for_collapse} = 1; $attrs->{_order_is_artificial} = 1; } - my $cursor = $self->cursor; - # this will be used as both initial raw-row collector AND as a RV of # _construct_results. Not regrowing the array twice matters a lot... # a surprising amount actually my $rows = delete $self->{_stashed_rows}; + my $cursor; # we may not need one at all + + my $did_fetch_all = $fetch_all; + if ($fetch_all) { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref - $rows = [ ($rows ? @$rows : ()), $cursor->all ]; + $rows = [ ($rows ? @$rows : ()), $self->cursor->all ]; } elsif( $attrs->{collapse} ) { - $attrs->{_ordered_for_collapse} = (!$attrs->{order_by}) ? 0 : do { - my $st = $rsrc->schema->storage; - my @ord_cols = map - { $_->[0] } - ( $st->_extract_order_criteria($attrs->{order_by}) ) - ; + # a cursor will need to be closed over in case of collapse + $cursor = $self->cursor; - my $colinfos = $st->_resolve_column_info($attrs->{from}, \@ord_cols); - - for (0 .. $#ord_cols) { - if ( - ! $colinfos->{$ord_cols[$_]} - or - $colinfos->{$ord_cols[$_]}{-result_source} != $rsrc - ) { - splice @ord_cols, $_; - last; - } - } - - # since all we check here are the start of the order_by belonging to the - # top level $rsrc, a present identifying set will mean that the resultset - # is ordered by its leftmost table in a tsable manner - (@ord_cols and $rsrc->_identifying_column_set({ map - { $colinfos->{$_}{-colname} => $colinfos->{$_} } - @ord_cols - })) ? 1 : 0; - } unless defined $attrs->{_ordered_for_collapse}; + $attrs->{_ordered_for_collapse} = ( + ( + $attrs->{order_by} + and + $rsrc->schema + ->storage + ->_extract_colinfo_of_stable_main_source_order_by_portion($attrs) + ) ? 1 : 0 + ) unless defined $attrs->{_ordered_for_collapse}; if (! $attrs->{_ordered_for_collapse}) { - $fetch_all = 1; + $did_fetch_all = 1; # instead of looping over ->next, use ->all in stealth mode # *without* calling a ->reset afterwards @@ -1339,8 +1324,9 @@ sub _construct_results { } } - if (! $fetch_all and ! @{$rows||[]} ) { + if (! $did_fetch_all and ! @{$rows||[]} ) { # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + $cursor ||= $self->cursor; if (scalar (my @r = $cursor->next) ) { $rows = [ \@r ]; } @@ -1348,14 +1334,34 @@ sub _construct_results { return undef unless @{$rows||[]}; - my @extra_collapser_args; - if ($attrs->{collapse} and ! $fetch_all ) { + # sanity check - people are too clever for their own good + if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) { - @extra_collapser_args = ( - # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref - sub { my @r = $cursor->next or return; \@r }, # how the collapser gets more rows - ($self->{_stashed_rows} = []), # where does it stuff excess - ); + my $multiplied_selectors; + for my $sel_alias ( grep { $_ ne $attrs->{alias} } keys %{ $aliastypes->{selecting} } ) { + if ( + $aliastypes->{multiplying}{$sel_alias} + or + $aliastypes->{premultiplied}{$sel_alias} + ) { + $multiplied_selectors->{$_} = 1 for values %{$aliastypes->{selecting}{$sel_alias}{-seen_columns}} + } + } + + for my $i (0 .. $#{$attrs->{as}} ) { + my $sel = $attrs->{select}[$i]; + + if (ref $sel eq 'SCALAR') { + $sel = $$sel; + } + elsif( ref $sel eq 'REF' and ref $$sel eq 'ARRAY' ) { + $sel = $$sel->[0]; + } + + $self->throw_exception( + 'Result collapse not possible - selection from a has_many source redirected to the main object' + ) if ($multiplied_selectors->{$sel} and $attrs->{as}[$i] !~ /\./); + } } # hotspot - skip the setter @@ -1368,15 +1374,21 @@ sub _construct_results { my $infmap = $attrs->{as}; - $self->{_result_inflator}{is_hri} = do { ( $inflator_cref == ( - require DBIx::Class::ResultClass::HashRefInflator - && - DBIx::Class::ResultClass::HashRefInflator->can('inflate_result') - ) ) ? 1 : 0 - } unless defined $self->{_result_inflator}{is_hri}; + $self->{_result_inflator}{is_core_row} = ( ( + $inflator_cref + == + ( \&DBIx::Class::Row::inflate_result || die "No ::Row::inflate_result() - can't happen" ) + ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_core_row}; + + $self->{_result_inflator}{is_hri} = ( ( + ! $self->{_result_inflator}{is_core_row} + and + $inflator_cref == \&DBIx::Class::ResultClass::HashRefInflator::inflate_result + ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_hri}; + - if (! $attrs->{_related_results_construction}) { - # construct a much simpler array->hash folder for the one-table cases right here + if ($attrs->{_simple_passthrough_construction}) { + # construct a much simpler array->hash folder for the one-table HRI cases right here if ($self->{_result_inflator}{is_hri}) { for my $r (@$rows) { $r = { map { $infmap->[$_] => $r->[$_] } 0..$#$infmap }; @@ -1389,48 +1401,115 @@ sub _construct_results { # # crude unscientific benchmarking indicated the shortcut eval is not worth it for # this particular resultset size - elsif (@$rows < 60) { + elsif ( $self->{_result_inflator}{is_core_row} and @$rows < 60 ) { for my $r (@$rows) { $r = $inflator_cref->($res_class, $rsrc, { map { $infmap->[$_] => $r->[$_] } (0..$#$infmap) } ); } } else { eval sprintf ( - '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows', - join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) + ( $self->{_result_inflator}{is_core_row} + ? '$_ = $inflator_cref->($res_class, $rsrc, { %s }) for @$rows' + # a custom inflator may be a multiplier/reductor - put it in direct list ctx + : '@$rows = map { $inflator_cref->($res_class, $rsrc, { %s } ) } @$rows' + ), + ( join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) ) ); } } - # Special-case multi-object HRI (we always prune) - elsif ($self->{_result_inflator}{is_hri}) { - ( $self->{_row_parser}{hri} ||= $rsrc->_mk_row_parser({ - eval => 1, - inflate_map => $infmap, - selection => $attrs->{select}, - collapse => $attrs->{collapse}, - premultiplied => $attrs->{_main_source_premultiplied}, - hri_style => 1, - }) )->($rows, @extra_collapser_args); - } - # Regular multi-object else { + my $parser_type = + $self->{_result_inflator}{is_hri} ? 'hri' + : $self->{_result_inflator}{is_core_row} ? 'classic_pruning' + : 'classic_nonpruning' + ; - ( $self->{_row_parser}{classic} ||= $rsrc->_mk_row_parser({ + # $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, - selection => $attrs->{select}, collapse => $attrs->{collapse}, premultiplied => $attrs->{_main_source_premultiplied}, - }) )->($rows, @extra_collapser_args); + 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} ) { + + $err = + 'Collapse aborted due to invalid ResultSource metadata - the following ' + . 'selections are declared non-nullable but NULLs were retrieved: ' + ; + + 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; - $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows; + $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; + } + + 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 { + # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + my @r = $cursor->next or return; + \@r + } + ; + + $self->{_row_parser}{$parser_type}{cref}->( + $rows, + $next_cref ? ( $next_cref, $self->{_stashed_rows} = [] ) : (), + ); - # CDBI compat stuff - if ($attrs->{record_filter}) { - $_ = $attrs->{record_filter}->($_) for @$rows; + # simple in-place substitution, does not regrow $rows + if ($self->{_result_inflator}{is_core_row}) { + $_ = $inflator_cref->($res_class, $rsrc, @$_) for @$rows + } + # Special-case multi-object HRI - there is no $inflator_cref pass at all + elsif ( ! $self->{_result_inflator}{is_hri} ) { + # the inflator may be a multiplier/reductor - put it in list ctx + @$rows = map { $inflator_cref->($res_class, $rsrc, @$_) } @$rows; + } } + # The @$rows check seems odd at first - why wouldn't we want to warn + # regardless? The issue is things like find() etc, where the user + # *knows* only one result will come back. In these cases the ->all + # is not a pessimization, but rather something we actually want + carp_unique( + 'Unable to properly collapse has_many results in iterator mode due ' + . 'to order criteria - performed an eager cursor slurp underneath. ' + . 'Consider using ->all() instead' + ) if ( ! $fetch_all and @$rows > 1 ); + return $rows; } @@ -1463,8 +1542,8 @@ L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class. Note that changing the result_class will also remove any components that were originally loaded in the source class via -L. Any overloaded methods -in the original source class will not run. +L. +Any overloaded methods in the original source class will not run. =cut @@ -1564,10 +1643,10 @@ sub count_rs { # software based limiting can not be ported if this $rs is to be used # in a subquery itself (i.e. ->as_query) if ($self->_has_resolved_attr (qw/collapse group_by offset rows/)) { - return $self->_count_subq_rs; + return $self->_count_subq_rs($self->{_attrs}); } else { - return $self->_count_rs; + return $self->_count_rs($self->{_attrs}); } } @@ -1578,19 +1657,17 @@ sub _count_rs { my ($self, $attrs) = @_; my $rsrc = $self->result_source; - $attrs ||= $self->_resolved_attrs; my $tmp_attrs = { %$attrs }; # take off any limits, record_filter is cdbi, and no point of ordering nor locking a count delete @{$tmp_attrs}{qw/rows offset order_by record_filter for/}; # overwrite the selector (supplied by the storage) - $tmp_attrs->{select} = $rsrc->storage->_count_select ($rsrc, $attrs); - $tmp_attrs->{as} = 'count'; - - my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count'); - - return $tmp_rs; + $rsrc->resultset_class->new($rsrc, { + %$tmp_attrs, + select => $rsrc->storage->_count_select ($rsrc, $attrs), + as => 'count', + })->get_column ('count'); } # @@ -1600,11 +1677,10 @@ sub _count_subq_rs { my ($self, $attrs) = @_; my $rsrc = $self->result_source; - $attrs ||= $self->_resolved_attrs; my $sub_attrs = { %$attrs }; # extra selectors do not go in the subquery and there is no point of ordering it, nor locking it - delete @{$sub_attrs}{qw/collapse columns as select _prefetch_selector_range order_by for/}; + delete @{$sub_attrs}{qw/collapse columns as select order_by for/}; # if we multi-prefetch we group_by something unique, as this is what we would # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless @@ -1807,7 +1883,7 @@ sub _rs_update_delete { my $attrs = { %{$self->_resolved_attrs} }; my $join_classifications; - my $existing_group_by = delete $attrs->{group_by}; + my ($existing_group_by) = delete @{$attrs}{qw(group_by _grouped_by_distinct)}; # do we need a subquery for any reason? my $needs_subq = ( @@ -1822,20 +1898,12 @@ sub _rs_update_delete { # simplify the joinmap, so we can further decide if a subq is necessary if (!$needs_subq and @{$attrs->{from}} > 1) { - $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $self->{cond}, $attrs); - - # check if there are any joins left after the prune - if ( @{$attrs->{from}} > 1 ) { - $join_classifications = $storage->_resolve_aliastypes_from_select_args ( - [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ], - $attrs->{select}, - $self->{cond}, - $attrs - ); - # any non-pruneable joins imply subq - $needs_subq = scalar keys %{ $join_classifications->{restricting} || {} }; - } + ($attrs->{from}, $join_classifications) = + $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} || {} }; } # check if the head is composite (by now all joins are thrown out unless $needs_subq) @@ -1868,9 +1936,12 @@ sub _rs_update_delete { ); # make a new $rs selecting only the PKs (that's all we really need for the subq) - delete $attrs->{$_} for qw/collapse select _prefetch_selector_range as/; + delete $attrs->{$_} for qw/select as collapse/; $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ]; - $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins + + # this will be consumed by the pruner waaaaay down the stack + $attrs->{_force_prune_multiplying_joins} = 1; + my $subrs = (ref $self)->new($rsrc, $attrs); if (@$idcols == 1) { @@ -1891,6 +1962,8 @@ sub _rs_update_delete { if ( $existing_group_by or + # we do not need to check pre-multipliers, since if the premulti is there, its + # parent (who is multi) will be there too keys %{ $join_classifications->{multiplying} || {} } ) { # make sure if there is a supplied group_by it matches the columns compiled above @@ -1922,7 +1995,6 @@ sub _rs_update_delete { $guard = $storage->txn_scope_guard; - $cond = []; for my $row ($subrs->cursor->all) { push @$cond, { map { $idcols->[$_] => $row->[$_] } @@ -1932,11 +2004,11 @@ sub _rs_update_delete { } } - my $res = $storage->$op ( + my $res = $cond ? $storage->$op ( $rsrc, $op eq 'update' ? $values : (), $cond, - ); + ) : '0E0'; $guard->commit if $guard; @@ -2110,7 +2182,7 @@ first element should be a list of column names and each subsequent element should be a data value in the earlier specified column order. For example: - $Arstist_rs->populate([ + $schema->resultset("Artist")->populate([ [ qw( artistid name ) ], [ 100, 'A Formally Unknown Singer' ], [ 101, 'A singer that jumped the shark two albums ago' ], @@ -2146,127 +2218,275 @@ case there are obviously no benefits to using this method over L. sub populate { my $self = shift; - # cruft placed in standalone method - my $data = $self->_normalize_populate_args(@_); + # this is naive and just a quick check + # the types will need to be checked more thoroughly when the + # multi-source populate gets added + my $data = ( + ref $_[0] eq 'ARRAY' + and + ( @{$_[0]} or return ) + and + ( ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY' ) + and + $_[0] + ) or $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs'); - return unless @$data; + # FIXME - no cref handling + # At this point assume either hashes or arrays if(defined wantarray) { - my @created = map { $self->create($_) } @$data; - return wantarray ? @created : \@created; - } - else { - my $first = $data->[0]; + my (@results, $guard); - # if a column is a registered relationship, and is a non-blessed hash/array, consider - # it relationship data - my (@rels, @columns); - my $rsrc = $self->result_source; - my $rels = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships }; - for (keys %$first) { - my $ref = ref $first->{$_}; - $rels->{$_} && ($ref eq 'ARRAY' or $ref eq 'HASH') - ? push @rels, $_ - : push @columns, $_ + if (ref $data->[0] eq 'ARRAY') { + # column names only, nothing to do + return if @$data == 1; + + $guard = $self->result_source->schema->storage->txn_scope_guard + if @$data > 2; + + @results = map + { my $vals = $_; $self->new_result({ map { $data->[0][$_] => $vals->[$_] } 0..$#{$data->[0]} })->insert } + @{$data}[1 .. $#$data] ; } + else { + + $guard = $self->result_source->schema->storage->txn_scope_guard + if @$data > 1; + + @results = map { $self->new_result($_)->insert } @$data; + } + + $guard->commit if $guard; + return wantarray ? @results : \@results; + } + + # we have to deal with *possibly incomplete* related data + # 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); + my $data_start = 0; + + DATA_SLICE: + for my $i (0 .. $#$data) { + + my $current_slice_seen_rel_infos; + +### Determine/Supplement collists +### BEWARE - This is a hot piece of code, a lot of weird idioms were used + if( ref $data->[$i] eq 'ARRAY' ) { - my @pks = $rsrc->primary_columns; + # positional(!) explicit column list + if ($i == 0) { + # column names only, nothing to do + return if @$data == 1; - ## do the belongs_to relationships - foreach my $index (0..$#$data) { + $colinfo->{$data->[0][$_]} = { pos => $_, name => $data->[0][$_] } and push @$colnames, $data->[0][$_] + for 0 .. $#{$data->[0]}; - # delegate to create() for any dataset without primary keys with specified relationships - if (grep { !defined $data->[$index]->{$_} } @pks ) { - for my $r (@rels) { - if (grep { ref $data->[$index]{$r} eq $_ } qw/HASH ARRAY/) { # a related set must be a HASH or AoH - my @ret = $self->populate($data); - return; + $data_start = 1; + + next DATA_SLICE; + } + else { + for (values %$colinfo) { + if ($_->{is_rel} ||= ( + $rel_info->{$_->{name}} + and + ( + ref $data->[$i][$_->{pos}] eq 'ARRAY' + or + ref $data->[$i][$_->{pos}] eq 'HASH' + or + ( defined blessed $data->[$i][$_->{pos}] and $data->[$i][$_->{pos}]->isa('DBIx::Class::Row') ) + ) + and + 1 + )) { + + # moar sanity check... sigh + for ( ref $data->[$i][$_->{pos}] eq 'ARRAY' ? @{$data->[$i][$_->{pos}]} : $data->[$i][$_->{pos}] ) { + if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } + } + + push @$current_slice_seen_rel_infos, $rel_info->{$_->{name}}; } } } - foreach my $rel (@rels) { - next unless ref $data->[$index]->{$rel} eq "HASH"; - my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel}); - my ($reverse_relname, $reverse_relinfo) = %{$rsrc->reverse_relationship_info($rel)}; - my $related = $result->result_source->_resolve_condition( - $reverse_relinfo->{cond}, - $self, - $result, - $rel, - ); - - delete $data->[$index]->{$rel}; - $data->[$index] = {%{$data->[$index]}, %$related}; + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, { map { $colnames->[$_] => $data->[$i][$_] } 0 .. $#$colnames }; - push @columns, keys %$related if $index == 0; + # this is needed further down to decide whether or not to fallback to create() + $colinfo->{$colnames->[$_]}{seen_null} ||= ! defined $data->[$i][$_] + for 0 .. $#$colnames; } } + elsif( ref $data->[$i] eq 'HASH' ) { - ## inherit the data locked in the conditions of the resultset - my ($rs_data) = $self->_merge_with_rscond({}); - delete @{$rs_data}{@columns}; + for ( sort keys %{$data->[$i]} ) { - ## do bulk insert on current row - $rsrc->storage->insert_bulk( - $rsrc, - [@columns, keys %$rs_data], - [ map { [ @$_{@columns}, values %$rs_data ] } @$data ], - ); - - ## do the has_many relationships - foreach my $item (@$data) { + $colinfo->{$_} ||= do { - my $main_row; + $self->throw_exception("Column '$_' must be present in supplied explicit column list") + if $data_start; # it will be 0 on AoH, 1 on AoA - foreach my $rel (@rels) { - next unless ref $item->{$rel} eq "ARRAY" && @{ $item->{$rel} }; + push @$colnames, $_; - $main_row ||= $self->new_result({map { $_ => $item->{$_} } @pks}); + # RV + { pos => $#$colnames, name => $_ } + }; - my $child = $main_row->$rel; + if ($colinfo->{$_}{is_rel} ||= ( + $rel_info->{$_} + and + ( + ref $data->[$i]{$_} eq 'ARRAY' + or + ref $data->[$i]{$_} eq 'HASH' + or + ( defined blessed $data->[$i]{$_} and $data->[$i]{$_}->isa('DBIx::Class::Row') ) + ) + and + 1 + )) { + + # moar sanity check... sigh + for ( ref $data->[$i]{$_} eq 'ARRAY' ? @{$data->[$i]{$_}} : $data->[$i]{$_} ) { + if ( defined blessed $_ and $_->isa('DBIx::Class::Row' ) ) { + carp_unique("Fast-path populate() with supplied related objects is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } + } - my $related = $child->result_source->_resolve_condition( - $rels->{$rel}{cond}, - $child, - $main_row, - $rel, - ); + push @$current_slice_seen_rel_infos, $rel_info->{$_}; + } + } - my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); - my @populate = map { {%$_, %$related} } @rows_to_add; + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, $data->[$i]; - $child->populate( \@populate ); + # this is needed further down to decide whether or not to fallback to create() + $colinfo->{$_}{seen_null} ||= ! defined $data->[$i]{$_} + for keys %{$data->[$i]}; } } + else { + $self->throw_exception('Unexpected populate() data structure member type: ' . ref $data->[$i] ); + } + + if ( grep + { $_->{attrs}{is_depends_on} } + @{ $current_slice_seen_rel_infos || [] } + ) { + carp_unique("Fast-path populate() of belongs_to relationship data is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); + } } -} + if( $slices_with_rels ) { -# populate() argumnets went over several incarnations -# What we ultimately support is AoH -sub _normalize_populate_args { - my ($self, $arg) = @_; + # need to exclude the rel "columns" + $colnames = [ grep { ! $colinfo->{$_}{is_rel} } @$colnames ]; - if (ref $arg eq 'ARRAY') { - if (!@$arg) { - return []; - } - elsif (ref $arg->[0] eq 'HASH') { - return $arg; + # extra sanity check - ensure the main source is in fact identifiable + # the localizing of nullability is insane, but oh well... the use-case is legit + my $ci = $rsrc->columns_info($colnames); + + $ci->{$_} = { %{$ci->{$_}}, is_nullable => 0 } + for grep { ! $colinfo->{$_}{seen_null} } keys %$ci; + + unless( $rsrc->_identifying_column_set($ci) ) { + carp_unique("Fast-path populate() of non-uniquely identifiable rows with related data is not possible - falling back to regular create()"); + return my $throwaway = $self->populate(@_); } - elsif (ref $arg->[0] eq 'ARRAY') { - my @ret; - my @colnames = @{$arg->[0]}; - foreach my $values (@{$arg}[1 .. $#$arg]) { - push @ret, { map { $colnames[$_] => $values->[$_] } (0 .. $#colnames) }; + } + +### inherit the data locked in the conditions of the resultset + my ($rs_data) = $self->_merge_with_rscond({}); + delete @{$rs_data}{@$colnames}; # passed-in stuff takes precedence + + # if anything left - decompose rs_data + my $rs_data_vals; + if (keys %$rs_data) { + push @$rs_data_vals, $rs_data->{$_} + for sort keys %$rs_data; + } + +### start work + my $guard; + $guard = $rsrc->schema->storage->txn_scope_guard + if $slices_with_rels; + +### 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, + [ @$colnames, sort keys %$rs_data ], + [ map { + ref $data->[$_] eq 'ARRAY' + ? ( + $slices_with_rels ? [ @{$data->[$_]}[0..$#$colnames], @{$rs_data_vals||[]} ] # the collist changed + : $rs_data_vals ? [ @{$data->[$_]}, @$rs_data_vals ] + : $data->[$_] + ) + : [ @{$data->[$_]}{@$colnames}, @{$rs_data_vals||[]} ] + } $data_start .. $#$data ], + ); + +### do the children relationships + if ( $slices_with_rels ) { + my @rels = grep { $colinfo->{$_}{is_rel} } keys %$colinfo + or die 'wtf... please report a bug with DBIC_TRACE=1 output (stacktrace)'; + + for my $sl (@$slices_with_rels) { + + my ($main_proto, $main_proto_rs); + for my $rel (@rels) { + next unless defined $sl->{$rel}; + + $main_proto ||= { + %$rs_data, + (map { $_ => $sl->{$_} } @$colnames), + }; + + unless (defined $colinfo->{$rel}{rs}) { + + $colinfo->{$rel}{rs} = $rsrc->related_source($rel)->resultset; + + $colinfo->{$rel}{fk_map} = { reverse %{ $rsrc->_resolve_relationship_condition( + rel_name => $rel, + self_alias => "\xFE", # irrelevant + foreign_alias => "\xFF", # irrelevant + )->{identity_map} || {} } }; + + } + + $colinfo->{$rel}{rs}->search({ map # only so that we inherit them values properly, no actual search + { + $_ => { '=' => + ( $main_proto_rs ||= $rsrc->resultset->search($main_proto) ) + ->get_column( $colinfo->{$rel}{fk_map}{$_} ) + ->as_query + } + } + keys %{$colinfo->{$rel}{fk_map}} + })->populate( ref $sl->{$rel} eq 'ARRAY' ? $sl->{$rel} : [ $sl->{$rel} ] ); + + 1; } - return \@ret; } } - $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs'); + $guard->commit if $guard; } =head2 pager @@ -2362,7 +2582,7 @@ sub new_result { $self->throw_exception( "new_result takes only one argument - a hashref of values" ) if @_ > 2; - $self->throw_exception( "new_result expects a hashref" ) + $self->throw_exception( "Result object instantiation requires a hashref as argument" ) unless (ref $values eq 'HASH'); my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); @@ -2401,51 +2621,33 @@ sub new_result { sub _merge_with_rscond { my ($self, $data) = @_; - my (%new_data, @cols_from_relations); + my ($implied_data, @cols_from_relations); my $alias = $self->{attrs}{alias}; if (! defined $self->{cond}) { # just massage $data below } - elsif ($self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) { - %new_data = %{ $self->{attrs}{related_objects} || {} }; # nothing might have been inserted yet - @cols_from_relations = keys %new_data; - } - elsif (ref $self->{cond} ne 'HASH') { - $self->throw_exception( - "Can't abstract implicit construct, resultset condition not a hash" - ); + elsif ($self->{cond} eq UNRESOLVABLE_CONDITION) { + $implied_data = $self->{attrs}{related_objects}; # nothing might have been inserted yet + @cols_from_relations = keys %{ $implied_data || {} }; } else { - # precendence must be given to passed values over values inherited from - # the cond, so the order here is important. - my $collapsed_cond = $self->_collapse_cond($self->{cond}); - my %implied = %{$self->_remove_alias($collapsed_cond, $alias)}; - - while ( my($col, $value) = each %implied ) { - my $vref = ref $value; - if ( - $vref eq 'HASH' - and - keys(%$value) == 1 - and - (keys %$value)[0] eq '=' - ) { - $new_data{$col} = $value->{'='}; - } - elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) { - $new_data{$col} = $value; - } - } + my $eqs = $self->result_source->schema->storage->_extract_fixed_condition_columns($self->{cond}, 'consider_nulls'); + $implied_data = { map { + ( ($eqs->{$_}||'') eq UNRESOLVABLE_CONDITION ) ? () : ( $_ => $eqs->{$_} ) + } keys %$eqs }; } - %new_data = ( - %new_data, - %{ $self->_remove_alias($data, $alias) }, + return ( + { map + { %{ $self->_remove_alias($_, $alias) } } + # precedence must be given to passed values over values inherited from + # the cond, so the order here is important. + ( $implied_data||(), $data) + }, + \@cols_from_relations ); - - return (\%new_data, \@cols_from_relations); } # _has_resolved_attr @@ -2453,7 +2655,7 @@ sub _merge_with_rscond { # determines if the resultset defines at least one # of the attributes supplied # -# used to determine if a subquery is neccessary +# used to determine if a subquery is necessary # # supports some virtual attributes: # -join @@ -2501,38 +2703,6 @@ sub _has_resolved_attr { return 0; } -# _collapse_cond -# -# Recursively collapse the condition. - -sub _collapse_cond { - my ($self, $cond, $collapsed) = @_; - - $collapsed ||= {}; - - if (ref $cond eq 'ARRAY') { - foreach my $subcond (@$cond) { - next unless ref $subcond; # -or - $collapsed = $self->_collapse_cond($subcond, $collapsed); - } - } - elsif (ref $cond eq 'HASH') { - if (keys %$cond and (keys %$cond)[0] eq '-and') { - foreach my $subcond (@{$cond->{-and}}) { - $collapsed = $self->_collapse_cond($subcond, $collapsed); - } - } - else { - foreach my $col (keys %$cond) { - my $value = $cond->{$col}; - $collapsed->{$col} = $value; - } - } - } - - return $collapsed; -} - # _remove_alias # # Remove the specified alias from the specified query hash. A copy is made so @@ -2577,16 +2747,11 @@ sub as_query { my $attrs = { %{ $self->_resolved_attrs } }; - # For future use: - # - # in list ctx: - # my ($sql, \@bind, \%dbi_bind_attrs) = _select_args_to_query (...) - # $sql also has no wrapping parenthesis in list ctx - # - my $sqlbind = $self->result_source->storage - ->_select_args_to_query ($attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs); + my $aq = $self->result_source->storage->_select_args_to_query ( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ); - return $sqlbind; + $aq; } =head2 find_or_new @@ -2603,7 +2768,7 @@ sub as_query { { artist => 'fred' }, { key => 'artists' }); $cd->cd_to_producer->find_or_new({ producer => $producer }, - { key => 'primary }); + { key => 'primary' }); Find an existing record from this resultset using L. if none exists, instantiate a new result object and return it. The object will not be saved @@ -2718,10 +2883,9 @@ L. =cut sub create { - my ($self, $attrs) = @_; - $self->throw_exception( "create needs a hashref" ) - unless ref $attrs eq 'HASH'; - return $self->new_result($attrs)->insert; + #my ($self, $col_data) = @_; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + return shift->new_result(shift)->insert; } =head2 find_or_create @@ -2803,7 +2967,7 @@ sub find_or_create { if (keys %$hash and my $row = $self->find($hash, $attrs) ) { return $row; } - return $self->create($hash); + return $self->new_result($hash)->insert; } =head2 update_or_create @@ -2873,7 +3037,7 @@ sub update_or_create { return $row; } - return $self->create($cond); + return $self->new_result($cond)->insert; } =head2 update_or_new @@ -3056,9 +3220,18 @@ Returns a related resultset for the supplied relationship name. =cut sub related_resultset { + $_[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 $_[0]->{related_resultsets}{$_[1]} + if defined $_[0]->{related_resultsets}{$_[1]}; + my ($self, $rel) = @_; - return $self->{related_resultsets}{$rel} ||= do { + return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; my $rel_info = $rsrc->relationship_info($rel); @@ -3069,31 +3242,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 $related_cache; - - if (my $cache = $self->get_cache) { - $related_cache = [ map - { @{$_->related_resultset($rel)->get_cache||[]} } - @$cache - ]; - } - - my $rel_source = $rsrc->related_source($rel); + delete $attrs->{result_class}; my $new = do { @@ -3102,18 +3269,30 @@ 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.) + # -- 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 ); + }; - my $rel_attrs = $rel_source->resultset_attributes; - local $rel_attrs->{alias} = $alias; + if (my $cache = $self->get_cache) { + my @related_cache = map + { $_->related_resultset($rel)->get_cache || () } + @$cache + ; + + $new->set_cache([ map @$_, @related_cache ]) if @related_cache == @$cache; + } - $rel_source->resultset - ->search_rs( - undef, { - %$attrs, - where => $attrs->{where}, - }); - }; - $new->set_cache($related_cache) if $related_cache; $new; }; } @@ -3153,6 +3332,9 @@ source alias of the current result set: }); } +The alias of L can be altered by the +L. + =cut sub current_source_alias { @@ -3253,7 +3435,7 @@ sub _chain_relationship { # ->_resolve_join as otherwise they get lost - captainL my $join = $self->_merge_joinpref_attr( $attrs->{join}, $attrs->{prefetch} ); - delete @{$attrs}{qw/join prefetch collapse group_by distinct select as columns +select +as +columns/}; + delete @{$attrs}{qw/join prefetch collapse group_by distinct _grouped_by_distinct select as columns +select +as +columns/}; my $seen = { %{ (delete $attrs->{seen_join}) || {} } }; @@ -3343,9 +3525,12 @@ sub _resolved_attrs { return $self->{_attrs} if $self->{_attrs}; my $attrs = { %{ $self->{attrs} || {} } }; - my $source = $self->result_source; + my $source = $attrs->{result_source} = $self->result_source; my $alias = $attrs->{alias}; + $self->throw_exception("Specifying distinct => 1 in conjunction with collapse => 1 is unsupported") + if $attrs->{collapse} and $attrs->{distinct}; + # default selection list $attrs->{columns} = [ $source->columns ] unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/; @@ -3444,89 +3629,37 @@ sub _resolved_attrs { ]; } - if ( defined $attrs->{order_by} ) { - $attrs->{order_by} = ( - ref( $attrs->{order_by} ) eq 'ARRAY' - ? [ @{ $attrs->{order_by} } ] - : [ $attrs->{order_by} || () ] - ); - } - if ($attrs->{group_by} and ref $attrs->{group_by} ne 'ARRAY') { - $attrs->{group_by} = [ $attrs->{group_by} ]; - } + for my $attr (qw(order_by group_by)) { - # generate the distinct induced group_by early, as prefetch will be carried via a - # subquery (since a group_by is present) - if (delete $attrs->{distinct}) { - if ($attrs->{group_by}) { - carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)"); - } - else { - # distinct affects only the main selection part, not what prefetch may - # add below. - $attrs->{group_by} = $source->storage->_group_over_selection ( - $attrs->{from}, - $attrs->{select}, - $attrs->{order_by}, + if ( defined $attrs->{$attr} ) { + $attrs->{$attr} = ( + ref( $attrs->{$attr} ) eq 'ARRAY' + ? [ @{ $attrs->{$attr} } ] + : [ $attrs->{$attr} || () ] ); + + delete $attrs->{$attr} unless @{$attrs->{$attr}}; } } - # generate selections based on the prefetch helper - my $prefetch; - $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) - if defined $attrs->{prefetch}; - - if ($prefetch) { - $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") - if $attrs->{_dark_selector}; + # set collapse default based on presence of prefetch + my $prefetch; + if ( + defined $attrs->{prefetch} + and + $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) + ) { + $self->throw_exception("Specifying prefetch in conjunction with an explicit collapse => 0 is unsupported") + if defined $attrs->{collapse} and ! $attrs->{collapse}; $attrs->{collapse} = 1; - - # this is a separate structure (we don't look in {from} directly) - # as the resolver needs to shift things off the lists to work - # properly (identical-prefetches on different branches) - my $join_map = {}; - if (ref $attrs->{from} eq 'ARRAY') { - - my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0; - - for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) { - next unless $j->[0]{-alias}; - next unless $j->[0]{-join_path}; - next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth; - - my @jpath = map { keys %$_ } @{$j->[0]{-join_path}}; - - my $p = $join_map; - $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries - push @{$p->{-join_aliases} }, $j->[0]{-alias}; - } - } - - my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map ); - - # we need to somehow mark which columns came from prefetch - if (@prefetch) { - my $sel_end = $#{$attrs->{select}}; - $attrs->{_prefetch_selector_range} = [ $sel_end + 1, $sel_end + @prefetch ]; - } - - push @{ $attrs->{select} }, (map { $_->[0] } @prefetch); - push @{ $attrs->{as} }, (map { $_->[1] } @prefetch); } - if ( defined List::Util::first { $_ =~ /\./ } @{$attrs->{as}} ) { - $attrs->{_related_results_construction} = 1; - } - else { - $attrs->{collapse} = 0; - } # run through the resulting joinstructure (starting from our current slot) - # and unset collapse if proven unnesessary + # and unset collapse if proven unnecessary # # also while we are at it find out if the current root source has # been premultiplied by previous related_source chaining @@ -3537,7 +3670,7 @@ sub _resolved_attrs { if (ref $attrs->{from} eq 'ARRAY') { - if (@{$attrs->{from}} <= 1) { + if (@{$attrs->{from}} == 1) { # no joins - no collapse $attrs->{collapse} = 0; } @@ -3574,6 +3707,66 @@ sub _resolved_attrs { } } + + # generate the distinct induced group_by before injecting the prefetched select/as parts + if (delete $attrs->{distinct}) { + if ($attrs->{group_by}) { + carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)"); + } + 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); + + # 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 + # rip stuff apart for us anyway, and we do not want to have a potentially + # function-converted external order_by + # ( there is an explicit if ( collapse && _grouped_by_distinct ) check in DBIHacks ) + $attrs->{order_by} = $new_order unless $attrs->{collapse}; + } + } + + + # generate selections based on the prefetch helper + if ($prefetch) { + + $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") + if $attrs->{_dark_selector}; + + # this is a separate structure (we don't look in {from} directly) + # as the resolver needs to shift things off the lists to work + # properly (identical-prefetches on different branches) + my $joined_node_aliases_map = {}; + if (ref $attrs->{from} eq 'ARRAY') { + + my $start_depth = $attrs->{seen_join}{-relation_chain_depth} || 0; + + for my $j ( @{$attrs->{from}}[1 .. $#{$attrs->{from}} ] ) { + next unless $j->[0]{-alias}; + next unless $j->[0]{-join_path}; + next if ($j->[0]{-relation_chain_depth} || 0) < $start_depth; + + my @jpath = map { keys %$_ } @{$j->[0]{-join_path}}; + + my $p = $joined_node_aliases_map; + $p = $p->{$_} ||= {} for @jpath[ ($start_depth/2) .. $#jpath]; #only even depths are actual jpath boundaries + push @{$p->{-join_aliases} }, $j->[0]{-alias}; + } + } + + ( push @{$attrs->{select}}, $_->[0] ) and ( push @{$attrs->{as}}, $_->[1] ) + for $source->_resolve_selection_from_prefetch( $prefetch, $joined_node_aliases_map ); + } + + + $attrs->{_simple_passthrough_construction} = !( + $attrs->{collapse} + or + grep { $_ =~ /\./ } @{$attrs->{as}} + ); + + # if both page and offset are specified, produce a combined offset # even though it doesn't make much sense, this is what pre 081xx has # been doing @@ -3639,8 +3832,10 @@ sub _calculate_score { if (ref $b eq 'HASH') { my ($b_key) = keys %{$b}; + $b_key = '' if ! defined $b_key; if (ref $a eq 'HASH') { my ($a_key) = keys %{$a}; + $a_key = '' if ! defined $a_key; if ($a_key eq $b_key) { return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} )); } else { @@ -3892,32 +4087,65 @@ syntax as outlined above. Shortcut to request a particular set of columns to be retrieved. Each column spec may be a string (a table column name), or a hash (in which case the key is the C value, and the value is used as the C from that, then auto-populates C from C and L. - columns => [ 'foo', { bar => 'baz' } ] + columns => [ 'some_column', { dbic_slot => 'another_column' } ] is the same as - select => [qw/foo baz/], - as => [qw/foo bar/] + select => [qw(some_column another_column)], + as => [qw(some_column dbic_slot)] + +If you want to individually retrieve related columns (in essence perform +manual L) you have to make sure to specify the correct inflation slot +chain such that it matches existing relationships: + + my $rs = $schema->resultset('Artist')->search({}, { + # required to tell DBIC to collapse has_many relationships + collapse => 1, + join => { cds => 'tracks' }, + '+columns' => { + 'cds.cdid' => 'cds.cdid', + 'cds.tracks.title' => 'tracks.title', + }, + }); + +Like elsewhere, literal SQL or literal values can be included by using a +scalar reference or a literal bind value, and these values will be available +in the result with C (see also +L): + + # equivalent SQL: SELECT 1, 'a string', IF(my_column,?,?) ... + # bind values: $true_value, $false_value + columns => [ + { + foo => \1, + bar => \q{'a string'}, + baz => \[ 'IF(my_column,?,?)', $true_value, $false_value ], + } + ] =head2 +columns +B You B explicitly quote C<'+columns'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+columns> as a bareword +with a unary plus operator before it, which is the same as simply C. + =over 4 -=item Value: \@columns +=item Value: \@extra_columns =back -Indicates additional columns to be selected from storage. Works the same -as L but adds columns to the selection. (You may also use the -C attribute, as in earlier versions of DBIC). For -example:- +Indicates additional columns to be selected from storage. Works the same as +L but adds columns to the current selection. (You may also use the +C attribute, as in earlier versions of DBIC, but this is +deprecated) $schema->resultset('CD')->search(undef, { '+columns' => ['artist.name'], @@ -3929,20 +4157,6 @@ passed to object inflation. Note that the 'artist' is the name of the column (or relationship) accessor, and 'name' is the name of the column accessor in the related table. -B You need to explicitly quote '+columns' when defining the attribute. -Not doing so causes Perl to incorrectly interpret +columns as a bareword with a -unary plus operator before it. - -=head2 include_columns - -=over 4 - -=item Value: \@columns - -=back - -Deprecated. Acts as a synonym for L for backward compatibility. - =head2 select =over 4 @@ -3968,25 +4182,28 @@ names: B You will almost always need a corresponding L attribute when you use L, to instruct DBIx::Class how to store the result of the column. -Also note that the L attribute has nothing to do with the SQL-side 'AS' -identifier aliasing. You can however alias a function, so you can use it in -e.g. an C clause. This is done via the C<-as> B supplied as shown in the example above. =head2 +select +B You B explicitly quote C<'+select'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+select> as a bareword +with a unary plus operator before it, which is the same as simply C but adds columns to the default selection, instead of specifying -an explicit list. +=item Value: \@extra_select_columns =back +Indicates additional columns to be selected from storage. Works the same as +L but adds columns to the current selection, instead of specifying +a new explicit list. + =head2 as =over 4 @@ -3995,12 +4212,14 @@ an explicit list. =back -Indicates column names for object inflation. That is L indicates the +Indicates DBIC-side names for object inflation. That is L indicates the slot name in which the column value will be stored within the L object. The value will then be accessible via this identifier by the C method (or via the object accessor B) as shown below. The L attribute has -B with the SQL-side C. See L for details. +with the same name already exists>) as shown below. + +The L attribute has B with the SQL-side identifier +aliasing C. See L for details. $rs = $schema->resultset('Employee')->search(undef, { select => [ @@ -4031,12 +4250,18 @@ L for details. =head2 +as +B You B explicitly quote C<'+as'> when using this attribute. +Not doing so causes Perl to incorrectly interpret C<+as> as a bareword +with a unary plus operator before it, which is the same as simply C. + =over 4 -Indicates additional column names for those added via L. See L. +=item Value: \@extra_inflation_names =back +Indicates additional inflation names for selectors added via L. See L. + =head2 join =over 4 @@ -4152,7 +4377,7 @@ object with all of its related data. If an L is already declared, and orders the resultset in a way that makes collapsing as described above impossible (e.g. C<< ORDER BY has_many_rel.column >> or C), DBIC will automatically -switch to "eager" mode and slurp the entire resultset before consturcting the +switch to "eager" mode and slurp the entire resultset before constructing the first object returned by L. Setting this attribute on a resultset that does not join any has_many @@ -4170,8 +4395,10 @@ For a more in-depth discussion, see L. This attribute is a shorthand for specifying a L spec, adding all columns from the joined related sources as L and setting -L to a true value. For example, the following two queries are -equivalent: +L to a true value. It can be thought of as a rough B +of the L attribute. + +For example, the following two queries are equivalent: my $rs = $schema->resultset('Artist')->search({}, { prefetch => { cds => ['genre', 'tracks' ] }, @@ -4348,15 +4575,20 @@ A arrayref of columns to group by. Can include columns of joined tables. =back -HAVING is a select statement attribute that is applied between GROUP BY and -ORDER BY. It is applied to the after the grouping calculations have been -done. +The HAVING operator specifies a B condition applied to the set +after the grouping calculations have been done. In other words it is a +constraint just like L (and accepting the same +L) applied to the data +as it exists after GROUP BY has taken place. Specifying L without +L is a logical mistake, and a fatal error on most RDBMS engines. + +E.g. having => { 'count_employee' => { '>=', 100 } } or with an in-place function in which case literal SQL is required: - having => \[ 'count(employee) >= ?', [ count => 100 ] ] + having => \[ 'count(employee) >= ?', 100 ] =head2 distinct @@ -4366,24 +4598,28 @@ or with an in-place function in which case literal SQL is required: =back -Set to 1 to group by all columns. If the resultset already has a group_by -attribute, this setting is ignored and an appropriate warning is issued. +Set to 1 to automatically generate a L clause based on the selection +(including intelligent handling of L contents). Note that the group +criteria calculation takes place over the B selection. This includes +any L, L or L additions in subsequent +L calls, and standalone columns selected via +L (L). A notable exception are the +extra selections specified via L - such selections are explicitly +excluded from group criteria calculations. -=head2 where +If the final ResultSet also explicitly defines a L attribute, this +setting is ignored and an appropriate warning is issued. -=over 4 +=head2 where -Adds to the WHERE clause. +Adds extra conditions to the resultset, combined with the preexisting C +conditions, same as the B argument to the L # only return rows WHERE deleted IS NULL for all searches __PACKAGE__->resultset_attributes({ where => { deleted => undef } }); -Can be overridden by passing C<< { where => undef } >> as an attribute -to a resultset. - -For more complicated where clauses see L. - -=back +Note that the above example is +L. =head2 cache @@ -4576,7 +4812,7 @@ or to a sensible value based on the "data_type". =item dbic_colname Used to fill in missing sqlt_datatype and sqlt_size attributes (if they are -explicitly specified they are never overriden). Also used by some weird DBDs, +explicitly specified they are never overridden). Also used by some weird DBDs, where the column name should be available at bind_param time (e.g. Oracle). =back @@ -4587,12 +4823,17 @@ supported: [ $name => $val ] === [ { dbic_colname => $name }, $val ] [ \$dt => $val ] === [ { sqlt_datatype => $dt }, $val ] [ undef, $val ] === [ {}, $val ] + $val === [ {}, $val ] -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. +=cut