X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=8f68daa0dff2d157c10c81ae55d4630a38faea46;hb=788dae4f0d3a3288aae0dfa95350ffb50e4f2096;hp=5e4b8b5487da4e8bf0f3a4c40420a959d1504c57;hpb=1605376709663b035385b41828ce13ae3ed45a4d;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 5e4b8b5..8f68daa 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3,33 +3,35 @@ package DBIx::Class::ResultSet; use strict; use warnings; use base qw/DBIx::Class/; -use Carp::Clan qw/^DBIx::Class/; -use DBIx::Class::Exception; -use Data::Page; +use DBIx::Class::Carp; use DBIx::Class::ResultSetColumn; -use DBIx::Class::ResultSourceHandle; -use Hash::Merge (); -use Scalar::Util qw/blessed weaken/; +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 Storable qw/nfreeze thaw/; +use Data::Compare (); # no imports!!! guard against insane architecture # not importing first() as it will clash with our own method use List::Util (); -use namespace::clean; - - 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) *__HM_DEDUP = sub () { 0 }; } +use namespace::clean; + use overload '0+' => "count", 'bool' => "_bool", fallback => 1; +# this is real - CDBICompat overrides it with insanity +# yes, prototype won't matter, but that's for now ;) +sub _bool () { 1 } + __PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/); =head1 NAME @@ -38,12 +40,12 @@ DBIx::Class::ResultSet - Represents a query used for fetching a set of results. =head1 SYNOPSIS - my $users_rs = $schema->resultset('User'); + my $users_rs = $schema->resultset('User'); while( $user = $users_rs->next) { print $user->username; } - my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 }); + my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 }); my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all(); =head1 DESCRIPTION @@ -91,14 +93,14 @@ another. sub get_data { my $self = shift; my $request = $self->get_request; # Get a request object somehow. - my $schema = $self->get_schema; # Get the DBIC schema object somehow. + my $schema = $self->result_source->schema; my $cd_rs = $schema->resultset('CD')->search({ title => $request->param('title'), year => $request->param('year'), }); - $self->apply_security_policy( $cd_rs ); + $cd_rs = $self->apply_security_policy( $cd_rs ); return $cd_rs->all(); } @@ -114,11 +116,15 @@ another. =head3 Resolving conditions and attributes -When a resultset is chained from another resultset, conditions and -attributes with the same keys need resolving. +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 +original selection, and start the selection "clean". -L, L, L, L attributes are merged -into the existing ones from the original resultset. +The L, L, L, L, L attributes +are merged into the existing ones from the original resultset. The L and L attributes, and any search conditions, are merged with an SQL C to the existing condition from the original @@ -161,15 +167,102 @@ 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 =over 4 -=item Arguments: $source, \%$attrs +=item Arguments: L<$source|DBIx::Class::ResultSource>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $rs +=item Return Value: L<$resultset|/search> =back @@ -178,27 +271,48 @@ L) and an attribute hash (see L below). Does not perform any queries -- these are executed as needed by the other methods. -Generally you won't need to construct a resultset manually. You'll -automatically get one from e.g. a L called in scalar context: +Generally you never construct a resultset manually. Instead you get one +from e.g. a +C<< $schema->L('$source_name') >> +or C<< $another_resultset->L(...) >> (the later called in +scalar context): my $rs = $schema->resultset('CD')->search({ title => '100th Window' }); -IMPORTANT: If called on an object, proxies to new_result instead so +=over + +=item WARNING + +If called on an object, proxies to L instead, so my $cd = $schema->resultset('CD')->new({ title => 'Spoon' }); -will return a CD object, not a ResultSet. +will return a CD object, not a ResultSet, and is equivalent to: + + my $cd = $schema->resultset('CD')->new_result({ title => 'Spoon' }); + +Please also keep in mind that many internals call L directly, +so overloading this method with the idea of intercepting new result object +creation B. See also warning pertaining to L. + +=back =cut 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; @@ -213,6 +327,12 @@ sub new { attrs => $attrs, }, $class; + # if there is a dark selector, this means we are already in a + # chain and the cleanup/sanification was taken care of by + # _search_rs already + $self->_normalize_selection($attrs) + unless $attrs->{_dark_selector}; + $self->result_class( $attrs->{result_class} || $source->result_class ); @@ -224,9 +344,9 @@ sub new { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker> | undef, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: $resultset (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -236,6 +356,10 @@ sub new { my $new_rs = $cd_rs->search([ { year => 2005 }, { year => 2004 } ]); # year = 2005 OR year = 2004 +In list context, C<< ->all() >> is called implicitly on the resultset, thus +returning a list of L objects instead. +To avoid that, use L. + If you need to pass in additional attributes but no additional condition, call it as C. @@ -246,8 +370,9 @@ 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. @@ -255,11 +380,11 @@ For more help on using joins with search, see L. Note that L does not process/deflate any of the values passed in the L-compatible search condition structure. This is unlike other -condition-bound methods L, L and L. The user must ensure +condition-bound methods L, L and L. The user must ensure manually that any value passed to this method will stringify to something the RDBMS knows how to deal with. A notable example is the handling of L objects, for more info see: -L. +L. =cut @@ -268,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) { @@ -290,9 +416,9 @@ sub search { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -301,69 +427,83 @@ always return a resultset, even in list context. =cut -my $callsites_warned; sub search_rs { my $self = shift; - # Special-case handling for (undef, undef). - if ( @_ == 2 && !defined $_[1] && !defined $_[0] ) { - @_ = (); - } + my $rsrc = $self->result_source; + my ($call_cond, $call_attrs); - my $call_attrs = {}; - if (@_ > 1) { - if (ref $_[-1] eq 'HASH') { - # copy for _normalize_selection - $call_attrs = { %{ pop @_ } }; - } - elsif (! defined $_[-1] ) { - pop @_; # search({}, undef) + # Special-case handling for (undef, undef) or (undef) + # Note that (foo => undef) is valid deprecated syntax + @_ = () if not scalar grep { defined $_ } @_; + + # just a cond + if (@_ == 1) { + $call_cond = shift; + } + # fish out attrs in the ($condref, $attr) case + elsif (@_ == 2 and ( ! defined $_[0] or (ref $_[0]) ne '') ) { + ($call_cond, $call_attrs) = @_; + } + elsif (@_ % 2) { + $self->throw_exception('Odd number of arguments to search') + } + # legacy search + elsif (@_) { + carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead' + unless $rsrc->result_class->isa('DBIx::Class::CDBICompat'); + + 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 ''); } + + $call_cond = { @_ }; } # 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 ( - ! defined $_[0] + ! defined $call_cond or - ref $_[0] eq 'HASH' && ! keys %{$_[0]} + ref $call_cond eq 'HASH' && ! keys %$call_cond or - ref $_[0] eq 'ARRAY' && ! @{$_[0]} + ref $call_cond eq 'ARRAY' && ! @$call_cond )) { $cache = $self->get_cache; } - my $rsrc = $self->result_source; - 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 }; # take care of call attrs (only if anything is changing) - if (keys %$call_attrs) { + if ($call_attrs and keys %$call_attrs) { - $self->throw_exception ('_trailing_select is not a public attribute - do not use it in search()') - if ( exists $call_attrs->{_trailing_select} or exists $call_attrs->{'+_trailing_select'} ); + # copy for _normalize_selection + $call_attrs = { %$call_attrs }; - my @selector_attrs = qw/select as columns cols +select +as +columns include_columns _trailing_select +_trailing_select/; + 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')}; + } - # Normalize the selector list (operates on the passed-in attr structure) + # 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 - # order to separate 'as'-ed from blind 'select's + # order to allow detection of empty vs partial 'as' + $call_attrs->{_dark_selector} = $old_attrs->{_dark_selector} + if $old_attrs->{_dark_selector}; $self->_normalize_selection ($call_attrs); # start with blind overwriting merge, exclude selector attrs $new_attrs = { %{$old_attrs}, %{$call_attrs} }; delete @{$new_attrs}{@selector_attrs}; - # 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}; - } - for (@selector_attrs) { $new_attrs->{$_} = $self->_merge_attr($old_attrs->{$_}, $call_attrs->{$_}) if ( exists $old_attrs->{$_} or exists $call_attrs->{$_} ); @@ -371,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'"; } @@ -391,36 +532,6 @@ sub search_rs { } - # rip apart the rest of @_, parse a condition - my $call_cond = do { - - if (ref $_[0] eq 'HASH') { - (keys %{$_[0]}) ? $_[0] : undef - } - elsif (@_ == 1) { - $_[0] - } - elsif (@_ % 2) { - $self->throw_exception('Odd number of arguments to search') - } - else { - +{ @_ } - } - - } if @_; - - if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) { - # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas) - my $callsite = do { - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - carp; - $w - }; - carp 'search( %condition ) is deprecated, use search( \%condition ) instead' - unless $callsites_warned->{$callsite}++; - } - for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( @@ -442,12 +553,19 @@ sub search_rs { return $rs; } +my $dark_sel_dumper; 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 # Keep the X vs +X separation until _resolved_attrs time - this allows to # delay the decision on whether to use a default select list ($rsrc->columns) @@ -459,9 +577,7 @@ sub _normalize_selection { # supplied at all) - try to infer the alias, either from the -as parameter # of the selector spec, or use the parameter whole if it looks like a column # name (ugly legacy heuristic). If all fails - leave the selector bare (which - # is ok as well), but transport it over a separate attribute to make sure it is - # the last thing in the select list, thus unable to throw off the corresponding - # 'as' chain + # is ok as well), but make sure no more additions to the 'as' chain take place for my $pref ('', '+') { my ($sel, $as) = map { @@ -484,77 +600,100 @@ sub _normalize_selection { ); } elsif( ! @$as ) { - # no as part supplied at all - try to deduce + # no as part supplied at all - try to deduce (unless explicit end of named selection is declared) # if any @$as has been supplied we assume the user knows what (s)he is doing # and blindly keep stacking up pieces - my (@new_sel, @new_trailing); - for (@$sel) { - if ( ref $_ eq 'HASH' and exists $_->{-as} ) { - push @$as, $_->{-as}; - push @new_sel, $_; - } - # assume any plain no-space, no-parenthesis string to be a column spec - # FIXME - this is retarded but is necessary to support shit like 'count(foo)' - elsif ( ! ref $_ and $_ =~ /^ [^\s\(\)]+ $/x) { - push @$as, $_; - push @new_sel, $_; - } - # if all else fails - shove the selection to the trailing stack and move on - else { - push @new_trailing, $_; + unless ($attrs->{_dark_selector}) { + SELECTOR: + for (@$sel) { + if ( ref $_ eq 'HASH' and exists $_->{-as} ) { + push @$as, $_->{-as}; + } + # assume any plain no-space, no-parenthesis string to be a column spec + # FIXME - this is retarded but is necessary to support shit like 'count(foo)' + elsif ( ! ref $_ and $_ =~ /^ [^\s\(\)]+ $/x) { + push @$as, $_; + } + # if all else fails - raise a flag that no more aliasing will be allowed + else { + $attrs->{_dark_selector} = { + plus_stage => $pref, + string => ($dark_sel_dumper ||= do { + require Data::Dumper::Concise; + Data::Dumper::Concise::DumperObject()->Indent(0); + })->Values([$_])->Dump + , + }; + last SELECTOR; + } } } - - @$sel = @new_sel; - $attrs->{"${pref}_trailing_select"} = $self->_merge_attr($attrs->{"${pref}_trailing_select"}, \@new_trailing) - if @new_trailing; } elsif (@$as < @$sel) { $self->throw_exception( "Unable to handle an ${pref}as specification (@$as) with less elements than the corresponding ${pref}select" ); } - - # now see what the result for this pair looks like: - if (@$as == @$sel) { - - # if balanced - treat as a columns entry - $attrs->{"${pref}columns"} = $self->_merge_attr( - $attrs->{"${pref}columns"}, - [ map { +{ $as->[$_] => $sel->[$_] } } ( 0 .. $#$as ) ] + elsif ($pref and $attrs->{_dark_selector}) { + $self->throw_exception( + "Unable to process named '+select', resultset contains an unnamed selector $attrs->{_dark_selector}{string}" ); } - else { - # unbalanced - shove in select/as, not subject to deduplication in _resolved_attrs - $attrs->{"${pref}select"} = $self->_merge_attr($attrs->{"${pref}select"}, $sel); - $attrs->{"${pref}as"} = $self->_merge_attr($attrs->{"${pref}as"}, $as); - } - } + + # merge result + $attrs->{"${pref}select"} = $self->_merge_attr($attrs->{"${pref}select"}, $sel); + $attrs->{"${pref}as"} = $self->_merge_attr($attrs->{"${pref}as"}, $as); + } } sub _stack_cond { my ($self, $left, $right) = @_; - if (defined $left xor defined $right) { + + ( + (ref $_ eq 'ARRAY' and !@$_) + or + (ref $_ eq 'HASH' and ! keys %$_) + ) and $_ = undef for ($left, $right); + + # either on of the two undef or both undef + if ( ( (defined $left) xor (defined $right) ) or ! defined $left ) { return defined $left ? $left : $right; } - elsif (defined $left) { - return { -and => [ map - { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ } - ($left, $right) - ]}; + + my $cond = $self->result_source->schema->storage->_collapse_cond({ -and => [$left, $right] }); + + for my $c (grep { ref $cond->{$_} eq 'ARRAY' and ($cond->{$_}[0]||'') eq '-and' } keys %$cond) { + + my @vals = sort @{$cond->{$c}}[ 1..$#{$cond->{$c}} ]; + my @fin = shift @vals; + + for my $v (@vals) { + push @fin, $v unless Data::Compare::Compare( $fin[-1], $v ); + } + + $cond->{$c} = (@fin == 1) ? $fin[0] : [-and => @fin ]; } - return undef; + $cond; } =head2 search_literal +B: C is provided for Class::DBI compatibility and +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 +L for searching techniques that do not +require C. + =over 4 -=item Arguments: $sql_fragment, @bind_values +=item Arguments: $sql_fragment, @standalone_bind_values -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -564,21 +703,11 @@ sub _stack_cond { Pass a literal chunk of SQL to be added to the conditional part of the resultset query. -CAVEAT: C is provided for Class::DBI compatibility and should -only be used in that context. C is a convenience method. -It is equivalent to calling $schema->search(\[]), but if you want to ensure -columns are bound correctly, use C. - Example of how to use C instead of C my @cds = $cd_rs->search_literal('cdid = ? AND (artist = ? OR artist = ?)', (2, 1, 2)); my @cds = $cd_rs->search(\[ 'cdid = ? AND (artist = ? OR artist = ?)', [ 'cdid', 2 ], [ 'artist', 1 ], [ 'artist', 2 ] ]); - -See L and -L for searching techniques that do not -require C. - =cut sub search_literal { @@ -587,16 +716,16 @@ sub search_literal { if ( @bind && ref($bind[-1]) eq 'HASH' ) { $attr = pop @bind; } - return $self->search(\[ $sql, map [ __DUMMY__ => $_ ], @bind ], ($attr || () )); + return $self->search(\[ $sql, map [ {} => $_ ], @bind ], ($attr || () )); } =head2 find =over 4 -=item Arguments: \%columns_values | @pk_values, \%attrs? +=item Arguments: \%columns_values | @pk_values, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $row_object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -628,7 +757,7 @@ Note that this fallback behavior may be deprecated in further versions. If you need to search with arbitrary conditions - use L. If the query resulting from this fallback produces more than one row, a warning to the effect is issued, though only the first row is constructed and returned as -C<$row_object>. +C<$result_object>. In addition to C, L recognizes and applies standard L in the same way as L does. @@ -663,57 +792,69 @@ sub find { my $rsrc = $self->result_source; + my $constraint_name; + if (exists $attrs->{key}) { + $constraint_name = defined $attrs->{key} + ? $attrs->{key} + : $self->throw_exception("An undefined 'key' resultset attribute makes no sense") + ; + } + # Parse out the condition from input my $call_cond; + if (ref $_[0] eq 'HASH') { $call_cond = { %{$_[0]} }; } else { - my $constraint = exists $attrs->{key} ? $attrs->{key} : 'primary'; - my @c_cols = $rsrc->unique_constraint_columns($constraint); + # if only values are supplied we need to default to 'primary' + $constraint_name = 'primary' unless defined $constraint_name; + + my @c_cols = $rsrc->unique_constraint_columns($constraint_name); $self->throw_exception( - "No constraint columns, maybe a malformed '$constraint' constraint?" + "No constraint columns, maybe a malformed '$constraint_name' constraint?" ) unless @c_cols; $self->throw_exception ( 'find() expects either a column/value hashref, or a list of values ' - . "corresponding to the columns of the specified unique constraint '$constraint'" + . "corresponding to the columns of the specified unique constraint '$constraint_name'" ) unless @c_cols == @_; $call_cond = {}; @{$call_cond}{@c_cols} = @_; } - my %related; 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 (exists $attrs->{key}) { + if (defined $constraint_name) { $final_cond = $self->_qualify_cond_columns ( $self->_build_unique_cond ( - $attrs->{key}, + $constraint_name, $call_cond, ), @@ -751,7 +892,7 @@ sub find { # Run the query, passing the result_class since it should propagate for find my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs}); - if (keys %{$rs->_resolved_attrs->{collapse}}) { + if ($rs->_resolved_attrs->{collapse}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; return $row; @@ -797,7 +938,6 @@ sub _qualify_cond_columns { return \%aliased; } -my $callsites_warned_ucond; sub _build_unique_cond { my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_; @@ -832,22 +972,15 @@ sub _build_unique_cond { and !$ENV{DBIC_NULLABLE_KEY_NOWARN} and - my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond) + my @undefs = sort grep { ! defined $final_cond->{$_} } (keys %$final_cond) ) { - my $callsite = do { - my $w; - local $SIG{__WARN__} = sub { $w = shift }; - carp; - $w - }; - - carp ( sprintf ( + 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), - )) unless $callsites_warned_ucond->{$callsite}++; + )); } return $final_cond; @@ -857,9 +990,9 @@ sub _build_unique_cond { =over 4 -=item Arguments: $rel, $cond, \%attrs? +=item Arguments: $rel_name, $cond?, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $new_resultset +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -870,6 +1003,11 @@ sub _build_unique_cond { Searches the specified relationship, optionally specifying a condition and attributes for matching records. See L for more information. +In list context, C<< ->all() >> is called implicitly on the resultset, thus +returning a list of result objects instead. To avoid that, use L. + +See also L. + =cut sub search_related { @@ -893,7 +1031,7 @@ sub search_related_rs { =item Arguments: none -=item Return Value: $cursor +=item Return Value: L<$cursor|DBIx::Class::Cursor> =back @@ -903,22 +1041,23 @@ L for more information. =cut sub cursor { - my ($self) = @_; - - my $attrs = $self->_resolved_attrs_copy; + my $self = shift; - return $self->{cursor} - ||= $self->result_source->storage->select($attrs->{from}, $attrs->{select}, - $attrs->{where},$attrs); + return $self->{cursor} ||= do { + my $attrs = $self->_resolved_attrs; + $self->result_source->storage->select( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ); + }; } =head2 single =over 4 -=item Arguments: $cond? +=item Arguments: L<$cond?|DBIx::Class::SQLMaker> -=item Return Value: $row_object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -961,13 +1100,11 @@ sub single { $self->throw_exception('single() only takes search conditions, no attributes. You want ->search( $cond, $attrs )->single()'); } - my $attrs = $self->_resolved_attrs_copy; + my $attrs = { %{$self->_resolved_attrs} }; - if (keys %{$attrs->{collapse}}) { - $self->throw_exception( - 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' - ); - } + $self->throw_exception( + 'single() can not be used on resultsets collapsing a has_many. Use find( \%cond ) or next() instead' + ) if $attrs->{collapse}; if ($where) { if (defined $attrs->{where}) { @@ -981,54 +1118,23 @@ sub single { } } - my @data = $self->result_source->storage->select_single( + my $data = [ $self->result_source->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs - ); - - return (@data ? ($self->_construct_object(@data))[0] : undef); -} - - -# _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; + return undef unless @$data; + $self->{_stashed_rows} = [ $data ]; + $self->_construct_results->[0]; } =head2 get_column =over 4 -=item Arguments: $cond? +=item Arguments: L<$cond?|DBIx::Class::SQLMaker> -=item Return Value: $resultsetcolumn +=item Return Value: L<$resultsetcolumn|DBIx::Class::ResultSetColumn> =back @@ -1048,9 +1154,9 @@ sub get_column { =over 4 -=item Arguments: $cond, \%attrs? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -1076,7 +1182,7 @@ instead. An example conversion is: sub search_like { my $class = shift; - carp ( + carp_unique ( 'search_like() is deprecated and will be removed in DBIC version 0.09.' .' Instead use ->search({ x => { -like => "y%" } })' .' (note the outer pair of {}s - they are important!)' @@ -1093,7 +1199,7 @@ sub search_like { =item Arguments: $first, $last -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: L<$resultset|/search> (scalar context) | L<@result_objs|DBIx::Class::Manual::ResultClass> (list context) =back @@ -1112,8 +1218,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 @@ -1122,7 +1226,7 @@ sub slice { =item Arguments: none -=item Return Value: $result | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back @@ -1143,170 +1247,301 @@ first record from the resultset. sub next { my ($self) = @_; + if (my $cache = $self->get_cache) { $self->{all_cache_position} ||= 0; return $cache->[$self->{all_cache_position}++]; } + if ($self->{attrs}{cache}) { delete $self->{pager}; $self->{all_cache_position} = 1; return ($self->all)[0]; } - if ($self->{stashed_objects}) { - my $obj = shift(@{$self->{stashed_objects}}); - delete $self->{stashed_objects} unless @{$self->{stashed_objects}}; - return $obj; - } - my @row = ( - exists $self->{stashed_row} - ? @{delete $self->{stashed_row}} - : $self->cursor->next - ); - return undef unless (@row); - my ($row, @more) = $self->_construct_object(@row); - $self->{stashed_objects} = \@more if @more; - return $row; -} -sub _construct_object { - my ($self, @row) = @_; + return shift(@{$self->{_stashed_results}}) if @{ $self->{_stashed_results}||[] }; - my $info = $self->_collapse_result($self->{_attrs}{as}, \@row) - or return (); - my @new = $self->result_class->inflate_result($self->result_source, @$info); - @new = $self->{_attrs}{record_filter}->(@new) - if exists $self->{_attrs}{record_filter}; - return @new; -} + $self->{_stashed_results} = $self->_construct_results + or return undef; -sub _collapse_result { - my ($self, $as_proto, $row) = @_; + return shift @{$self->{_stashed_results}}; +} - my @copy = @$row; +# Constructs as many results as it can in one pass while respecting +# cursor laziness. Several modes of operation: +# +# * Always builds everything present in @{$self->{_stashed_rows}} +# * If called with $fetch_all true - pulls everything off the cursor and +# builds all result structures (or objects) in one pass +# * If $self->_resolved_attrs->{collapse} is true, checks the order_by +# and if the resultset is ordered properly by the left side: +# * Fetches stuff off the cursor until the "master object" changes, +# and saves the last extra row (if any) in @{$self->{_stashed_rows}} +# OR +# * Just fetches, and collapses/constructs everything as if $fetch_all +# was requested (there is no other way to collapse except for an +# eager cursor) +# * If no collapse is requested - just get the next row, construct and +# return +sub _construct_results { + my ($self, $fetch_all) = @_; - # 'foo' => [ undef, 'foo' ] - # 'foo.bar' => [ 'foo', 'bar' ] - # 'foo.bar.baz' => [ 'foo.bar', 'baz' ] + my $rsrc = $self->result_source; + my $attrs = $self->_resolved_attrs; - my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto; + 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}, $_} @pcols ]; + $attrs->{_ordered_for_collapse} = 1; + $attrs->{_order_is_artificial} = 1; + } - my %collapse = %{$self->{_attrs}{collapse}||{}}; + # 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 @pri_index; + my $cursor; # we may not need one at all - # if we're doing collapsing (has_many prefetch) we need to grab records - # until the PK changes, so fill @pri_index. if not, we leave it empty so - # we know we don't have to bother. + my $did_fetch_all = $fetch_all; - # the reason for not using the collapse stuff directly is because if you - # had for e.g. two artists in a row with no cds, the collapse info for - # both would be NULL (undef) so you'd lose the second artist + if ($fetch_all) { + # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + $rows = [ ($rows ? @$rows : ()), $self->cursor->all ]; + } + elsif( $attrs->{collapse} ) { - # store just the index so we can check the array positions from the row - # without having to contruct the full hash + # a cursor will need to be closed over in case of collapse + $cursor = $self->cursor; - if (keys %collapse) { - my %pri = map { ($_ => 1) } $self->result_source->_pri_cols; - foreach my $i (0 .. $#construct_as) { - next if defined($construct_as[$i][0]); # only self table - if (delete $pri{$construct_as[$i][1]}) { - push(@pri_index, $i); + $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}) { + $did_fetch_all = 1; + + # instead of looping over ->next, use ->all in stealth mode + # *without* calling a ->reset afterwards + # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending + if (! $cursor->{_done}) { + $rows = [ ($rows ? @$rows : ()), $cursor->all ]; + $cursor->{_done} = 1; } - last unless keys %pri; # short circuit (Johnny Five Is Alive!) } } - # no need to do an if, it'll be empty if @pri_index is empty anyway + 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 ]; + } + } + + return undef unless @{$rows||[]}; - my %pri_vals = map { ($_ => $copy[$_]) } @pri_index; + # sanity check - people are too clever for their own good + if ($attrs->{collapse} and my $aliastypes = $attrs->{_last_sqlmaker_alias_map} ) { - my @const_rows; + 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}} + } + } - do { # no need to check anything at the front, we always want the first row + for my $i (0 .. $#{$attrs->{as}} ) { + my $sel = $attrs->{select}[$i]; - my %const; + if (ref $sel eq 'SCALAR') { + $sel = $$sel; + } + elsif( ref $sel eq 'REF' and ref $$sel eq 'ARRAY' ) { + $sel = $$sel->[0]; + } - foreach my $this_as (@construct_as) { - $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy); + $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] !~ /\./); } + } - push(@const_rows, \%const); + # hotspot - skip the setter + my $res_class = $self->_result_class; + + my $inflator_cref = $self->{_result_inflator}{cref} ||= do { + $res_class->can ('inflate_result') + or $self->throw_exception("Inflator $res_class does not provide an inflate_result() method"); + }; - } until ( # no pri_index => no collapse => drop straight out - !@pri_index - or - do { # get another row, stash it, drop out if different PK + my $infmap = $attrs->{as}; - @copy = $self->cursor->next; - $self->{stashed_row} = \@copy; + $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}; - # last thing in do block, counts as true if anything doesn't match + $self->{_result_inflator}{is_hri} = ( ( + ! $self->{_result_inflator}{is_core_row} + and + $inflator_cref == ( + require DBIx::Class::ResultClass::HashRefInflator + && + DBIx::Class::ResultClass::HashRefInflator->can('inflate_result') + ) + ) ? 1 : 0 ) unless defined $self->{_result_inflator}{is_hri}; - # check xor defined first for NULL vs. NOT NULL then if one is - # defined the other must be so check string equality - grep { - (defined $pri_vals{$_} ^ defined $copy[$_]) - || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_])) - } @pri_index; + 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 }; } - ); + } + # FIXME SUBOPTIMAL this is a very very very hot spot + # while rather optimal we can *still* do much better, by + # building a smarter Row::inflate_result(), and + # switch to feeding it data via a much leaner interface + # + # crude unscientific benchmarking indicated the shortcut eval is not worth it for + # this particular resultset size + 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 ( + ( $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 ) ) + ); + } + } + else { + my $parser_type = + $self->{_result_inflator}{is_hri} ? 'hri' + : $self->{_result_inflator}{is_core_row} ? 'classic_pruning' + : 'classic_nonpruning' + ; - my $alias = $self->{attrs}{alias}; - my $info = []; + # $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} ) { + + $err = + 'Collapse aborted due to invalid ResultSource metadata - the following ' + . 'selections are declared non-nullable but NULLs were retrieved: ' + ; - my %collapse_pos; + my @violating_idx; + COL: for my $i (@$check_non_null_cols) { + ! defined $_->[$i] and push @violating_idx, $i and next COL for @$rows; + } - my @const_keys; + $self->throw_exception( $err . join (', ', map { "'$infmap->[$_]'" } @violating_idx ) ) + if @violating_idx; - foreach my $const (@const_rows) { - scalar @const_keys or do { - @const_keys = sort { length($a) <=> length($b) } keys %$const; - }; - foreach my $key (@const_keys) { - if (length $key) { - my $target = $info; - my @parts = split(/\./, $key); - my $cur = ''; - my $data = $const->{$key}; - foreach my $p (@parts) { - $target = $target->[1]->{$p} ||= []; - $cur .= ".${p}"; - if ($cur eq ".${key}" && (my @ckey = @{$collapse{$cur}||[]})) { - # collapsing at this point and on final part - my $pos = $collapse_pos{$cur}; - CK: foreach my $ck (@ckey) { - if (!defined $pos->{$ck} || $pos->{$ck} ne $data->{$ck}) { - $collapse_pos{$cur} = $data; - delete @collapse_pos{ # clear all positioning for sub-entries - grep { m/^\Q${cur}.\E/ } keys %collapse_pos - }; - push(@$target, []); - last CK; - } - } - } - if (exists $collapse{$cur}) { - $target = $target->[-1]; - } - } - $target->[0] = $data; - } else { - $info->[0] = $const->{$key}; + $unrolled_non_null_cols_to_check = join (',', @$check_non_null_cols); + } + + 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} = [] ) : (), + ); + + # 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; } } - return $info; + # 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; } =head2 result_source =over 4 -=item Arguments: $result_source? +=item Arguments: L<$result_source?|DBIx::Class::ResultSource> -=item Return Value: $result_source +=item Return Value: L<$result_source|DBIx::Class::ResultSource> =back @@ -1323,7 +1558,7 @@ is derived. =back -An accessor for the class to use when creating row objects. Defaults to +An accessor for the class to use when creating result objects. Defaults to C<< result_source->result_class >> - which in most cases is the name of the L<"table"|DBIx::Class::Manual::Glossary/"ResultSource"> class. @@ -1337,14 +1572,22 @@ in the original source class will not run. sub result_class { my ($self, $result_class) = @_; if ($result_class) { - unless (ref $result_class) { # don't fire this for an object - $self->ensure_class_loaded($result_class); + + # don't fire this for an object + $self->ensure_class_loaded($result_class) + unless ref($result_class); + + if ($self->get_cache) { + carp_unique('Changing the result_class of a ResultSet instance with cached results is a noop - the cache contents will not be altered'); + } + # FIXME ENCAPSULATION - encapsulation breach, cursor method additions pending + elsif ($self->{cursor} && $self->{cursor}{_pos}) { + $self->throw_exception('Changing the result_class of a ResultSet instance with an active cursor is not supported'); } + $self->_result_class($result_class); - # THIS LINE WOULD BE A BUG - this accessor specifically exists to - # permit the user to set result class on one result set only; it only - # chains if provided to search() - #$self->{attrs}{result_class} = $result_class if ref $self; + + delete $self->{_result_inflator}; } $self->_result_class; } @@ -1353,7 +1596,7 @@ sub result_class { =over 4 -=item Arguments: $cond, \%attrs?? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> =item Return Value: $count @@ -1370,12 +1613,11 @@ sub count { return $self->search(@_)->count if @_ and defined $_[0]; return scalar @{ $self->get_cache } if $self->get_cache; - my $attrs = $self->_resolved_attrs_copy; + my $attrs = { %{ $self->_resolved_attrs } }; # this is a little optimization - it is faster to do the limit # adjustments in software, instead of a subquery - my $rows = delete $attrs->{rows}; - my $offset = delete $attrs->{offset}; + my ($rows, $offset) = delete @{$attrs}{qw/rows offset/}; my $crs; if ($self->_has_resolved_attr (qw/collapse group_by/)) { @@ -1397,9 +1639,9 @@ sub count { =over 4 -=item Arguments: $cond, \%attrs?? +=item Arguments: L<$cond|DBIx::Class::SQLMaker>, L<\%attrs?|/ATTRIBUTES> -=item Return Value: $count_rs +=item Return Value: L<$count_rs|DBIx::Class::ResultSetColumn> =back @@ -1423,10 +1665,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}); } } @@ -1437,20 +1679,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'; - delete @{$tmp_attrs}{qw/columns _trailing_select/}; - - 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'); } # @@ -1460,16 +1699,20 @@ 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 _trailing_select order_by for/}; + delete @{$sub_attrs}{qw/collapse columns as select order_by for/}; - # if we multi-prefetch we group_by primary keys only as this is what we would + # 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 - if ( keys %{$attrs->{collapse}} ) { - $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } ($rsrc->_pri_cols) ] + if ( $attrs->{collapse} ) { + $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{ + $rsrc->_identifying_column_set || $self->throw_exception( + 'Unable to construct a unique group_by criteria properly collapsing the ' + . 'has_many prefetch before count()' + ); + } ] } # Calculate subquery selector @@ -1501,18 +1744,22 @@ sub _count_subq_rs { my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep); - my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); + my $having_sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); + my %seen_having; # search for both a proper quoted qualified string, for a naive unquoted scalarref # and if all fails for an utterly naive quoted scalar-with-function - while ($sql =~ / + while ($having_sql =~ / $rquote $sep $lquote (.+?) $rquote | [\s,] \w+ \. (\w+) [\s,] | [\s,] $lquote (.+?) $rquote [\s,] /gx) { - push @parts, ($1 || $2 || $3); # one of them matched if we got here + my $part = $1 || $2 || $3; # one of them matched if we got here + unless ($seen_having{$part}++) { + push @parts, $part; + } } } @@ -1542,15 +1789,15 @@ sub _count_subq_rs { ->get_column ('count'); } -sub _bool { - return 1; -} =head2 count_literal +B: C is provided for Class::DBI compatibility and +should only be used in that context. See L for further info. + =over 4 -=item Arguments: $sql_fragment, @bind_values +=item Arguments: $sql_fragment, @standalone_bind_values =item Return Value: $count @@ -1569,45 +1816,33 @@ sub count_literal { shift->search_literal(@_)->count; } =item Arguments: none -=item Return Value: @objects +=item Return Value: L<@result_objs|DBIx::Class::Manual::ResultClass> =back -Returns all elements in the resultset. Called implicitly if the resultset -is returned in list context. +Returns all elements in the resultset. =cut sub all { my $self = shift; if(@_) { - $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); + $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); } - return @{ $self->get_cache } if $self->get_cache; - - my @obj; - - if (keys %{$self->_resolved_attrs->{collapse}}) { - # Using $self->cursor->all is really just an optimisation. - # If we're collapsing has_many prefetches it probably makes - # very little difference, and this is cleaner than hacking - # _construct_object to survive the approach - $self->cursor->reset; - my @row = $self->cursor->next; - while (@row) { - push(@obj, $self->_construct_object(@row)); - @row = (exists $self->{stashed_row} - ? @{delete $self->{stashed_row}} - : $self->cursor->next); - } - } else { - @obj = map { $self->_construct_object(@$_) } $self->cursor->all; + delete @{$self}{qw/_stashed_rows _stashed_results/}; + + if (my $c = $self->get_cache) { + return @$c; } - $self->set_cache(\@obj) if $self->{attrs}{cache}; + $self->cursor->reset; + + my $objs = $self->_construct_results('fetch_all') || []; - return @obj; + $self->set_cache($objs) if $self->{attrs}{cache}; + + return @$objs; } =head2 reset @@ -1628,7 +1863,8 @@ another query. sub reset { my ($self) = @_; - delete $self->{_attrs} if exists $self->{_attrs}; + + delete @{$self}{qw/_stashed_rows _stashed_results/}; $self->{all_cache_position} = 0; $self->cursor->reset; return $self; @@ -1640,12 +1876,12 @@ sub reset { =item Arguments: none -=item Return Value: $object | undef +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> | undef =back -Resets the resultset and returns an object for the first result (or C -if the resultset is empty). +L the resultset (causing a fresh query to storage) and returns +an object for the first result (or C if the resultset is empty). =cut @@ -1664,63 +1900,141 @@ sub _rs_update_delete { my ($self, $op, $values) = @_; my $rsrc = $self->result_source; + my $storage = $rsrc->schema->storage; - # if a condition exists we need to strip all table qualifiers - # if this is not possible we'll force a subquery below - my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond}); + my $attrs = { %{$self->_resolved_attrs} }; - my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/); - my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/rows offset/); + my $join_classifications; + my ($existing_group_by) = delete @{$attrs}{qw(group_by _grouped_by_distinct)}; - if ($needs_group_by_subq or $needs_subq) { + # do we need a subquery for any reason? + my $needs_subq = ( + defined $existing_group_by + or + # if {from} is unparseable wrap a subq + ref($attrs->{from}) ne 'ARRAY' + or + # limits call for a subq + $self->_has_resolved_attr(qw/rows offset/) + ); - # make a new $rs selecting only the PKs (that's all we really need) - my $attrs = $self->_resolved_attrs_copy; + # simplify the joinmap, so we can further decide if a subq is necessary + if (!$needs_subq and @{$attrs->{from}} > 1) { + ($attrs->{from}, $join_classifications) = + $storage->_prune_unused_joins ($attrs); - delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/; - $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ]; + # any non-pruneable non-local restricting joins imply subq + $needs_subq = defined List::Util::first { $_ ne $attrs->{alias} } keys %{ $join_classifications->{restricting} || {} }; + } - if ($needs_group_by_subq) { - # make sure no group_by was supplied, or if there is one - make sure it matches - # the columns compiled above perfectly. Anything else can not be sanely executed - # on most databases so croak right then and there + # check if the head is composite (by now all joins are thrown out unless $needs_subq) + $needs_subq ||= ( + (ref $attrs->{from}[0]) ne 'HASH' + or + ref $attrs->{from}[0]{ $attrs->{from}[0]{-alias} } + ); - if (my $g = $attrs->{group_by}) { - my @current_group_by = map - { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" } - @$g - ; + my ($cond, $guard); + # do we need anything like a subquery? + if (! $needs_subq) { + # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus + # 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; + local $sqla->{_dequalify_idents} = 1; + \[ $sqla->_recurse_where($self->{cond}) ]; + }; + } + else { + # we got this far - means it is time to wrap a subquery + my $idcols = $rsrc->_identifying_column_set || $self->throw_exception( + sprintf( + "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'", + $op, + $rsrc->source_name, + ) + ); - if ( - join ("\x00", sort @current_group_by) - ne - join ("\x00", sort @{$attrs->{columns}} ) - ) { - $self->throw_exception ( - "You have just attempted a $op operation on a resultset which does group_by" - . ' on columns other than the primary keys, while DBIC internally needs to retrieve' - . ' the primary keys in a subselect. All sane RDBMS engines do not support this' - . ' kind of queries. Please retry the operation with a modified group_by or' - . ' without using one at all.' - ); - } - } - else { - $attrs->{group_by} = $attrs->{columns}; - } - } + # make a new $rs selecting only the PKs (that's all we really need for the subq) + delete $attrs->{$_} for qw/select as collapse/; + $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ]; + + # this will be consumed by the pruner waaaaay down the stack + $attrs->{_force_prune_multiplying_joins} = 1; my $subrs = (ref $self)->new($rsrc, $attrs); - return $self->result_source->storage->_subq_update_delete($subrs, $op, $values); - } - else { - return $rsrc->storage->$op( - $rsrc, - $op eq 'update' ? $values : (), - $cond, - ); + + if (@$idcols == 1) { + $cond = { $idcols->[0] => { -in => $subrs->as_query } }; + } + elsif ($storage->_use_multicolumn_in) { + # no syntax for calling this properly yet + # !!! EXPERIMENTAL API !!! WILL CHANGE !!! + $cond = $storage->sql_maker->_where_op_multicolumn_in ( + $idcols, # how do I convey a list of idents...? can binds reside on lhs? + $subrs->as_query + ), + } + else { + # if all else fails - get all primary keys and operate over a ORed set + # wrap in a transaction for consistency + # this is where the group_by/multiplication starts to matter + 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 + # perfectly. Anything else can not be sanely executed on most databases so croak + # right then and there + if ($existing_group_by) { + my @current_group_by = map + { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" } + @$existing_group_by + ; + + if ( + join ("\x00", sort @current_group_by) + ne + join ("\x00", sort @{$attrs->{columns}} ) + ) { + $self->throw_exception ( + "You have just attempted a $op operation on a resultset which does group_by" + . ' on columns other than the primary keys, while DBIC internally needs to retrieve' + . ' the primary keys in a subselect. All sane RDBMS engines do not support this' + . ' kind of queries. Please retry the operation with a modified group_by or' + . ' without using one at all.' + ); + } + } + + $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); + } + + $guard = $storage->txn_scope_guard; + + for my $row ($subrs->cursor->all) { + push @$cond, { map + { $idcols->[$_] => $row->[$_] } + (0 .. $#$idcols) + }; + } + } } + + my $res = $cond ? $storage->$op ( + $rsrc, + $op eq 'update' ? $values : (), + $cond, + ) : '0E0'; + + $guard->commit if $guard; + + return $res; } =head2 update @@ -1729,17 +2043,17 @@ sub _rs_update_delete { =item Arguments: \%values -=item Return Value: $storage_rv +=item Return Value: $underlying_storage_rv =back Sets the specified columns in the resultset to the supplied values in a single query. Note that this will not run any accessor/set_column/update -triggers, nor will it update any row object instances derived from this +triggers, nor will it update any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-update triggers or cascades defined either by you or a -L. +L. The return value is a pass through of what the underlying storage backend returned, and may vary. See L for the most @@ -1752,7 +2066,7 @@ This is unlike the corresponding L. The user must ensure manually that any value passed to this method will stringify to something the RDBMS knows how to deal with. A notable example is the handling of L objects, for more info see: -L. +L. =cut @@ -1786,7 +2100,7 @@ sub update_all { unless ref $values eq 'HASH'; my $guard = $self->result_source->schema->txn_scope_guard; - $_->update($values) for $self->all; + $_->update({%$values}) for $self->all; # shallow copy - update will mangle it $guard->commit; return 1; } @@ -1797,17 +2111,17 @@ sub update_all { =item Arguments: none -=item Return Value: $storage_rv +=item Return Value: $underlying_storage_rv =back Deletes the rows matching this resultset in a single query. Note that this will not run any delete triggers, nor will it alter the -L status of any row object instances +L status of any result object instances derived from this resultset (this includes the contents of the L if any). See L if you need to execute any on-delete triggers or cascades defined either by you or a -L. +L. The return value is a pass through of what the underlying storage backend returned, and may vary. See L for the most common case. @@ -1853,28 +2167,55 @@ sub delete_all { =over 4 -=item Arguments: \@data; +=item Arguments: [ \@column_list, \@row_values+ ] | [ \%col_data+ ] + +=item Return Value: L<\@result_objects|DBIx::Class::Manual::ResultClass> (scalar context) | L<@result_objects|DBIx::Class::Manual::ResultClass> (list context) =back -Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs. -For the arrayref of hashrefs style each hashref should be a structure suitable -forsubmitting to a $resultset->create(...) method. +Accepts either an arrayref of hashrefs or alternatively an arrayref of +arrayrefs. + +=over + +=item NOTE -In void context, C in L is used -to insert the data, as this is a faster method. +The context of this method call has an important effect on what is +submitted to storage. In void context data is fed directly to fastpath +insertion routines provided by the underlying storage (most often +L), bypassing the L and +L calls on the +L class, including any +augmentation of these methods provided by components. For example if you +are using something like L to create primary +keys for you, you will find that your PKs are empty. In this case you +will have to explicitly force scalar or list context in order to create +those values. + +=back -Otherwise, each set of data is inserted into the database using -L, and the resulting objects are -accumulated into an array. The array itself, or an array reference -is returned depending on scalar or list context. +In non-void (scalar or list) context, this method is simply a wrapper +for L. Depending on list or scalar context either a list of +L objects or an arrayref +containing these objects is returned. -Example: Assuming an Artist Class that has many CDs Classes relating: +When supplying data in "arrayref of arrayrefs" invocation style, the +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: + + $schema->resultset("Artist")->populate([ + [ qw( artistid name ) ], + [ 100, 'A Formally Unknown Singer' ], + [ 101, 'A singer that jumped the shark two albums ago' ], + [ 102, 'An actually cool singer' ], + ]); - my $Artist_rs = $schema->resultset("Artist"); +For the arrayref of hashrefs style each hashref should be a structure +suitable for passing to L. Multi-create is also permitted with +this syntax. - ## Void Context Example - $Artist_rs->populate([ + $schema->resultset("Artist")->populate([ { artistid => 4, name => 'Manufactured Crap', cds => [ { title => 'My First CD', year => 2006 }, { title => 'Yet More Tweeny-Pop crap', year => 2007 }, @@ -1888,164 +2229,277 @@ Example: Assuming an Artist Class that has many CDs Classes relating: }, ]); - ## Array Context Example - my ($ArtistOne, $ArtistTwo, $ArtistThree) = $Artist_rs->populate([ - { name => "Artist One"}, - { name => "Artist Two"}, - { name => "Artist Three", cds=> [ - { title => "First CD", year => 2007}, - { title => "Second CD", year => 2008}, - ]} - ]); +If you attempt a void-context multi-create as in the example above (each +Artist also has the related list of CDs), and B supply the +necessary autoinc foreign key information, this method will proxy to the +less efficient L, and then throw the Result objects away. In this +case there are obviously no benefits to using this method over L. - print $ArtistOne->name; ## response is 'Artist One' - print $ArtistThree->cds->count ## reponse is '2' +=cut -For the arrayref of arrayrefs style, the first element should be a list of the -fieldsnames to which the remaining elements are rows being inserted. For -example: +sub populate { + my $self = shift; - $Arstist_rs->populate([ - [qw/artistid name/], - [100, 'A Formally Unknown Singer'], - [101, 'A singer that jumped the shark two albums ago'], - [102, 'An actually cool singer'], - ]); + my ($data, $guard); -Please note an important effect on your data when choosing between void and -wantarray context. Since void context goes straight to C in -L this will skip any component that is overriding -C. So if you are using something like L to -create primary keys for you, you will find that your PKs are empty. In this -case you will have to use the wantarray context in order to create those -values. + # this is naive and just a quick check + # the types will need to be checked more thoroughly when the + # multi-source populate gets added + if (ref $_[0] eq 'ARRAY') { + return unless @{$_[0]}; -=cut + $data = $_[0] if (ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY'); + } -sub populate { - my $self = shift; + $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs') + unless $data; - # cruft placed in standalone method - my $data = $self->_normalize_populate_args(@_); + # FIXME - no cref handling + # At this point assume either hashes or arrays if(defined wantarray) { - my @created; - foreach my $item (@$data) { - push(@created, $self->create($item)); - } - return wantarray ? @created : \@created; - } - else { - my $first = $data->[0]; + my @results; - # 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, $_ + $guard = $self->result_source->schema->storage->txn_scope_guard + if ( @$data > 2 or ( @$data == 2 and ref $data->[0] eq 'ARRAY' ) ); + + if (ref $data->[0] eq 'ARRAY') { + @results = map + { my $vals = $_; $self->new_result({ map { $data->[0][$_] => $vals->[$_] } 0..$#{$data->[0]} })->insert } + @{$data}[1 .. $#$data] ; } + else { + @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; - my @pks = $rsrc->primary_columns; + DATA_SLICE: + for my $i (0 .. $#$data) { - ## do the belongs_to relationships - foreach my $index (0..$#$data) { + my $current_slice_seen_rel_infos; - # 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; +### Determine/Supplement collists +### BEWARE - This is a hot piece of code, a lot of weird idioms were used + if( ref $data->[$i] eq 'ARRAY' ) { + + # positional(!) explicit column list + if ($i == 0) { + + $colinfo->{$data->[0][$_]} = { pos => $_, name => $data->[0][$_] } and push @$colnames, $data->[0][$_] + for 0 .. $#{$data->[0]}; + + $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}; - - push @columns, keys %$related if $index == 0; + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, { map { $colnames->[$_] => $data->[$i][$_] } 0 .. $#$colnames }; + + # 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' ) { + + for ( sort keys %{$data->[$i]} ) { + + $colinfo->{$_} ||= do { + + $self->throw_exception("Column '$_' must be present in supplied explicit column list") + if $data_start; # it will be 0 on AoH, 1 on AoA + + push @$colnames, $_; + + # RV + { pos => $#$colnames, name => $_ } + }; + + 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(@_); + } + } - ## inherit the data locked in the conditions of the resultset - my ($rs_data) = $self->_merge_with_rscond({}); - delete @{$rs_data}{@columns}; - my @inherit_cols = keys %$rs_data; - my @inherit_data = values %$rs_data; - - ## do bulk insert on current row - $rsrc->storage->insert_bulk( - $rsrc, - [@columns, @inherit_cols], - [ map { [ @$_{@columns}, @inherit_data ] } @$data ], - ); + push @$current_slice_seen_rel_infos, $rel_info->{$_}; + } + } - ## do the has_many relationships - foreach my $item (@$data) { + if ($current_slice_seen_rel_infos) { + push @$slices_with_rels, $data->[$i]; - my $main_row; + # 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] ); + } - foreach my $rel (@rels) { - next unless ref $item->{$rel} eq "ARRAY" && @{ $item->{$rel} }; + 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(@_); + } + } - $main_row ||= $self->new_result({map { $_ => $item->{$_} } @pks}); + if( $slices_with_rels ) { - my $child = $main_row->$rel; + # need to exclude the rel "columns" + $colnames = [ grep { ! $colinfo->{$_}{is_rel} } @$colnames ]; - my $related = $child->result_source->_resolve_condition( - $rels->{$rel}{cond}, - $child, - $main_row, - $rel, - ); + # 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); - my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); - my @populate = map { {%$_, %$related} } @rows_to_add; + $ci->{$_} = { %{$ci->{$_}}, is_nullable => 0 } + for grep { ! $colinfo->{$_}{seen_null} } keys %$ci; - $child->populate( \@populate ); - } + 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(@_); } } -} +### 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 -# populate() argumnets went over several incarnations -# What we ultimately support is AoH -sub _normalize_populate_args { - my ($self, $arg) = @_; + # 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; + } - if (ref $arg eq 'ARRAY') { - if (ref $arg->[0] eq 'HASH') { - return $arg; - } - 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) }; +### start work + $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 @@ -2054,11 +2508,11 @@ sub _normalize_populate_args { =item Arguments: none -=item Return Value: $pager +=item Return Value: L<$pager|Data::Page> =back -Return Value a L object for the current resultset. Only makes +Returns a L object for the current resultset. Only makes sense for queries with a C attribute. To get the full count of entries for a paged resultset, call @@ -2066,116 +2520,11 @@ C on the L object. =cut -# make a wizard good for both a scalar and a hashref -my $mk_lazy_count_wizard = sub { - require Variable::Magic; - - my $stash = { total_rs => shift }; - my $slot = shift; # only used by the hashref magic - - my $magic = Variable::Magic::wizard ( - data => sub { $stash }, - - (!$slot) - ? ( - # the scalar magic - get => sub { - # set value lazily, and dispell for good - ${$_[0]} = $_[1]{total_rs}->count; - Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref}); - return 1; - }, - set => sub { - # an explicit set implies dispell as well - # the unless() is to work around "fun and giggles" below - Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref}) - unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager'; - return 1; - }, - ) - : ( - # the uvar magic - fetch => sub { - if ($_[2] eq $slot and !$_[1]{inactive}) { - my $cnt = $_[1]{total_rs}->count; - $_[0]->{$slot} = $cnt; - - # attempting to dispell in a fetch handle (works in store), seems - # to invariable segfault on 5.10, 5.12, 5.13 :( - # so use an inactivator instead - #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref}); - $_[1]{inactive}++; - } - return 1; - }, - store => sub { - if (! $_[1]{inactive} and $_[2] eq $slot) { - #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref}); - $_[1]{inactive}++ - unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager'; - } - return 1; - }, - ), - ); - - $stash->{magic_selfref} = $magic; - weaken ($stash->{magic_selfref}); # this fails on 5.8.1 - - return $magic; -}; - -# the tie class for 5.8.1 -{ - package # hide from pause - DBIx::Class::__DBIC_LAZY_RS_COUNT__; - use base qw/Tie::Hash/; - - sub FIRSTKEY { my $dummy = scalar keys %{$_[0]{data}}; each %{$_[0]{data}} } - sub NEXTKEY { each %{$_[0]{data}} } - sub EXISTS { exists $_[0]{data}{$_[1]} } - sub DELETE { delete $_[0]{data}{$_[1]} } - sub CLEAR { %{$_[0]{data}} = () } - sub SCALAR { scalar %{$_[0]{data}} } - - sub TIEHASH { - $_[1]{data} = {%{$_[1]{selfref}}}; - %{$_[1]{selfref}} = (); - Scalar::Util::weaken ($_[1]{selfref}); - return bless ($_[1], $_[0]); - }; - - sub FETCH { - if ($_[1] eq $_[0]{slot}) { - my $cnt = $_[0]{data}{$_[1]} = $_[0]{total_rs}->count; - untie %{$_[0]{selfref}}; - %{$_[0]{selfref}} = %{$_[0]{data}}; - return $cnt; - } - else { - $_[0]{data}{$_[1]}; - } - } - - sub STORE { - $_[0]{data}{$_[1]} = $_[2]; - if ($_[1] eq $_[0]{slot}) { - untie %{$_[0]{selfref}}; - %{$_[0]{selfref}} = %{$_[0]{data}}; - } - $_[2]; - } -} - sub pager { my ($self) = @_; return $self->{pager} if $self->{pager}; - if ($self->get_cache) { - $self->throw_exception ('Pagers on cached resultsets are not supported'); - } - my $attrs = $self->{attrs}; if (!defined $attrs->{page}) { $self->throw_exception("Can't create pager for non-paged rs"); @@ -2188,70 +2537,16 @@ sub pager { # throw away the paging flags and re-run the count (possibly # with a subselect) to get the real total count my $count_attrs = { %$attrs }; - delete $count_attrs->{$_} for qw/rows offset page pager/; - my $total_rs = (ref $self)->new($self->result_source, $count_attrs); + delete @{$count_attrs}{qw/rows offset page pager/}; + my $total_rs = (ref $self)->new($self->result_source, $count_attrs); -### the following may seem awkward and dirty, but it's a thought-experiment -### necessary for future development of DBIx::DS. Do *NOT* change this code -### before talking to ribasushi/mst - - my $pager = Data::Page->new( - 0, #start with an empty set + require DBIx::Class::ResultSet::Pager; + return $self->{pager} = DBIx::Class::ResultSet::Pager->new( + sub { $total_rs->count }, #lazy-get the total $attrs->{rows}, $self->{attrs}{page}, ); - - my $data_slot = 'total_entries'; - - # Since we are interested in a cached value (once it's set - it's set), every - # technique will detach from the magic-host once the time comes to fire the - # ->count (or in the segfaulting case of >= 5.10 it will deactivate itself) - - if ($] < 5.008003) { - # 5.8.1 throws 'Modification of a read-only value attempted' when one tries - # to weakref the magic container :( - # tested on 5.8.1 - tie (%$pager, 'DBIx::Class::__DBIC_LAZY_RS_COUNT__', - { slot => $data_slot, total_rs => $total_rs, selfref => $pager } - ); - } - elsif ($] < 5.010) { - # We can use magic on the hash value slot. It's interesting that the magic is - # attached to the hash-slot, and does *not* stop working once I do the dummy - # assignments after the cast() - # tested on 5.8.3 and 5.8.9 - my $magic = $mk_lazy_count_wizard->($total_rs); - Variable::Magic::cast ( $pager->{$data_slot}, $magic ); - - # this is for fun and giggles - $pager->{$data_slot} = -1; - $pager->{$data_slot} = 0; - - # this does not work for scalars, but works with - # uvar magic below - #my %vals = %$pager; - #%$pager = (); - #%{$pager} = %vals; - } - else { - # And the uvar magic - # works on 5.10.1, 5.12.1 and 5.13.4 in its current form, - # however see the wizard maker for more notes - my $magic = $mk_lazy_count_wizard->($total_rs, $data_slot); - Variable::Magic::cast ( %$pager, $magic ); - - # still works - $pager->{$data_slot} = -1; - $pager->{$data_slot} = 0; - - # this now works - my %vals = %$pager; - %$pager = (); - %{$pager} = %vals; - } - - return $self->{pager} = $pager; } =head2 page @@ -2260,7 +2555,7 @@ sub pager { =item Arguments: $page_number -=item Return Value: $rs +=item Return Value: L<$resultset|/search> =back @@ -2279,16 +2574,16 @@ sub page { =over 4 -=item Arguments: \%vals +=item Arguments: \%col_data -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back -Creates a new row object in the resultset's result class and returns +Creates a new result object in the resultset's result class and returns it. The row is not inserted into the database at this point, call L to do that. Calling L -will tell you whether the row object has been inserted or not. +will tell you whether the result object has been inserted or not. Passes the hashref of input on to L. @@ -2296,20 +2591,38 @@ Passes the hashref of input on to L. sub new_result { my ($self, $values) = @_; - $self->throw_exception( "new_result needs a hash" ) + + $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'); my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values); - my %new = ( + my $new = $self->result_class->new({ %$merged_cond, - @$cols_from_relations + ( @$cols_from_relations ? (-cols_from_relations => $cols_from_relations) - : (), + : () + ), -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED - ); + }); + + if ( + reftype($new) eq 'HASH' + and + ! keys %$new + and + blessed($new) + ) { + carp_unique (sprintf ( + "%s->new returned a blessed empty hashref - a strong indicator something is wrong with its inheritance chain", + $self->result_class, + )); + } - return $self->result_class->new(\%new); + $new; } # _merge_with_rscond @@ -2321,51 +2634,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 @@ -2373,7 +2668,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 @@ -2421,38 +2716,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 @@ -2482,7 +2745,7 @@ sub _remove_alias { =item Arguments: none -=item Return Value: \[ $sql, @bind ] +=item Return Value: \[ $sql, L<@bind_values|/DBIC BIND VALUES> ] =back @@ -2495,27 +2758,22 @@ This is generally used as the RHS for a subquery. sub as_query { my $self = shift; - my $attrs = $self->_resolved_attrs_copy; + 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 =over 4 -=item Arguments: \%vals, \%attrs? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2523,7 +2781,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 @@ -2560,9 +2818,9 @@ sub find_or_new { =over 4 -=item Arguments: \%vals +=item Arguments: \%col_data -=item Return Value: a L $object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2586,12 +2844,11 @@ This can be applied recursively, and will work correctly for a structure with an arbitrary depth and width, as long as the relationships actually exists and the correct column data has been supplied. - Instead of hashrefs of plain related data (key/value pairs), you may also pass new or inserted objects. New objects (not inserted yet, see -L), will be inserted into their appropriate tables. +L), will be inserted into their appropriate tables. -Effectively a shortcut for C<< ->new_result(\%vals)->insert >>. +Effectively a shortcut for C<< ->new_result(\%col_data)->insert >>. Example of creating a new row. @@ -2629,28 +2886,28 @@ C resultset. Note Hashref. When subclassing ResultSet never attempt to override this method. Since it is a simple shortcut for C<< $self->new_result($attrs)->insert >>, a lot of the internals simply never call it, so your override will be -bypassed more often than not. Override either L -or L depending on how early in the -L process you need to intervene. +bypassed more often than not. Override either L +or L depending on how early in the +L process you need to intervene. See also warning pertaining to +L. =back =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 =over 4 -=item Arguments: \%vals, \%attrs? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back @@ -2697,6 +2954,23 @@ all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. +If you need to know if an existing row was found or a new one created use +L and L instead. Don't forget +to call L to save the newly created row to the +database! + + my $cd = $schema->resultset('CD')->find_or_new({ + cdid => 5, + artist => 'Massive Attack', + title => 'Mezzanine', + year => 2005, + }); + + if( !$cd->in_storage ) { + # do some stuff + $cd->insert; + } + =cut sub find_or_create { @@ -2706,23 +2980,23 @@ 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 =over 4 -=item Arguments: \%col_values, { key => $unique_constraint }? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $row_object +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_create({ col => $val, ... }); Like L, but if a row is found it is immediately updated via -C<< $found_row->update (\%col_values) >>. +C<< $found_row->update (\%col_data) >>. Takes an optional C attribute to search on a specific unique constraint. @@ -2758,6 +3032,11 @@ all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. +If you need to know if an existing row was updated or a new one created use +L and L instead. Don't forget +to call L to save the newly created row to the +database! + =cut sub update_or_create { @@ -2771,23 +3050,23 @@ sub update_or_create { return $row; } - return $self->create($cond); + return $self->new_result($cond)->insert; } =head2 update_or_new =over 4 -=item Arguments: \%col_values, { key => $unique_constraint }? +=item Arguments: \%col_data, { key => $unique_constraint, L<%attrs|/ATTRIBUTES> }? -=item Return Value: $rowobject +=item Return Value: L<$result|DBIx::Class::Manual::ResultClass> =back $resultset->update_or_new({ col => $val, ... }); Like L but if a row is found it is immediately updated via -C<< $found_row->update (\%col_values) >>. +C<< $found_row->update (\%col_data) >>. For example: @@ -2819,7 +3098,7 @@ supplied by the database (e.g. an auto_increment primary key column). In normal usage, the value of such columns should NOT be included at all in the call to C, even when set to C. -See also L, L and L. +See also L, L and L. =cut @@ -2843,7 +3122,7 @@ sub update_or_new { =item Arguments: none -=item Return Value: \@cache_objects | undef +=item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> | undef =back @@ -2862,15 +3141,15 @@ sub get_cache { =over 4 -=item Arguments: \@cache_objects +=item Arguments: L<\@result_objs|DBIx::Class::Manual::ResultClass> -=item Return Value: \@cache_objects +=item Return Value: L<\@result_objs|DBIx::Class::Manual::ResultClass> =back Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset. Note that -if the cache is set the resultset will return the cached objects rather +if the cache is set, the resultset will return the cached objects rather than re-querying the database even if the cache attr is not set. The contents of the cache can also be populated by using the @@ -2941,9 +3220,9 @@ sub is_ordered { =over 4 -=item Arguments: $relationship_name +=item Arguments: $rel_name -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -2956,8 +3235,10 @@ Returns a related resultset for the supplied relationship name. sub related_resultset { my ($self, $rel) = @_; - $self->{related_resultsets} ||= {}; - return $self->{related_resultsets}{$rel} ||= do { + return $self->{related_resultsets}{$rel} + if defined $self->{related_resultsets}{$rel}; + + return $self->{related_resultsets}{$rel} = do { my $rsrc = $self->result_source; my $rel_info = $rsrc->relationship_info($rel); @@ -2983,15 +3264,6 @@ sub related_resultset { #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi delete @{$attrs}{qw(result_class alias)}; - my $new_cache; - - if (my $cache = $self->get_cache) { - if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) { - $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} } - @$cache ]; - } - } - my $rel_source = $rsrc->related_source($rel); my $new = do { @@ -3012,7 +3284,16 @@ sub related_resultset { where => $attrs->{where}, }); }; - $new->set_cache($new_cache) if $new_cache; + + 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; + } + $new; }; } @@ -3047,17 +3328,15 @@ source alias of the current result set: my $me = $self->current_source_alias; - return $self->search( + return $self->search({ "$me.modified" => $user->id, - ); + }); } =cut sub current_source_alias { - my ($self) = @_; - - return ($self->{attrs} || {})->{alias} || 'me'; + return (shift->{attrs} || {})->{alias} || 'me'; } =head2 as_subselect_rs @@ -3066,7 +3345,7 @@ sub current_source_alias { =item Arguments: none -=item Return Value: $resultset +=item Return Value: L<$resultset|/search> =back @@ -3154,7 +3433,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}) || {} } }; @@ -3239,30 +3518,24 @@ sub _chain_relationship { return {%$attrs, from => $from, seen_join => $seen}; } -# too many times we have to do $attrs = { %{$self->_resolved_attrs} } -sub _resolved_attrs_copy { - my $self = shift; - return { %{$self->_resolved_attrs (@_)} }; -} - sub _resolved_attrs { my $self = shift; 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}; - # one last pass of normalization - $self->_normalize_selection($attrs); + $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 _trailing_select/; + unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/; # merge selectors together - for (qw/columns select as _trailing_select/) { - $attrs->{$_} = $self->_merge_attr($attrs->{$_}, $attrs->{"+$_"}) + for (qw/columns select as/) { + $attrs->{$_} = $self->_merge_attr($attrs->{$_}, delete $attrs->{"+$_"}) if $attrs->{$_} or $attrs->{"+$_"}; } @@ -3271,7 +3544,7 @@ sub _resolved_attrs { if (my $cols = delete $attrs->{columns}) { for my $c (ref $cols eq 'ARRAY' ? @$cols : $cols) { if (ref $c eq 'HASH') { - for my $as (keys %$c) { + for my $as (sort keys %$c) { push @sel, $c->{$as}; push @as, $as; } @@ -3293,14 +3566,10 @@ sub _resolved_attrs { if $attrs->{select}; # assume all unqualified selectors to apply to the current alias (legacy stuff) - for (@sel) { - $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_"; - } + $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" for @sel; - # disqualify all $alias.col as-bits (collapser mandated) - for (@as) { - $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_; - } + # disqualify all $alias.col as-bits (inflate-map mandated) + $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_ for @as; # de-duplicate the result (remove *identical* select/as pairs) # and also die on duplicate {as} pointing to different {select}s @@ -3370,29 +3639,21 @@ sub _resolved_attrs { $attrs->{group_by} = [ $attrs->{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 ("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. However trailing is not yet a part of the selection as - # prefetch must insert before it - $attrs->{group_by} = $source->storage->_group_over_selection ( - $attrs->{from}, - [ @{$attrs->{select}||[]}, @{$attrs->{_trailing_select}||[]} ], - $attrs->{order_by}, - ); - } - } - $attrs->{collapse} ||= {}; - if ($attrs->{prefetch}) { - my $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ); + # generate selections based on the prefetch helper + my ($prefetch, @prefetch_select, @prefetch_as); + $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}; - my $prefetch_ordering = []; + $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 @@ -3415,25 +3676,90 @@ sub _resolved_attrs { } } - my @prefetch = - $source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} ); + my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map ); + + # save these for after distinct resolution + @prefetch_select = map { $_->[0] } @prefetch; + @prefetch_as = map { $_->[1] } @prefetch; + } + + # run through the resulting joinstructure (starting from our current slot) + # 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 + # + # this allows to predict whether a root object with all other relation + # data set to NULL is in fact unique + if ($attrs->{collapse}) { - # 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 ]; + if (ref $attrs->{from} eq 'ARRAY') { + + if (@{$attrs->{from}} == 1) { + # no joins - no collapse + $attrs->{collapse} = 0; + } + else { + # find where our table-spec starts + my @fromlist = @{$attrs->{from}}; + while (@fromlist) { + my $t = shift @fromlist; + + my $is_multi; + # me vs join from-spec distinction - a ref means non-root + if (ref $t eq 'ARRAY') { + $t = $t->[0]; + $is_multi ||= ! $t->{-is_single}; + } + last if ($t->{-alias} && $t->{-alias} eq $alias); + $attrs->{_main_source_premultiplied} ||= $is_multi; + } + + # no non-singles remaining, nor any premultiplication - nothing to collapse + if ( + ! $attrs->{_main_source_premultiplied} + and + ! List::Util::first { ! $_->[0]{-is_single} } @fromlist + ) { + $attrs->{collapse} = 0; + } + } } - push @{ $attrs->{select} }, (map { $_->[0] } @prefetch); - push @{ $attrs->{as} }, (map { $_->[1] } @prefetch); + else { + # if we can not analyze the from - err on the side of safety + $attrs->{_main_source_premultiplied} = 1; + } + } - push( @{$attrs->{order_by}}, @$prefetch_ordering ); - $attrs->{_collapse_order_by} = \@$prefetch_ordering; + # 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}; + } } + # inject prefetch-bound selection (if any) + push @{$attrs->{select}}, @prefetch_select; + push @{$attrs->{as}}, @prefetch_as; - push @{ $attrs->{select} }, @{$attrs->{_trailing_select}} - if $attrs->{_trailing_select}; + $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 @@ -3542,6 +3868,7 @@ sub _merge_joinpref_attr { $position++; } my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element); + $import_key = '' if not defined $import_key; if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) { push( @{$orig}, $import_element ); @@ -3558,7 +3885,7 @@ sub _merge_joinpref_attr { $seen_keys->{$import_key} = 1; # don't merge the same key twice } - return $orig; + return @$orig ? $orig : (); } { @@ -3566,6 +3893,7 @@ sub _merge_joinpref_attr { sub _merge_attr { $hm ||= do { + require Hash::Merge; my $hm = Hash::Merge->new; $hm->specify_behavior({ @@ -3653,16 +3981,22 @@ sub STORABLE_freeze { my $to_serialize = { %$self }; # A cursor in progress can't be serialized (and would make little sense anyway) - delete $to_serialize->{cursor}; + # the parser can be regenerated (and can't be serialized) + delete @{$to_serialize}{qw/cursor _row_parser _result_inflator/}; - nfreeze($to_serialize); + # nor is it sensical to store a not-yet-fired-count pager + if ($to_serialize->{pager} and ref $to_serialize->{pager}{total_entries} eq 'CODE') { + delete $to_serialize->{pager}; + } + + Storable::nfreeze($to_serialize); } # need this hook for symmetry sub STORABLE_thaw { my ($self, $cloning, $serialized) = @_; - %$self = %{ thaw($serialized) }; + %$self = %{ Storable::thaw($serialized) }; $self; } @@ -3685,6 +4019,10 @@ sub throw_exception { } } +1; + +__END__ + # XXX: FIXME: Attributes docs need clearing up =head1 ATTRIBUTES @@ -3694,6 +4032,10 @@ searching for data. They can be passed to any method which takes an C<\%attrs> argument. See L, L, L, L. +Default attributes can be set on the result class using +L. (Please read +the CAVEATS on that feature before using it!) + These are in no particular order: =head2 order_by @@ -3730,39 +4072,57 @@ syntax as outlined above. =over 4 -=item Value: \@columns +=item Value: \@columns | \%columns | $column =back 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 prefetch) 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', + }, + }); =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'], @@ -3774,16 +4134,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. -=head2 include_columns - -=over 4 - -=item Value: \@columns - -=back - -Deprecated. Acts as a synonym for L for backward compatibility. - =head2 select =over 4 @@ -3816,22 +4166,20 @@ attribute> supplied as shown in the example above. =head2 +select -=over 4 - -Indicates additional columns to be selected from storage. Works the same as -L but adds columns to the default selection, instead of specifying -an explicit list. - -=back - -=head2 +as +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 current selection, instead of specifying +a new explicit list. + =head2 as =over 4 @@ -3840,7 +4188,7 @@ Indicates additional column names for those added via L. See L. =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 instead: You can create your own accessors if required - see 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 + +=item Value: \@extra_inflation_names + +=back + +Indicates additional inflation names for selectors added via L. See L. + =head2 join =over 4 @@ -3937,103 +4299,176 @@ similarly for a third time). For e.g. will return a set of all artists that have both a cd with title 'Down to Earth' and a cd with title 'Popular'. -If you want to fetch related objects from other tables as well, see C +If you want to fetch related objects from other tables as well, see L below. + NOTE: An internal join-chain pruner will discard certain joins while + constructing the actual SQL query, as long as the joins in question do not + affect the retrieved result. This for example includes 1:1 left joins + that are not part of the restriction specification (WHERE/HAVING) nor are + a part of the query selection. + For more help on using joins with search, see L. -=head2 prefetch +=head2 collapse =over 4 -=item Value: ($rel_name | \@rel_names | \%rel_names) +=item Value: (0 | 1) =back -Contains one or more relationships that should be fetched along with -the main query (when they are accessed afterwards the data will -already be available, without extra queries to the database). This is -useful for when you know you will need the related objects, because it -saves at least one query: - - my $rs = $schema->resultset('Tag')->search( - undef, - { - prefetch => { - cd => 'artist' - } - } - ); +When set to a true value, indicates that any rows fetched from joined has_many +relationships are to be aggregated into the corresponding "parent" object. For +example, the resultset: -The initial search results in SQL like the following: + my $rs = $schema->resultset('CD')->search({}, { + '+columns' => [ qw/ tracks.title tracks.position / ], + join => 'tracks', + collapse => 1, + }); - SELECT tag.*, cd.*, artist.* FROM tag - JOIN cd ON tag.cd = cd.cdid - JOIN artist ON cd.artist = artist.artistid +While executing the following query: -L has no need to go back to the database when we access the -C or C relationships, which saves us two SQL statements in this -case. + SELECT me.*, tracks.title, tracks.position + FROM cd me + LEFT JOIN track tracks + ON tracks.cdid = me.cdid -Simple prefetches will be joined automatically, so there is no need -for a C attribute in the above search. +Will return only as many objects as there are rows in the CD source, even +though the result of the query may span many rows. Each of these CD objects +will in turn have multiple "Track" objects hidden behind the has_many +generated accessor C. Without C<< collapse => 1 >>, the return values +of this resultset would be as many CD objects as there are tracks (a "Cartesian +product"), with each CD object containing exactly one of all fetched Track data. -C can be used with the following relationship types: C, -C (or if you're using C, any relationship declared -with an accessor type of 'single' or 'filter'). A more complex example that -prefetches an artists cds, the tracks on those cds, and the tags associated -with that artist is given below (assuming many-to-many from artists to tags): +When a collapse is requested on a non-ordered resultset, an order by some +unique part of the main source (the left-most table) is inserted automatically. +This is done so that the resultset is allowed to be "lazy" - calling +L<< $rs->next|/next >> will fetch only as many rows as it needs to build the next +object with all of its related data. - my $rs = $schema->resultset('Artist')->search( - undef, - { - prefetch => [ - { cds => 'tracks' }, - { artist_tags => 'tags' } - ] - } - ); +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 constructing the +first object returned by L. +Setting this attribute on a resultset that does not join any has_many +relations is a no-op. -B If you specify a C attribute, the C and C