X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=580ab2013fd6fbfd1c0c575db8fd7875bbd02a07;hb=e493ecb281730e358d23551d4addc5157b850892;hp=6dcbbf9ce13ebce12a8fb3457efce265aa447c4d;hpb=cf48da0c9ecff776e12d1f194c3be24b8079f1f4;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 6dcbbf9..580ab20 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -9,11 +9,22 @@ use Data::Page; use Storable; use DBIx::Class::ResultSetColumn; use DBIx::Class::ResultSourceHandle; -use List::Util (); +use Hash::Merge (); use Scalar::Util qw/blessed weaken/; use Try::Tiny; +use Storable qw/nfreeze thaw/; + +# 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 + *__HM_DEDUP = sub () { 0 }; +} + use overload '0+' => "count", 'bool' => "_bool", @@ -244,12 +255,32 @@ documentation for the first argument, see L. For more help on using joins with search, see L. +=head3 CAVEAT + +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 +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. + =cut sub search { my $self = shift; my $rs = $self->search_rs( @_ ); - return (wantarray ? $rs->all : $rs); + + my $want = wantarray; + if ($want) { + return $rs->all; + } + elsif (defined $want) { + return $rs; + } + else { + $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense'); + } } =head2 search_rs @@ -276,7 +307,9 @@ sub search_rs { } my $call_attrs = {}; - $call_attrs = pop(@_) if @_ > 1 and ref $_[-1] eq 'HASH'; + $call_attrs = pop(@_) if ( + @_ > 1 and ( ! defined $_[-1] or ref $_[-1] eq 'HASH' ) + ); # see if we can keep the cache (no $rs changes) my $cache; @@ -303,7 +336,11 @@ sub search_rs { my $new_attrs = { %{$old_attrs}, %{$call_attrs} }; # merge new attrs into inherited - foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) { + foreach my $key (qw/join prefetch/) { + next unless exists $call_attrs->{$key}; + $new_attrs->{$key} = $self->_merge_joinpref_attr($old_attrs->{$key}, $call_attrs->{$key}); + } + foreach my $key (qw/+select +as +columns include_columns bind/) { next unless exists $call_attrs->{$key}; $new_attrs->{$key} = $self->_merge_attr($old_attrs->{$key}, $call_attrs->{$key}); } @@ -326,6 +363,9 @@ sub search_rs { } if @_; + carp 'search( %condition ) is deprecated, use search( \%condition ) instead' + if (@_ > 1 and ! $self->result_source->result_class->isa('DBIx::Class::CDBICompat') ); + for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( @@ -1266,10 +1306,42 @@ sub _count_subq_rs { if (ref $sel eq 'HASH' and $sel->{-as}); } - for my $g_part (@$g) { - my $colpiece = $sel_index->{$g_part} || $g_part; + # anything from the original select mentioned on the group-by needs to make it to the inner selector + # also look for named aggregates referred in the having clause + # having often contains scalarrefs - thus parse it out entirely + my @parts = @$g; + if ($attrs->{having}) { + local $sql_maker->{having_bind}; + local $sql_maker->{quote_char} = $sql_maker->{quote_char}; + local $sql_maker->{name_sep} = $sql_maker->{name_sep}; + unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) { + $sql_maker->{quote_char} = [ "\x00", "\xFF" ]; + # if we don't unset it we screw up retarded but unfortunately working + # 'MAX(foo.bar)' => { '>', 3 } + $sql_maker->{name_sep} = ''; + } + + my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep); - # disqualify join-based group_by's. Arcane but possible query + my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{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 =~ / + $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 + } + } + + for (@parts) { + my $colpiece = $sel_index->{$_} || $_; + + # unqualify join-based group_by's. Arcane but possible query # also horrible horrible hack to alias a column (not a func.) # (probably need to introduce SQLA syntax) if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) { @@ -1495,6 +1567,15 @@ The return value is a pass through of what the underlying storage backend returned, and may vary. See L for the most common case. +=head3 CAVEAT + +Note that L does not process/deflate any of the values passed in. +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. + =cut sub update { @@ -1862,7 +1943,8 @@ my $mk_lazy_count_wizard = sub { # the tie class for 5.8.1 { - package DBIx::Class::__DBIC_LAZY_RS_COUNT__; + 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}} } @@ -1911,8 +1993,12 @@ sub pager { } my $attrs = $self->{attrs}; - $self->throw_exception("Can't create pager for non-paged rs") - unless $self->{attrs}{page}; + if (!defined $attrs->{page}) { + $self->throw_exception("Can't create pager for non-paged rs"); + } + elsif ($attrs->{page} <= 0) { + $self->throw_exception('Invalid page number (page-numbers are 1-based)'); + } $attrs->{rows} ||= 10; # throw away the paging flags and re-run the count (possibly @@ -2877,7 +2963,7 @@ sub _chain_relationship { # we need to take the prefetch the attrs into account before we # ->_resolve_join as otherwise they get lost - captainL - my $join = $self->_merge_attr( $attrs->{join}, $attrs->{prefetch} ); + 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/}; @@ -2895,7 +2981,7 @@ sub _chain_relationship { # are resolved (prefetch is useless - we are wrapping # a subquery anyway). my $rs_copy = $self->search; - $rs_copy->{attrs}{join} = $self->_merge_attr ( + $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr ( $rs_copy->{attrs}{join}, delete $rs_copy->{attrs}{prefetch}, ); @@ -2978,98 +3064,162 @@ sub _resolved_attrs { my $source = $self->result_source; my $alias = $attrs->{alias}; - $attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols}; - my @colbits; +######## +# resolve selectors, this one is quite hairy - # build columns (as long as select isn't set) into a set of as/select hashes - unless ( $attrs->{select} ) { + my $selection_pieces; - my @cols; - if ( ref $attrs->{columns} eq 'ARRAY' ) { - @cols = @{ delete $attrs->{columns}} - } elsif ( defined $attrs->{columns} ) { - @cols = delete $attrs->{columns} - } else { - @cols = $source->columns - } + $attrs->{columns} ||= delete $attrs->{cols} + if exists $attrs->{cols}; - for (@cols) { - if ( ref $_ eq 'HASH' ) { - push @colbits, $_ - } else { - my $key = /^\Q${alias}.\E(.+)$/ - ? "$1" - : "$_"; - my $value = /\./ - ? "$_" - : "${alias}.$_"; - push @colbits, { $key => $value }; + # disassemble columns / +columns + ( + $selection_pieces->{columns}{select}, + $selection_pieces->{columns}{as}, + $selection_pieces->{'+columns'}{select}, + $selection_pieces->{'+columns'}{as}, + ) = map + { + my (@sel, @as); + + for my $colbit (@$_) { + + if (ref $colbit eq 'HASH') { + for my $as (keys %$colbit) { + push @sel, $colbit->{$as}; + push @as, $as; + } + } + elsif ($colbit) { + push @sel, $colbit; + push @as, $colbit; + } } + + (\@sel, \@as) + } + ( + (ref $attrs->{columns} eq 'ARRAY' ? delete $attrs->{columns} : [ delete $attrs->{columns} ]), + # include_columns is a legacy add-on to +columns + [ map { ref $_ eq 'ARRAY' ? @$_ : ($_ || () ) } delete @{$attrs}{qw/+columns include_columns/} ] ) + ; + + # make copies of select/as and +select/+as + ( + $selection_pieces->{'select/as'}{select}, + $selection_pieces->{'select/as'}{as}, + $selection_pieces->{'+select/+as'}{select}, + $selection_pieces->{'+select/+as'}{as}, + ) = map + { $_ ? [ ref $_ eq 'ARRAY' ? @$_ : $_ ] : [] } + ( delete @{$attrs}{qw/select as +select +as/} ) + ; + + # default to * only when neither no non-plus selectors are available + if ( + ! @{$selection_pieces->{'select/as'}{select}} + and + ! @{$selection_pieces->{'columns'}{select}} + ) { + for ($source->columns) { + push @{$selection_pieces->{'select/as'}{select}}, $_; + push @{$selection_pieces->{'select/as'}{as}}, $_; } } - # add the additional columns on - foreach (qw{include_columns +columns}) { - if ( $attrs->{$_} ) { - my @list = ( ref($attrs->{$_}) eq 'ARRAY' ) - ? @{ delete $attrs->{$_} } - : delete $attrs->{$_}; - for (@list) { - if ( ref($_) eq 'HASH' ) { - push @colbits, $_ - } else { - my $key = ( split /\./, $_ )[-1]; - my $value = ( /\./ ? $_ : "$alias.$_" ); - push @colbits, { $key => $value }; + # final composition order (important) + my @sel_pairs = grep { + $selection_pieces->{$_} + && + ( + ( $selection_pieces->{$_}{select} && @{$selection_pieces->{$_}{select}} ) + || + ( $selection_pieces->{$_}{as} && @{$selection_pieces->{$_}{as}} ) + ) + } qw|columns select/as +columns +select/+as|; + + # fill in missing as bits for each pair + # if it's the last pair we can let things slide ( bare +select is sadly popular) + my $out_of_sync; + + for my $i (0 .. $#sel_pairs) { + + my $pairname = $sel_pairs[$i]; + + my ($sel, $as) = @{$selection_pieces->{$pairname}}{qw/select as/}; + + $self->throw_exception( + "Unable to assemble final selection list: $pairname specified in addition to unbalanced $sel_pairs[$i-1]" + ) if ($out_of_sync); + + if (@$sel == @$as) { + next; + } + elsif (@$sel < @$as) { + $self->throw_exception( + "More 'as' elements than 'select' elements for $pairname, unable to continue" + ); + } + else { + # try to deduce the 'as' part, will work only if all the selectors are "plain", or contain an explicit -as + # if we can not deduce something - stop right there and leave the rest of the selector un-as'ed + # if there is an extra selection pair coming after that - it will die due to out_of_sync being set + for my $j ($#$as+1 .. $#$sel) { + if (my $ref = ref $sel->[$j]) { + if ($ref eq 'HASH' and exists $sel->[$j]{-as}) { + push @$as, $sel->[$j]{-as}; + } + else { + $out_of_sync++; + last; + } + } + else { + push @$as, $sel->[$j]; } } } } - # start with initial select items - if ( $attrs->{select} ) { - $attrs->{select} = - ( ref $attrs->{select} eq 'ARRAY' ) - ? [ @{ $attrs->{select} } ] - : [ $attrs->{select} ]; - - if ( $attrs->{as} ) { - $attrs->{as} = - ( - ref $attrs->{as} eq 'ARRAY' - ? [ @{ $attrs->{as} } ] - : [ $attrs->{as} ] - ) - } else { - $attrs->{as} = [ map { - m/^\Q${alias}.\E(.+)$/ - ? $1 - : $_ - } @{ $attrs->{select} } - ] - } + # assume all unqualified selectors to apply to the current alias (legacy stuff) + # disqualify all $alias.col as-bits (collapser mandated) + for (values %$selection_pieces) { + $_->{select} = [ map { (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" } @{$_->{select}} ]; + $_->{as} = [ map { $_ =~ /^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$_->{as}} ]; } - else { - # otherwise we intialise select & as to empty - $attrs->{select} = []; - $attrs->{as} = []; + # merge everything + for (@sel_pairs) { + $attrs->{select} = $self->_merge_attr ($attrs->{select}, $selection_pieces->{$_}{select}); + $attrs->{as} = $self->_merge_attr ($attrs->{as}, $selection_pieces->{$_}{as}); } - # now add colbits to select/as - push @{ $attrs->{select} }, map values %{$_}, @colbits; - push @{ $attrs->{as} }, map keys %{$_}, @colbits; + # de-duplicate the result (remove *identical* select/as pairs) + # and also die on duplicate {as} pointing to different {select}s + # not using a c-style for as the condition is prone to shrinkage + my $seen; + my $i = 0; + while ($i <= $#{$attrs->{as}} ) { + my ($sel, $as) = map { $attrs->{$_}[$i] } (qw/select as/); - if ( my $adds = delete $attrs->{'+select'} ) { - $adds = [$adds] unless ref $adds eq 'ARRAY'; - push @{ $attrs->{select} }, - map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds; - } - if ( my $adds = delete $attrs->{'+as'} ) { - $adds = [$adds] unless ref $adds eq 'ARRAY'; - push @{ $attrs->{as} }, @$adds; + if ($seen->{"$sel \x00\x00 $as"}++) { + splice @$_, $i, 1 + for @{$attrs}{qw/select as/}; + } + elsif ($seen->{$as}++) { + $self->throw_exception( + "inflate_result() alias '$as' specified twice with different SQL-side {select}-ors" + ); + } + else { + $i++; + } } +## selector resolution done +######## + + $attrs->{from} ||= [{ -source_handle => $source->handle, -alias => $self->{attrs}{alias}, @@ -3084,7 +3234,7 @@ sub _resolved_attrs { my $join = delete $attrs->{join} || {}; if ( defined $attrs->{prefetch} ) { - $join = $self->_merge_attr( $join, $attrs->{prefetch} ); + $join = $self->_merge_joinpref_attr( $join, $attrs->{prefetch} ); } $attrs->{from} = # have to copy here to avoid corrupting the original @@ -3121,40 +3271,15 @@ sub _resolved_attrs { carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)"); } else { - my $storage = $self->result_source->schema->storage; - my $rs_column_list = $storage->_resolve_column_info ($attrs->{from}); - - my $group_spec = $attrs->{group_by} = []; - my %group_index; - - for (@{$attrs->{select}}) { - if (! ref($_) or ref ($_) ne 'HASH' ) { - push @$group_spec, $_; - $group_index{$_}++; - if ($rs_column_list->{$_} and $_ !~ /\./ ) { - # add a fully qualified version as well - $group_index{"$rs_column_list->{$_}{-source_alias}.$_"}++; - } - } - } - # add any order_by parts that are not already present in the group_by - # we need to be careful not to add any named functions/aggregates - # i.e. select => [ ... { count => 'foo', -as 'foocount' } ... ] - for my $chunk ($storage->_extract_order_columns($attrs->{order_by})) { - - # only consider real columns (for functions the user got to do an explicit group_by) - my $colinfo = $rs_column_list->{$chunk} - or next; - - $chunk = "$colinfo->{-source_alias}.$chunk" if $chunk !~ /\./; - push @$group_spec, $chunk unless $group_index{$chunk}++; - } + $attrs->{group_by} = $source->storage->_group_over_selection ( + @{$attrs}{qw/from select order_by/} + ); } } $attrs->{collapse} ||= {}; if ( my $prefetch = delete $attrs->{prefetch} ) { - $prefetch = $self->_merge_attr( {}, $prefetch ); + $prefetch = $self->_merge_joinpref_attr( {}, $prefetch ); my $prefetch_ordering = []; @@ -3277,7 +3402,7 @@ sub _calculate_score { } } -sub _merge_attr { +sub _merge_joinpref_attr { my ($self, $orig, $import) = @_; return $import unless defined($orig); @@ -3309,7 +3434,7 @@ sub _merge_attr { $orig->[$best_candidate->{position}] = $import_element; } elsif (ref $import_element eq 'HASH') { my ($key) = keys %{$orig_best}; - $orig->[$best_candidate->{position}] = { $key => $self->_merge_attr($orig_best->{$key}, $import_element->{$key}) }; + $orig->[$best_candidate->{position}] = { $key => $self->_merge_joinpref_attr($orig_best->{$key}, $import_element->{$key}) }; } } $seen_keys->{$import_key} = 1; # don't merge the same key twice @@ -3318,6 +3443,89 @@ sub _merge_attr { return $orig; } +{ + my $hm; + + sub _merge_attr { + $hm ||= do { + my $hm = Hash::Merge->new; + + $hm->specify_behavior({ + SCALAR => { + SCALAR => sub { + my ($defl, $defr) = map { defined $_ } (@_[0,1]); + + if ($defl xor $defr) { + return $defl ? $_[0] : $_[1]; + } + elsif (! $defl) { + return (); + } + elsif (__HM_DEDUP and $_[0] eq $_[1]) { + return $_[0]; + } + else { + return [$_[0], $_[1]]; + } + }, + ARRAY => sub { + return $_[1] if !defined $_[0]; + return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return [$_[0], @{$_[1]}] + }, + HASH => sub { + return $_[1] if !defined $_[0]; + return $_[0] if !keys %{$_[1]}; + return [$_[0], $_[1]] + }, + }, + ARRAY => { + SCALAR => sub { + return $_[0] if !defined $_[1]; + return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return [@{$_[0]}, $_[1]] + }, + ARRAY => sub { + my @ret = @{$_[0]} or return $_[1]; + return [ @ret, @{$_[1]} ] unless __HM_DEDUP; + my %idx = map { $_ => 1 } @ret; + push @ret, grep { ! defined $idx{$_} } (@{$_[1]}); + \@ret; + }, + HASH => sub { + return [ $_[1] ] if ! @{$_[0]}; + return $_[0] if !keys %{$_[1]}; + return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]}; + return [ @{$_[0]}, $_[1] ]; + }, + }, + HASH => { + SCALAR => sub { + return $_[0] if !defined $_[1]; + return $_[1] if !keys %{$_[0]}; + return [$_[0], $_[1]] + }, + ARRAY => sub { + return $_[0] if !@{$_[1]}; + return $_[1] if !keys %{$_[0]}; + return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]}; + return [ $_[0], @{$_[1]} ]; + }, + HASH => sub { + return $_[0] if !keys %{$_[1]}; + return $_[1] if !keys %{$_[0]}; + return $_[0] if $_[0] eq $_[1]; + return [ $_[0], $_[1] ]; + }, + } + } => 'DBIC_RS_ATTR_MERGER'); + $hm; + }; + + return $hm->merge ($_[1], $_[2]); + } +} + sub result_source { my $self = shift; @@ -3328,6 +3536,27 @@ sub result_source { } } + +sub STORABLE_freeze { + my ($self, $cloning) = @_; + my $to_serialize = { %$self }; + + # A cursor in progress can't be serialized (and would make little sense anyway) + delete $to_serialize->{cursor}; + + return nfreeze($to_serialize); +} + +# need this hook for symmetry +sub STORABLE_thaw { + my ($self, $cloning, $serialized) = @_; + + %$self = %{ thaw($serialized) }; + + return $self; +} + + =head2 throw_exception See L for details.