X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=6cd34bd71f6884ee656b47c477dd90c0b6f0a1ce;hb=6e102c8f;hp=ed5a7aed46432850558d7f620850fe38ec19f0e7;hpb=69bc5f2b82b4a4f027cd9d57c38c25dc4e0b72c0;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index ed5a7ae..6cd34bd 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -4,9 +4,8 @@ use strict; use warnings; use base qw/DBIx::Class/; use DBIx::Class::Carp; -use DBIx::Class::Exception; use DBIx::Class::ResultSetColumn; -use Scalar::Util qw/blessed weaken/; +use Scalar::Util qw/blessed weaken reftype/; use Try::Tiny; use Data::Compare (); # no imports!!! guard against insane architecture @@ -26,6 +25,10 @@ use overload '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 @@ -354,37 +357,51 @@ always return a resultset, even in list context. 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}; @@ -392,7 +409,10 @@ sub search_rs { 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) { + + # copy for _normalize_selection + $call_attrs = { %$call_attrs }; my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/; @@ -419,6 +439,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'"; } @@ -439,28 +460,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') ) { - carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead'; - } - for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( @@ -487,8 +486,12 @@ sub _normalize_selection { my ($self, $attrs) = @_; # legacy syntax - $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns}) - if exists $attrs->{include_columns}; + if ( exists $attrs->{include_columns} ) { + carp_unique( "Resultset attribute 'include_columns' is deprecated, use '+columns' instead" ); + $attrs->{'+columns'} = $self->_merge_attr( + $attrs->{'+columns'}, delete $attrs->{include_columns} + ); + } # columns are always placed first, however @@ -993,13 +996,14 @@ 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 @@ -1051,7 +1055,7 @@ 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( @@ -1460,7 +1464,7 @@ 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 @@ -1596,18 +1600,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; + } } } @@ -1637,9 +1645,6 @@ sub _count_subq_rs { ->get_column ('count'); } -sub _bool { - return 1; -} =head2 count_literal @@ -1725,7 +1730,6 @@ another query. sub reset { my ($self) = @_; - delete $self->{_attrs} if exists $self->{_attrs}; $self->{all_cache_position} = 0; $self->cursor->reset; return $self; @@ -1760,152 +1764,146 @@ sub first { sub _rs_update_delete { my ($self, $op, $values) = @_; - my $cond = $self->{cond}; my $rsrc = $self->result_source; my $storage = $rsrc->schema->storage; my $attrs = { %{$self->_resolved_attrs} }; + my $join_classifications; my $existing_group_by = delete $attrs->{group_by}; - my $needs_subq = defined $existing_group_by; - # simplify the joinmap and maybe decide if a subquery is necessary - my $relation_classifications = {}; + # 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/) + ); - if (ref($attrs->{from}) eq 'ARRAY') { - # if we already know we need a subq, no point of classifying relations - if (!$needs_subq and @{$attrs->{from}} > 1) { - $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $cond, $attrs); + # simplify the joinmap, so we can further decide if a subq is necessary + if (!$needs_subq and @{$attrs->{from}} > 1) { + $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $self->{cond}, $attrs); - $relation_classifications = $storage->_resolve_aliastypes_from_select_args ( + # check if there are any joins left after the prune + if ( @{$attrs->{from}} > 1 ) { + $join_classifications = $storage->_resolve_aliastypes_from_select_args ( [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ], $attrs->{select}, - $cond, + $self->{cond}, $attrs ); + + # any non-pruneable joins imply subq + $needs_subq = scalar keys %{ $join_classifications->{restricting} || {} }; } } - else { - $needs_subq ||= 1; # if {from} is unparseable assume the worst - } + # 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} } + ); + + my ($cond, $guard); # do we need anything like a subquery? - if ( - ! $needs_subq - and - ! keys %{ $relation_classifications->{restricting} || {} } - and - ! $self->_has_resolved_attr(qw/rows offset/) # limits call for a subq - ) { + 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. - my $cond = do { + $cond = do { my $sqla = $rsrc->storage->sql_maker; local $sqla->{_dequalify_idents} = 1; \[ $sqla->_recurse_where($self->{cond}) ]; }; - return $rsrc->storage->$op( - $rsrc, - $op eq 'update' ? $values : (), - $cond, - ); } - - # 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, - ) - ); - - # 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}.$_" } @$idcols ]; - $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 (@$idcols == 1) { - return $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - { $idcols->[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 ($_) } @$idcols), - $sql, + 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, + ) ); - return $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - \[$sql, @bind], - ); - } - else { + # 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}.$_" } @$idcols ]; + $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 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 - if ( - $existing_group_by - or - keys %{ $relation_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.' - ); + 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 + 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} }); - } + $subrs = $subrs->search({}, { group_by => $attrs->{columns} }); + } - my $guard = $storage->txn_scope_guard; + $guard = $storage->txn_scope_guard; - my @op_condition; - for my $row ($subrs->cursor->all) { - push @op_condition, { map - { $idcols->[$_] => $row->[$_] } - (0 .. $#$idcols) - }; + $cond = []; + for my $row ($subrs->cursor->all) { + push @$cond, { map + { $idcols->[$_] => $row->[$_] } + (0 .. $#$idcols) + }; + } } + } - my $res = $storage->$op ( - $rsrc, - $op eq 'update' ? $values : (), - \@op_condition, - ); + my $res = $storage->$op ( + $rsrc, + $op eq 'update' ? $values : (), + $cond, + ); - $guard->commit; + $guard->commit if $guard; - return $res; - } + return $res; } =head2 update @@ -2038,28 +2036,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 -for submitting to a $resultset->create(...) method. +Accepts either an arrayref of hashrefs or alternatively an arrayref of +arrayrefs. -In void context, C in L is used -to insert the data, as this is a faster method. +=over -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. +=item NOTE -Example: Assuming an Artist Class that has many CDs Classes relating: +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 + +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. + +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: + + $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 $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 }, @@ -2073,37 +2098,11 @@ 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}, - ]} - ]); - - print $ArtistOne->name; ## response is 'Artist One' - print $ArtistThree->cds->count ## reponse is '2' - -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: - - $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'], - ]); - -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. +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. =cut @@ -2116,10 +2115,7 @@ sub populate { return unless @$data; if(defined wantarray) { - my @created; - foreach my $item (@$data) { - push(@created, $self->create($item)); - } + my @created = map { $self->create($_) } @$data; return wantarray ? @created : \@created; } else { @@ -2174,14 +2170,12 @@ sub 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 ], + [@columns, keys %$rs_data], + [ map { [ @$_{@columns}, values %$rs_data ] } @$data ], ); ## do the has_many relationships @@ -2336,15 +2330,29 @@ sub new_result { 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 @@ -2530,18 +2538,11 @@ 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); - - return $sqlbind; + $self->result_source->storage->_select_args_to_query ( + $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs + ); } =head2 find_or_new @@ -3112,9 +3113,7 @@ source alias of the current result set: =cut sub current_source_alias { - my ($self) = @_; - - return ($self->{attrs} || {})->{alias} || 'me'; + return (shift->{attrs} || {})->{alias} || 'me'; } =head2 as_subselect_rs @@ -3296,12 +3295,6 @@ 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}; @@ -3804,7 +3797,7 @@ 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. @@ -3823,10 +3816,10 @@ is the same as =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 selection. (You may also use the +C attribute, as in earlier versions of DBIC, but this is +deprecated). For example:- $schema->resultset('CD')->search(undef, { '+columns' => ['artist.name'],