X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=c8c89c5bf76b9595222aeaad523f02efc0502039;hb=be64931c710bcde7abe7334349b4c8a123645332;hp=0793e0515677e3970cc87beb93cce7fb0c470ecc;hpb=dc81dba3b6a3675dcc003be84fbaad2f0df7d6a2;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 0793e05..c8c89c5 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3,35 +3,30 @@ package DBIx::Class::ResultSet; use strict; use warnings; use base qw/DBIx::Class/; -use Carp::Clan qw/^DBIx::Class/; +use DBIx::Class::Carp; use DBIx::Class::Exception; -use Data::Page; -use Storable; use DBIx::Class::ResultSetColumn; -use DBIx::Class::ResultSourceHandle; -use Hash::Merge (); use Scalar::Util qw/blessed weaken/; 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; -__PACKAGE__->mk_group_accessors('simple' => qw/_result_class _source_handle/); +__PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/); =head1 NAME @@ -79,6 +74,34 @@ However, if it is used in a boolean context it is B true. So if you want to check if a resultset has any results, you must use C. +=head1 CUSTOM ResultSet CLASSES THAT USE Moose + +If you want to make your custom ResultSet classes with L, use a template +similar to: + + package MyApp::Schema::ResultSet::User; + + use Moose; + use namespace::autoclean; + use MooseX::NonMoose; + extends 'DBIx::Class::ResultSet'; + + sub BUILDARGS { $_[2] } + + ...your code... + + __PACKAGE__->meta->make_immutable; + + 1; + +The L is necessary so that the L constructor does not +clash with the regular ResultSet constructor. Alternatively, you can use: + + __PACKAGE__->meta->make_immutable(inline_constructor => 0); + +The L is necessary because the +signature of the ResultSet C is C<< ->new($source, \%args) >>. + =head1 EXAMPLES =head2 Chaining resultsets @@ -92,14 +115,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(); } @@ -197,8 +220,8 @@ sub new { return $class->new_result(@_) if ref $class; my ($source, $attrs) = @_; - $source = $source->handle - unless $source->isa('DBIx::Class::ResultSourceHandle'); + $source = $source->resolve + if $source->isa('DBIx::Class::ResultSourceHandle'); $attrs = { %{$attrs||{}} }; if ($attrs->{page}) { @@ -207,22 +230,24 @@ sub new { $attrs->{alias} ||= 'me'; - # Creation of {} and bless separated to mitigate RH perl bug - # see https://bugzilla.redhat.com/show_bug.cgi?id=196836 - my $self = { - _source_handle => $source, + my $self = bless { + result_source => $source, cond => $attrs->{where}, pager => undef, - attrs => $attrs - }; + attrs => $attrs, + }, $class; - bless $self, $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->resolve->result_class + $attrs->{result_class} || $source->result_class ); - return $self; + $self; } =head2 search @@ -231,7 +256,7 @@ sub new { =item Arguments: $cond, \%attrs? -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: $resultset (scalar context) || @row_objs (list context) =back @@ -241,6 +266,9 @@ 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 row objects instead. To avoid that, use L. + If you need to pass in additional attributes but no additional condition, call it as C. @@ -252,7 +280,8 @@ call it as C. For a list of attributes that can be passed to C, see L. For more examples of using this function, see L. For a complete -documentation for the first argument, see L. +documentation for the first argument, see L +and its extension L. For more help on using joins with search, see L. @@ -264,7 +293,7 @@ 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 @@ -306,7 +335,6 @@ always return a resultset, even in list context. =cut -my $callsites_warned; sub search_rs { my $self = shift; @@ -350,25 +378,24 @@ sub search_rs { # take care of call attrs (only if anything is changing) if (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'} ); + my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; - my @selector_attrs = qw/select as columns cols +select +as +columns include_columns _trailing_select +_trailing_select/; + # 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->{$_} ); @@ -415,15 +442,7 @@ sub search_rs { } 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}++; + carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead'; } for ($old_where, $call_cond) { @@ -447,6 +466,7 @@ sub search_rs { return $rs; } +my $dark_sel_dumper; sub _normalize_selection { my ($self, $attrs) = @_; @@ -454,6 +474,8 @@ sub _normalize_selection { $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns}) if exists $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) # allowing stuff like the remove_columns helper to work @@ -464,9 +486,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 { @@ -489,68 +509,110 @@ 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) = @_; + + # collapse single element top-level conditions + # (single pass only, unlikely to need recursion) + for ($left, $right) { + if (ref $_ eq 'ARRAY') { + if (@$_ == 0) { + $_ = undef; + } + elsif (@$_ == 1) { + $_ = $_->[0]; + } + } + elsif (ref $_ eq 'HASH') { + my ($first, $more) = keys %$_; + + # empty hash + if (! defined $first) { + $_ = undef; + } + # one element hash + elsif (! defined $more) { + if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') { + $_ = $_->{'-and'}; + } + elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') { + $_ = $_->{'-or'}; + } + } + } + } + + # merge hashes with weeding out of duplicates (simple cases only) + if (ref $left eq 'HASH' and ref $right eq 'HASH') { + + # shallow copy to destroy + $right = { %$right }; + for (grep { exists $right->{$_} } keys %$left) { + # the use of eq_deeply here is justified - the rhs of an + # expression can contain a lot of twisted weird stuff + delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} ); + } + + $right = undef unless keys %$right; + } + + if (defined $left xor defined $right) { return defined $left ? $left : $right; } - elsif (defined $left) { - return { -and => [ map - { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ } - ($left, $right) - ]}; + elsif (! defined $left) { + return undef; + } + else { + return { -and => [ $left, $right ] }; } - - return undef; } =head2 search_literal @@ -559,7 +621,7 @@ sub _stack_cond { =item Arguments: $sql_fragment, @bind_values -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: $resultset (scalar context) || @row_objs (list context) =back @@ -668,22 +730,33 @@ 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 = {}; @@ -702,7 +775,7 @@ sub find { next if $keyref eq 'ARRAY'; # has_many for multi_create my $rel_q = $rsrc->_resolve_condition( - $relinfo->{cond}, $val, $key + $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; @@ -714,11 +787,11 @@ sub find { 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, ), @@ -744,7 +817,7 @@ sub find { }++; push @unique_queries, try { - $self->_build_unique_cond ($c_name, $call_cond) + $self->_build_unique_cond ($c_name, $call_cond, 'croak_on_nulls') } || (); } @@ -803,7 +876,7 @@ sub _qualify_cond_columns { } sub _build_unique_cond { - my ($self, $constraint_name, $extra_cond) = @_; + my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_; my @c_cols = $self->result_source->unique_constraint_columns($constraint_name); @@ -815,15 +888,38 @@ sub _build_unique_cond { }; # trim out everything not in $columns - $final_cond = { map { $_ => $final_cond->{$_} } @c_cols }; - - if (my @missing = grep { ! defined $final_cond->{$_} } (@c_cols) ) { + $final_cond = { map { + exists $final_cond->{$_} + ? ( $_ => $final_cond->{$_} ) + : () + } @c_cols }; + + if (my @missing = grep + { ! ($croak_on_null ? defined $final_cond->{$_} : exists $final_cond->{$_}) } + (@c_cols) + ) { $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s", $constraint_name, join (', ', map { "'$_'" } @missing), ) ); } + if ( + !$croak_on_null + and + !$ENV{DBIC_NULLABLE_KEY_NOWARN} + and + my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond) + ) { + carp_unique ( sprintf ( + "NULL/undef values supplied for requested unique constraint '%s' (NULL " + . 'values in column(s): %s). This is almost certainly not what you wanted, ' + . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.', + $constraint_name, + join (', ', map { "'$_'" } @undefs), + )); + } + return $final_cond; } @@ -833,7 +929,7 @@ sub _build_unique_cond { =item Arguments: $rel, $cond, \%attrs? -=item Return Value: $new_resultset +=item Return Value: $new_resultset (scalar context) || @row_objs (list context) =back @@ -844,6 +940,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 row objects instead. To avoid that, use L. + +See also L. + =cut sub search_related { @@ -1024,7 +1125,7 @@ sub get_column { =item Arguments: $cond, \%attrs? -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: $resultset (scalar context) || @row_objs (list context) =back @@ -1050,7 +1151,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!)' @@ -1067,7 +1168,7 @@ sub search_like { =item Arguments: $first, $last -=item Return Value: $resultset (scalar context), @row_objs (list context) +=item Return Value: $resultset (scalar context) || @row_objs (list context) =back @@ -1420,7 +1521,7 @@ sub _count_rs { # 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/}; + delete @{$tmp_attrs}{qw/columns/}; my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count'); @@ -1438,7 +1539,7 @@ sub _count_subq_rs { 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 _prefetch_selector_range order_by for/}; # if we multi-prefetch we group_by primary keys only as this is what we would # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless @@ -1547,8 +1648,7 @@ sub count_literal { shift->search_literal(@_)->count; } =back -Returns all elements in the resultset. Called implicitly if the resultset -is returned in list context. +Returns all elements in the resultset. =cut @@ -1637,39 +1737,116 @@ sub first { sub _rs_update_delete { my ($self, $op, $values) = @_; + my $cond = $self->{cond}; 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/); + # "needs" is a strong word here - if the subquery is part of an IN clause - no point of + # even adding the group_by. It will really be used only when composing a poor-man's + # multicolumn-IN equivalent OR set + my $needs_group_by_subq = defined $attrs->{group_by}; - if ($needs_group_by_subq or $needs_subq) { + # simplify the joinmap and maybe decide if a grouping (and thus subquery) is necessary + my $relation_classifications; + if (ref($attrs->{from}) eq 'ARRAY') { + $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $cond, $attrs); - # make a new $rs selecting only the PKs (that's all we really need) - my $attrs = $self->_resolved_attrs_copy; + $relation_classifications = $storage->_resolve_aliastypes_from_select_args ( + [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ], + $attrs->{select}, + $cond, + $attrs + ) unless $needs_group_by_subq; # we already know we need a group, no point of resolving them + } + else { + $needs_group_by_subq ||= 1; # if {from} is unparseable assume the worst + } + + $needs_group_by_subq ||= exists $relation_classifications->{multiplying}; + # if no subquery - life is easy-ish + unless ( + $needs_group_by_subq + or + keys %$relation_classifications # if any joins at all - need to wrap a subq + or + $self->_has_resolved_attr(qw/rows offset/) # limits call for a 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. What this code tries to do (badly) is to generate a condition + # with the qualifiers removed, by exploiting the quote mechanism of sqla + # + # this is atrocious and should be replaced by normal sqla introspection + # one sunny day + my ($sql, @bind) = do { + my $sqla = $rsrc->storage->sql_maker; + local $sqla->{_dequalify_idents} = 1; + $sqla->_recurse_where($self->{cond}); + } if $self->{cond}; - delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/; - $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ]; + return $rsrc->storage->$op( + $rsrc, + $op eq 'update' ? $values : (), + $self->{cond} ? \[$sql, @bind] : (), + ); + } + + # we got this far - means it is time to wrap a subquery + my $pcols = [ $rsrc->_pri_cols ]; + my $existing_group_by = delete $attrs->{group_by}; + + # make a new $rs selecting only the PKs (that's all we really need for the subq) + delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/; + $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$pcols ]; + $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins + my $subrs = (ref $self)->new($rsrc, $attrs); + + if (@$pcols == 1) { + return $storage->$op ( + $rsrc, + $op eq 'update' ? $values : (), + { $pcols->[0] => { -in => $subrs->as_query } }, + ); + } + elsif ($storage->_use_multicolumn_in) { + # This is hideously ugly, but SQLA does not understand multicol IN expressions + my $sql_maker = $storage->sql_maker; + my ($sql, @bind) = @${$subrs->as_query}; + $sql = sprintf ('(%s) IN %s', # the as_query already comes with a set of parenthesis + join (', ', map { $sql_maker->_quote ($_) } @$pcols), + $sql, + ); + return $storage->$op ( + $rsrc, + $op eq 'update' ? $values : (), + \[$sql, @bind], + ); + } + 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 starts to matter + my $subq_group_by; 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 + $subq_group_by = $attrs->{columns}; - if (my $g = $attrs->{group_by}) { + # 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}.$_" } - @$g + @$existing_group_by ; if ( join ("\x00", sort @current_group_by) ne - join ("\x00", sort @{$attrs->{columns}} ) + join ("\x00", sort @$subq_group_by ) ) { $self->throw_exception ( "You have just attempted a $op operation on a resultset which does group_by" @@ -1680,20 +1857,27 @@ sub _rs_update_delete { ); } } - else { - $attrs->{group_by} = $attrs->{columns}; - } } - my $subrs = (ref $self)->new($rsrc, $attrs); - return $self->result_source->storage->_subq_update_delete($subrs, $op, $values); - } - else { - return $rsrc->storage->$op( + my $guard = $storage->txn_scope_guard; + + my @op_condition; + for my $row ($subrs->search({}, { group_by => $subq_group_by })->cursor->all) { + push @op_condition, { map + { $pcols->[$_] => $row->[$_] } + (0 .. $#$pcols) + }; + } + + my $res = $storage->$op ( $rsrc, $op eq 'update' ? $values : (), - $cond, + \@op_condition, ); + + $guard->commit; + + return $res; } } @@ -1713,7 +1897,7 @@ triggers, nor will it update any row 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 @@ -1726,7 +1910,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 @@ -1760,7 +1944,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; } @@ -1781,7 +1965,7 @@ L status of any row 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. @@ -1833,7 +2017,7 @@ sub delete_all { 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. +for submitting to a $resultset->create(...) method. In void context, C in L is used to insert the data, as this is a faster method. @@ -1902,13 +2086,15 @@ sub populate { # cruft placed in standalone method my $data = $self->_normalize_populate_args(@_); + return unless @$data; + if(defined wantarray) { my @created; foreach my $item (@$data) { push(@created, $self->create($item)); } return wantarray ? @created : \@created; - } + } else { my $first = $data->[0]; @@ -1948,6 +2134,7 @@ sub populate { $reverse_relinfo->{cond}, $self, $result, + $rel, ); delete $data->[$index]->{$rel}; @@ -1986,6 +2173,7 @@ sub populate { $rels->{$rel}{cond}, $child, $main_row, + $rel, ); my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); @@ -2004,7 +2192,10 @@ sub _normalize_populate_args { my ($self, $arg) = @_; if (ref $arg eq 'ARRAY') { - if (ref $arg->[0] eq 'HASH') { + if (!@$arg) { + return []; + } + elsif (ref $arg->[0] eq 'HASH') { return $arg; } elsif (ref $arg->[0] eq 'ARRAY') { @@ -2038,116 +2229,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"); @@ -2161,69 +2247,15 @@ sub pager { # 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); + 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 @@ -2278,7 +2310,6 @@ sub new_result { @$cols_from_relations ? (-cols_from_relations => $cols_from_relations) : (), - -source_handle => $self->_source_handle, -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED ); @@ -2318,7 +2349,13 @@ sub _merge_with_rscond { while ( my($col, $value) = each %implied ) { my $vref = ref $value; - if ($vref eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') { + 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) ) { @@ -2786,7 +2823,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 @@ -3092,8 +3129,8 @@ sub as_subselect_rs { return $fresh_rs->search( {}, { from => [{ $attrs->{alias} => $self->as_query, - -alias => $attrs->{alias}, - -source_handle => $self->result_source->handle, + -alias => $attrs->{alias}, + -rsrc => $self->result_source, }], alias => $attrs->{alias}, }); @@ -3143,8 +3180,8 @@ sub _chain_relationship { ); $from = [{ - -source_handle => $source->handle, - -alias => $attrs->{alias}, + -rsrc => $source, + -alias => $attrs->{alias}, $attrs->{alias} => $rs_copy->as_query, }]; delete @{$attrs}{@force_subq_attrs, qw/where bind/}; @@ -3155,7 +3192,7 @@ sub _chain_relationship { } else { $from = [{ - -source_handle => $source->handle, + -rsrc => $source, -alias => $attrs->{alias}, $attrs->{alias} => $source->from, }]; @@ -3220,16 +3257,13 @@ sub _resolved_attrs { my $source = $self->result_source; my $alias = $attrs->{alias}; - # one last pass of normalization - $self->_normalize_selection($attrs); - # 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->{"+$_"}; } @@ -3294,8 +3328,8 @@ sub _resolved_attrs { $attrs->{as} = \@as; $attrs->{from} ||= [{ - -source_handle => $source->handle, - -alias => $self->{attrs}{alias}, + -rsrc => $source, + -alias => $self->{attrs}{alias}, $self->{attrs}{alias} => $source->from, }]; @@ -3341,15 +3375,14 @@ sub _resolved_attrs { # 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)"); + carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)"); } else { # distinct affects only the main selection part, not what prefetch may - # add below. However trailing is not yet a part of the selection as - # prefetch must insert before it + # add below. $attrs->{group_by} = $source->storage->_group_over_selection ( $attrs->{from}, - [ @{$attrs->{select}||[]}, @{$attrs->{_trailing_select}||[]} ], + $attrs->{select}, $attrs->{order_by}, ); } @@ -3357,6 +3390,10 @@ sub _resolved_attrs { $attrs->{collapse} ||= {}; if ($attrs->{prefetch}) { + + $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") + if $attrs->{_dark_selector}; + my $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ); my $prefetch_ordering = []; @@ -3399,9 +3436,6 @@ sub _resolved_attrs { } - push @{ $attrs->{select} }, @{$attrs->{_trailing_select}} - if $attrs->{_trailing_select}; - # if both page and offset are specified, produce a combined offset # even though it doesn't make much sense, this is what pre 081xx has # been doing @@ -3509,6 +3543,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 ); @@ -3533,6 +3568,7 @@ sub _merge_joinpref_attr { sub _merge_attr { $hm ||= do { + require Hash::Merge; my $hm = Hash::Merge->new; $hm->specify_behavior({ @@ -3615,17 +3651,6 @@ sub _merge_joinpref_attr { } } -sub result_source { - my $self = shift; - - if (@_) { - $self->_source_handle($_[0]->handle); - } else { - $self->_source_handle->resolve; - } -} - - sub STORABLE_freeze { my ($self, $cloning) = @_; my $to_serialize = { %$self }; @@ -3633,16 +3658,21 @@ sub STORABLE_freeze { # A cursor in progress can't be serialized (and would make little sense anyway) delete $to_serialize->{cursor}; - return 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) }; - return $self; + $self; } @@ -3655,8 +3685,8 @@ See L for details. sub throw_exception { my $self=shift; - if (ref $self && $self->_source_handle->schema) { - $self->_source_handle->schema->throw_exception(@_) + if (ref $self and my $rsrc = $self->result_source) { + $rsrc->throw_exception(@_) } else { DBIx::Class::Exception->throw(@_); @@ -3752,6 +3782,10 @@ passed to object inflation. Note that the 'artist' is the name of the column (or relationship) accessor, and 'name' is the name of the column accessor in the related table. +B You need to explicitly quote '+columns' when defining the attribute. +Not doing so causes Perl to incorrectly interpret +columns as a bareword with a +unary plus operator before it. + =head2 include_columns =over 4 @@ -3792,6 +3826,10 @@ identifier aliasing. You can however alias a function, so you can use it in e.g. an C clause. This is done via the C<-as> B -attributes will be ignored. +=head3 Using L with L + +L implies a L with the equivalent argument, and is +properly merged with any existing L specification. So the +following: + + my $rs = $schema->resultset('CD')->search( + {'record_label.name' => 'Music Product Ltd.'}, + { + join => {artist => 'record_label'}, + prefetch => 'artist', + } + ); -B: Prefetch does a lot of deep magic. As such, it may not behave -exactly as you might expect. +... will work, searching on the record label's name, but only +prefetching the C. + +=head3 Using L with L / L / L / L + +L implies a L/L with the fields of the +prefetched relations. So given: + + my $rs = $schema->resultset('CD')->search( + undef, + { + select => ['cd.title'], + as => ['cd_title'], + prefetch => 'artist', + } + ); + +The L becomes: C<'cd.title', 'artist.*'> and the L +becomes: C<'cd_title', 'artist.*'>. + +=head3 CAVEATS + +Prefetch does a lot of deep magic. As such, it may not behave exactly +as you might expect. =over 4 @@ -4024,7 +4156,7 @@ Makes the resultset paged and specifies the page to retrieve. Effectively identical to creating a non-pages resultset and then calling ->page($page) on it. -If L attribute is not specified it defaults to 10 rows per page. +If L attribute is not specified it defaults to 10 rows per page. When you have a paged resultset, L will only return the number of rows in the page. To get the total, use the L and call @@ -4105,6 +4237,8 @@ Adds to the WHERE clause. Can be overridden by passing C<< { where => undef } >> as an attribute to a resultset. +For more complicated where clauses see L. + =back =head2 cache