X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=5da7f9a2a0785ccfdf590f4649b26ef06c04f93b;hb=c4800d10376961b48cfd4c2eb65184c4c6700768;hp=47bd139aa8a7616afcfdd7e42959734f41fec100;hpb=0a3441ee8e0e747cfa05eff02df0d918ed5d6acb;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 47bd139..5da7f9a 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -9,11 +9,23 @@ 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 + # (the merger is used for other things that ought not to be de-duped) + *__HM_DEDUP = sub () { 0 }; +} + use overload '0+' => "count", 'bool' => "_bool", @@ -244,12 +256,39 @@ 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); + + if (wantarray) { + return $rs->all; + } + elsif (defined wantarray) { + return $rs; + } + else { + # we can be called by a relationship helper, which in + # turn may be called in void context due to some braindead + # overload or whatever else the user decided to be clever + # at this particular day. Thus limit the exception to + # external code calls only + $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense') + if (caller)[0] !~ /^\QDBIx::Class::/; + + return (); + } } =head2 search_rs @@ -267,6 +306,7 @@ always return a resultset, even in list context. =cut +my $callsites_warned; sub search_rs { my $self = shift; @@ -276,7 +316,15 @@ sub search_rs { } my $call_attrs = {}; - $call_attrs = pop(@_) if @_ > 1 and ref $_[-1] eq 'HASH'; + if (@_ > 1) { + if (ref $_[-1] eq 'HASH') { + # copy for _normalize_selection + $call_attrs = { %{ pop @_ } }; + } + elsif (! defined $_[-1] ) { + pop @_; # search({}, undef) + } + } # see if we can keep the cache (no $rs changes) my $cache; @@ -291,23 +339,63 @@ sub search_rs { $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}; - # reset the selector list - if (List::Util::first { exists $call_attrs->{$_} } qw{columns select as}) { - delete @{$old_attrs}{qw{select as columns +select +as +columns include_columns}}; - } + my $new_attrs = { %$old_attrs }; + + # 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 _trailing_select +_trailing_select/; + + # Normalize the 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 + $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->{$_} ); + } + + # older deprecated name, use only if {columns} is not there + if (my $c = delete $new_attrs->{cols}) { + if ($new_attrs->{columns}) { + carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'"; + } + else { + $new_attrs->{columns} = $c; + } + } - my $new_attrs = { %{$old_attrs}, %{$call_attrs} }; - # merge new attrs into inherited - foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) { - next unless exists $call_attrs->{$key}; - $new_attrs->{$key} = $self->_merge_attr($old_attrs->{$key}, $call_attrs->{$key}); + # join/prefetch use their own crazy merging heuristics + foreach my $key (qw/join prefetch/) { + $new_attrs->{$key} = $self->_merge_joinpref_attr($old_attrs->{$key}, $call_attrs->{$key}) + if exists $call_attrs->{$key}; + } + + # stack binds together + $new_attrs->{bind} = [ @{ $old_attrs->{bind} || [] }, @{ $call_attrs->{bind} || [] } ]; } + # rip apart the rest of @_, parse a condition my $call_cond = do { @@ -326,6 +414,18 @@ 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}++; + } + for ($old_where, $call_cond) { if (defined $_) { $new_attrs->{where} = $self->_stack_cond ( @@ -340,13 +440,104 @@ sub search_rs { ) } - my $rs = (ref $self)->new($self->result_source, $new_attrs); + my $rs = (ref $self)->new($rsrc, $new_attrs); $rs->set_cache($cache) if ($cache); return $rs; } +sub _normalize_selection { + my ($self, $attrs) = @_; + + # legacy syntax + $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns}) + if exists $attrs->{include_columns}; + + # 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 + # + # select/as +select/+as pairs need special handling - the amount of select/as + # elements in each pair does *not* have to be equal (think multicolumn + # selectors like distinct(foo, bar) ). If the selector is bare (no 'as' + # 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 + for my $pref ('', '+') { + + my ($sel, $as) = map { + my $key = "${pref}${_}"; + + my $val = [ ref $attrs->{$key} eq 'ARRAY' + ? @{$attrs->{$key}} + : $attrs->{$key} || () + ]; + delete $attrs->{$key}; + $val; + } qw/select as/; + + if (! @$as and ! @$sel ) { + next; + } + elsif (@$as and ! @$sel) { + $self->throw_exception( + "Unable to handle ${pref}as specification (@$as) without a corresponding ${pref}select" + ); + } + elsif( ! @$as ) { + # no as part supplied at all - try to deduce + # 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, $_; + } + } + + @$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 ) } + ); + } + 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); + } + } + +} + sub _stack_cond { my ($self, $left, $right) = @_; if (defined $left xor defined $right) { @@ -1229,6 +1420,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/}; my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count'); @@ -1246,7 +1438,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 select _prefetch_select as order_by for/}; + delete @{$sub_attrs}{qw/collapse columns as select _prefetch_selector_range _trailing_select 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 @@ -1266,10 +1458,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); + + my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }); - # disqualify join-based group_by's. Arcane but possible query + # 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}\./) { @@ -1428,7 +1652,7 @@ sub _rs_update_delete { my $attrs = $self->_resolved_attrs_copy; - delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_select as/; + delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/; $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ]; if ($needs_group_by_subq) { @@ -1495,6 +1719,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 { @@ -1675,21 +1908,24 @@ sub populate { push(@created, $self->create($item)); } return wantarray ? @created : \@created; - } else { + } + else { my $first = $data->[0]; # 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->{$_}; - $self->result_source->has_relationship($_) && ($ref eq 'ARRAY' or $ref eq 'HASH') + $rels->{$_} && ($ref eq 'ARRAY' or $ref eq 'HASH') ? push @rels, $_ : push @columns, $_ ; } - my @pks = $self->result_source->primary_columns; + my @pks = $rsrc->primary_columns; ## do the belongs_to relationships foreach my $index (0..$#$data) { @@ -1707,9 +1943,9 @@ sub populate { foreach my $rel (@rels) { next unless ref $data->[$index]->{$rel} eq "HASH"; my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel}); - my ($reverse) = keys %{$self->result_source->reverse_relationship_info($rel)}; + my ($reverse_relname, $reverse_relinfo) = %{$rsrc->reverse_relationship_info($rel)}; my $related = $result->result_source->_resolve_condition( - $result->result_source->relationship_info($reverse)->{cond}, + $reverse_relinfo->{cond}, $self, $result, ); @@ -1728,8 +1964,8 @@ sub populate { my @inherit_data = values %$rs_data; ## do bulk insert on current row - $self->result_source->storage->insert_bulk( - $self->result_source, + $rsrc->storage->insert_bulk( + $rsrc, [@columns, @inherit_cols], [ map { [ @$_{@columns}, @inherit_data ] } @$data ], ); @@ -1737,18 +1973,19 @@ sub populate { ## do the has_many relationships foreach my $item (@$data) { + my $main_row; + foreach my $rel (@rels) { - next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY"; + next unless ref $item->{$rel} eq "ARRAY" && @{ $item->{$rel} }; - my $parent = $self->find({map { $_ => $item->{$_} } @pks}) - || $self->throw_exception('Cannot find the relating object.'); + $main_row ||= $self->new_result({map { $_ => $item->{$_} } @pks}); - my $child = $parent->$rel; + my $child = $main_row->$rel; my $related = $child->result_source->_resolve_condition( - $parent->result_source->relationship_info($rel)->{cond}, + $rels->{$rel}{cond}, $child, - $parent, + $main_row, ); my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); @@ -1862,7 +2099,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 +2149,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 @@ -2659,7 +2901,7 @@ sub is_paged { sub is_ordered { my ($self) = @_; - return scalar $self->result_source->storage->_extract_order_columns($self->{attrs}{order_by}); + return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by}); } =head2 related_resultset @@ -2877,7 +3119,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 +3137,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 +3220,79 @@ sub _resolved_attrs { my $source = $self->result_source; my $alias = $attrs->{alias}; - $attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols}; - my @colbits; - - # build columns (as long as select isn't set) into a set of as/select hashes - unless ( $attrs->{select} ) { + # one last pass of normalization + $self->_normalize_selection($attrs); - my @cols; - if ( ref $attrs->{columns} eq 'ARRAY' ) { - @cols = @{ delete $attrs->{columns}} - } elsif ( defined $attrs->{columns} ) { - @cols = delete $attrs->{columns} - } else { - @cols = $source->columns - } + # default selection list + $attrs->{columns} = [ $source->columns ] + unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as _trailing_select/; - for (@cols) { - if ( ref $_ eq 'HASH' ) { - push @colbits, $_ - } else { - my $key = /^\Q${alias}.\E(.+)$/ - ? "$1" - : "$_"; - my $value = /\./ - ? "$_" - : "${alias}.$_"; - push @colbits, { $key => $value }; - } - } + # merge selectors together + for (qw/columns select as _trailing_select/) { + $attrs->{$_} = $self->_merge_attr($attrs->{$_}, $attrs->{"+$_"}) + if $attrs->{$_} or $attrs->{"+$_"}; } - # 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 }; - } + # disassemble columns + my (@sel, @as); + for my $c (@{ + ref $attrs->{columns} eq 'ARRAY' ? $attrs->{columns} : [ $attrs->{columns} || () ] + }) { + if (ref $c eq 'HASH') { + for my $as (keys %$c) { + push @sel, $c->{$as}; + push @as, $as; } } + else { + push @sel, $c; + push @as, $c; + } } - # start with initial select items - if ( $attrs->{select} ) { - $attrs->{select} = - ( ref $attrs->{select} eq 'ARRAY' ) - ? [ @{ $attrs->{select} } ] - : [ $attrs->{select} ]; + # when trying to weed off duplicates later do not go past this point - + # everything added from here on is unbalanced "anyone's guess" stuff + my $dedup_stop_idx = $#as; - 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} } - ] - } - } - else { + push @as, @{ ref $attrs->{as} eq 'ARRAY' ? $attrs->{as} : [ $attrs->{as} ] } + if $attrs->{as}; + push @sel, @{ ref $attrs->{select} eq 'ARRAY' ? $attrs->{select} : [ $attrs->{select} ] } + if $attrs->{select}; - # otherwise we intialise select & as to empty - $attrs->{select} = []; - $attrs->{as} = []; + # assume all unqualified selectors to apply to the current alias (legacy stuff) + for (@sel) { + $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_"; } - # now add colbits to select/as - push @{ $attrs->{select} }, map values %{$_}, @colbits; - push @{ $attrs->{as} }, map keys %{$_}, @colbits; - - if ( my $adds = delete $attrs->{'+select'} ) { - $adds = [$adds] unless ref $adds eq 'ARRAY'; - push @{ $attrs->{select} }, - map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds; + # disqualify all $alias.col as-bits (collapser mandated) + for (@as) { + $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_; } - if ( my $adds = delete $attrs->{'+as'} ) { - $adds = [$adds] unless ref $adds eq 'ARRAY'; - push @{ $attrs->{as} }, @$adds; + + # 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 <= $dedup_stop_idx) { + if ($seen->{"$sel[$i] \x00\x00 $as[$i]"}++) { + splice @sel, $i, 1; + splice @as, $i, 1; + $dedup_stop_idx--; + } + elsif ($seen->{$as[$i]}++) { + $self->throw_exception( + "inflate_result() alias '$as[$i]' specified twice with different SQL-side {select}-ors" + ); + } + else { + $i++; + } } + $attrs->{select} = \@sel; + $attrs->{as} = \@as; + $attrs->{from} ||= [{ -source_handle => $source->handle, -alias => $self->{attrs}{alias}, @@ -3081,10 +3304,10 @@ sub _resolved_attrs { $self->throw_exception ('join/prefetch can not be used with a custom {from}') if ref $attrs->{from} ne 'ARRAY'; - my $join = delete $attrs->{join} || {}; + 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,15 +3344,20 @@ sub _resolved_attrs { 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}{qw/from select order_by/} + $attrs->{from}, + [ @{$attrs->{select}||[]}, @{$attrs->{_trailing_select}||[]} ], + $attrs->{order_by}, ); } } $attrs->{collapse} ||= {}; - if ( my $prefetch = delete $attrs->{prefetch} ) { - $prefetch = $self->_merge_attr( {}, $prefetch ); + if ($attrs->{prefetch}) { + my $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ); my $prefetch_ordering = []; @@ -3158,15 +3386,22 @@ sub _resolved_attrs { $source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} ); # we need to somehow mark which columns came from prefetch - $attrs->{_prefetch_select} = [ map { $_->[0] } @prefetch ]; + if (@prefetch) { + my $sel_end = $#{$attrs->{select}}; + $attrs->{_prefetch_selector_range} = [ $sel_end + 1, $sel_end + @prefetch ]; + } - push @{ $attrs->{select} }, @{$attrs->{_prefetch_select}}; + push @{ $attrs->{select} }, (map { $_->[0] } @prefetch); push @{ $attrs->{as} }, (map { $_->[1] } @prefetch); push( @{$attrs->{order_by}}, @$prefetch_ordering ); $attrs->{_collapse_order_by} = \@$prefetch_ordering; } + + 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 @@ -3252,7 +3487,7 @@ sub _calculate_score { } } -sub _merge_attr { +sub _merge_joinpref_attr { my ($self, $orig, $import) = @_; return $import unless defined($orig); @@ -3284,7 +3519,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 @@ -3293,6 +3528,93 @@ 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 [] if !defined $_[0] and !keys %{$_[1]}; + 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 [] if !keys %{$_[0]} and !defined $_[1]; + return [ $_[0] ] if !defined $_[1]; + return [ $_[1] ] if !keys %{$_[0]}; + return [$_[0], $_[1]] + }, + ARRAY => sub { + return [] if !keys %{$_[0]} and !@{$_[1]}; + 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 [] if !keys %{$_[0]} and !keys %{$_[1]}; + 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; @@ -3303,6 +3625,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. @@ -3733,7 +4076,11 @@ HAVING is a select statement attribute that is applied between GROUP BY and ORDER BY. It is applied to the after the grouping calculations have been done. - having => { 'count(employee)' => { '>=', 100 } } + having => { 'count_employee' => { '>=', 100 } } + +or with an in-place function in which case literal SQL is required: + + having => \[ 'count(employee) >= ?', [ count => 100 ] ] =head2 distinct