X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=a9c4ab77ff742d762b50b58629e778012af563be;hb=2d0b795a54a018d5c9cf2593cf83045962cd9b93;hp=4c5b9617f6b040db282ac3a519db65692f979d27;hpb=ce855fffdd5cf13e9fd29ad9883ab7cbb9a7b22a;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 4c5b961..a9c4ab7 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -8,7 +8,7 @@ use DBIx::Class::Exception; use DBIx::Class::ResultSetColumn; use Scalar::Util qw/blessed weaken/; use Try::Tiny; -use Data::Compare; +use Data::Compare (); # no imports!!! guard against insane architecture # not importing first() as it will clash with our own method use List::Util (); @@ -74,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 @@ -265,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 @@ -446,7 +474,7 @@ 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 + # 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) @@ -569,7 +597,7 @@ sub _stack_cond { 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 Compare( $left->{$_}, $right->{$_} ); + delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} ); } $right = undef unless keys %$right; @@ -702,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 = {}; @@ -748,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, ), @@ -790,7 +829,7 @@ sub find { # Run the query, passing the result_class since it should propagate for find my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs}); - if (keys %{$rs->_resolved_attrs->{collapse}}) { + if ($rs->_resolved_attrs->{collapse}) { my $row = $rs->next; carp "Query returned more than one row" if $rs->next; return $row; @@ -888,7 +927,7 @@ sub _build_unique_cond { =over 4 -=item Arguments: $rel, $cond, \%attrs? +=item Arguments: $rel, $cond?, \%attrs? =item Return Value: $new_resultset (scalar context) || @row_objs (list context) @@ -999,11 +1038,9 @@ sub single { my $attrs = $self->_resolved_attrs_copy; - if (keys %{$attrs->{collapse}}) { - $self->throw_exception( - 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' - ); - } + $self->throw_exception( + 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' + ) if $attrs->{collapse}; if ($where) { if (defined $attrs->{where}) { @@ -1017,12 +1054,13 @@ sub single { } } - my @data = $self->result_source->storage->select_single( + my $data = [ $self->result_source->storage->select_single( $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs - ); - - return (@data ? ($self->_construct_object(@data))[0] : undef); + )]; + return undef unless @$data; + $self->{stashed_rows} = [ $data ]; + $self->_construct_objects->[0]; } @@ -1179,161 +1217,156 @@ first record from the resultset. sub next { my ($self) = @_; + if (my $cache = $self->get_cache) { $self->{all_cache_position} ||= 0; return $cache->[$self->{all_cache_position}++]; } + if ($self->{attrs}{cache}) { delete $self->{pager}; $self->{all_cache_position} = 1; return ($self->all)[0]; } - if ($self->{stashed_objects}) { - my $obj = shift(@{$self->{stashed_objects}}); - delete $self->{stashed_objects} unless @{$self->{stashed_objects}}; - return $obj; - } - my @row = ( - exists $self->{stashed_row} - ? @{delete $self->{stashed_row}} - : $self->cursor->next - ); - return undef unless (@row); - my ($row, @more) = $self->_construct_object(@row); - $self->{stashed_objects} = \@more if @more; - return $row; -} -sub _construct_object { - my ($self, @row) = @_; + return shift(@{$self->{stashed_objects}}) if @{ $self->{stashed_objects}||[] }; - my $info = $self->_collapse_result($self->{_attrs}{as}, \@row) - or return (); - my @new = $self->result_class->inflate_result($self->result_source, @$info); - @new = $self->{_attrs}{record_filter}->(@new) - if exists $self->{_attrs}{record_filter}; - return @new; -} + $self->{stashed_objects} = $self->_construct_objects + or return undef; -sub _collapse_result { - my ($self, $as_proto, $row) = @_; - - my @copy = @$row; - - # 'foo' => [ undef, 'foo' ] - # 'foo.bar' => [ 'foo', 'bar' ] - # 'foo.bar.baz' => [ 'foo.bar', 'baz' ] - - my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto; - - my %collapse = %{$self->{_attrs}{collapse}||{}}; - - my @pri_index; - - # if we're doing collapsing (has_many prefetch) we need to grab records - # until the PK changes, so fill @pri_index. if not, we leave it empty so - # we know we don't have to bother. - - # the reason for not using the collapse stuff directly is because if you - # had for e.g. two artists in a row with no cds, the collapse info for - # both would be NULL (undef) so you'd lose the second artist + return shift @{$self->{stashed_objects}}; +} - # store just the index so we can check the array positions from the row - # without having to contruct the full hash +# Constructs as many objects as it can in one pass while respecting +# cursor laziness. Several modes of operation: +# +# * Always builds everything present in @{$self->{stashed_rows}} +# * If called with $fetch_all true - pulls everything off the cursor and +# builds all objects in one pass +# * If $self->_resolved_attrs->{collapse} is true, checks the order_by +# and if the resultset is ordered properly by the left side: +# * Fetches stuff off the cursor until the "master object" changes, +# and saves the last extra row (if any) in @{$self->{stashed_rows}} +# OR +# * Just fetches, and collapses/constructs everything as if $fetch_all +# was requested (there is no other way to collapse except for an +# eager cursor) +# * If no collapse is requested - just get the next row, construct and +# return +sub _construct_objects { + my ($self, $fetch_all) = @_; - if (keys %collapse) { - my %pri = map { ($_ => 1) } $self->result_source->_pri_cols; - foreach my $i (0 .. $#construct_as) { - next if defined($construct_as[$i][0]); # only self table - if (delete $pri{$construct_as[$i][1]}) { - push(@pri_index, $i); - } - last unless keys %pri; # short circuit (Johnny Five Is Alive!) - } + my $rsrc = $self->result_source; + my $attrs = $self->_resolved_attrs; + my $cursor = $self->cursor; + + # this will be used as both initial raw-row collector AND as a RV of + # _construct_objects. Not regrowing the array twice matters a lot... + # a suprising amount actually + my $rows = (delete $self->{stashed_rows}) || []; + if ($fetch_all) { + # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + $rows = [ @$rows, $cursor->all ]; } + elsif (!$attrs->{collapse}) { + # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + push @$rows, do { my @r = $cursor->next; @r ? \@r : () } + unless @$rows; + } + else { + $attrs->{_ordered_for_collapse} ||= (!$attrs->{order_by}) ? undef : do { + my $st = $rsrc->schema->storage; + my @ord_cols = map + { $_->[0] } + ( $st->_extract_order_criteria($attrs->{order_by}) ) + ; - # no need to do an if, it'll be empty if @pri_index is empty anyway - - my %pri_vals = map { ($_ => $copy[$_]) } @pri_index; - - my @const_rows; + my $colinfos = $st->_resolve_column_info($attrs->{from}, \@ord_cols); - do { # no need to check anything at the front, we always want the first row + for (0 .. $#ord_cols) { + if ( + ! $colinfos->{$ord_cols[$_]} + or + $colinfos->{$ord_cols[$_]}{-result_source} != $rsrc + ) { + splice @ord_cols, $_; + last; + } + } - my %const; + # since all we check here are the start of the order_by belonging to the + # top level $rsrc, a present identifying set will mean that the resultset + # is ordered by its leftmost table in a tsable manner + (@ord_cols and $rsrc->_identifying_column_set({ map + { $colinfos->{$_}{-colname} => $colinfos->{$_} } + @ord_cols + })) ? 1 : 0; + }; - foreach my $this_as (@construct_as) { - $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy); + if ($attrs->{_ordered_for_collapse}) { + push @$rows, do { my @r = $cursor->next; @r ? \@r : () }; } + # instead of looping over ->next, use ->all in stealth mode + # FIXME - encapsulation breach, got to be a better way + elsif (! $cursor->{done}) { + push @$rows, $cursor->all; + $cursor->{done} = 1; + $fetch_all = 1; + } + } - push(@const_rows, \%const); - - } until ( # no pri_index => no collapse => drop straight out - !@pri_index - or - do { # get another row, stash it, drop out if different PK + return undef unless @$rows; - @copy = $self->cursor->next; - $self->{stashed_row} = \@copy; + my $res_class = $self->result_class; + my $inflator = $res_class->can ('inflate_result') + or $self->throw_exception("Inflator $res_class does not provide an inflate_result() method"); - # last thing in do block, counts as true if anything doesn't match + my $infmap = $attrs->{as}; - # check xor defined first for NULL vs. NOT NULL then if one is - # defined the other must be so check string equality + if (!$attrs->{collapse} and $attrs->{_single_object_inflation}) { + # construct a much simpler array->hash folder for the one-table cases right here - grep { - (defined $pri_vals{$_} ^ defined $copy[$_]) - || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_])) - } @pri_index; + # FIXME SUBOPTIMAL this is a very very very hot spot + # while rather optimal we can *still* do much better, by + # building a smarter [Row|HRI]::inflate_result(), and + # switch to feeding it data via a much leaner interface + # + # crude unscientific benchmarking indicated the shortcut eval is not worth it for + # this particular resultset size + if (@$rows < 60) { + my @as_idx = 0..$#$infmap; + for my $r (@$rows) { + $r = $inflator->($res_class, $rsrc, { map { $infmap->[$_] => $r->[$_] } @as_idx } ); } - ); - - my $alias = $self->{attrs}{alias}; - my $info = []; - - my %collapse_pos; + } + else { + eval sprintf ( + '$_ = $inflator->($res_class, $rsrc, { %s }) for @$rows', + join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap ) + ); + } + } + else { + ($self->{_row_parser} ||= eval sprintf 'sub { %s }', $rsrc->_mk_row_parser({ + inflate_map => $infmap, + selection => $attrs->{select}, + collapse => $attrs->{collapse}, + }) or die $@)->($rows, $fetch_all ? () : ( + # FIXME SUBOPTIMAL - we can do better, cursor->next/all (well diff. methods) should return a ref + sub { my @r = $cursor->next or return; \@r }, # how the collapser gets more rows + ($self->{stashed_rows} = []), # where does it stuff excess + )); # modify $rows in-place, shrinking/extending as necessary + + $_ = $inflator->($res_class, $rsrc, @$_) for @$rows; - my @const_keys; + } - foreach my $const (@const_rows) { - scalar @const_keys or do { - @const_keys = sort { length($a) <=> length($b) } keys %$const; - }; - foreach my $key (@const_keys) { - if (length $key) { - my $target = $info; - my @parts = split(/\./, $key); - my $cur = ''; - my $data = $const->{$key}; - foreach my $p (@parts) { - $target = $target->[1]->{$p} ||= []; - $cur .= ".${p}"; - if ($cur eq ".${key}" && (my @ckey = @{$collapse{$cur}||[]})) { - # collapsing at this point and on final part - my $pos = $collapse_pos{$cur}; - CK: foreach my $ck (@ckey) { - if (!defined $pos->{$ck} || $pos->{$ck} ne $data->{$ck}) { - $collapse_pos{$cur} = $data; - delete @collapse_pos{ # clear all positioning for sub-entries - grep { m/^\Q${cur}.\E/ } keys %collapse_pos - }; - push(@$target, []); - last CK; - } - } - } - if (exists $collapse{$cur}) { - $target = $target->[-1]; - } - } - $target->[0] = $data; - } else { - $info->[0] = $const->{$key}; - } - } + # CDBI compat stuff + if ($attrs->{record_filter}) { + $_ = $attrs->{record_filter}->($_) for @$rows; } - return $info; + return $rows; } =head2 result_source @@ -1502,10 +1535,15 @@ sub _count_subq_rs { # 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 order_by for/}; - # if we multi-prefetch we group_by primary keys only as this is what we would + # if we multi-prefetch we group_by something unique, as this is what we would # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless - if ( keys %{$attrs->{collapse}} ) { - $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } ($rsrc->_pri_cols) ] + if ( $attrs->{collapse} ) { + $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{ + $rsrc->_identifying_column_set || $self->throw_exception( + 'Unable to construct a unique group_by criteria properly collapsing the ' + . 'has_many prefetch before count()' + ); + } ] } # Calculate subquery selector @@ -1616,33 +1654,23 @@ Returns all elements in the resultset. sub all { my $self = shift; if(@_) { - $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); + $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); } - return @{ $self->get_cache } if $self->get_cache; - - my @obj; - - if (keys %{$self->_resolved_attrs->{collapse}}) { - # Using $self->cursor->all is really just an optimisation. - # If we're collapsing has_many prefetches it probably makes - # very little difference, and this is cleaner than hacking - # _construct_object to survive the approach - $self->cursor->reset; - my @row = $self->cursor->next; - while (@row) { - push(@obj, $self->_construct_object(@row)); - @row = (exists $self->{stashed_row} - ? @{delete $self->{stashed_row}} - : $self->cursor->next); - } - } else { - @obj = map { $self->_construct_object(@$_) } $self->cursor->all; + delete $self->{stashed_rows}; + delete $self->{stashed_objects}; + + if (my $c = $self->get_cache) { + return @$c; } - $self->set_cache(\@obj) if $self->{attrs}{cache}; + $self->cursor->reset; + + my $objs = $self->_construct_objects('fetch_all') || []; - return @obj; + $self->set_cache($objs) if $self->{attrs}{cache}; + + return @$objs; } =head2 reset @@ -1663,7 +1691,10 @@ another query. sub reset { my ($self) = @_; - delete $self->{_attrs} if exists $self->{_attrs}; + delete $self->{_attrs}; + delete $self->{stashed_rows}; + delete $self->{stashed_objects}; + $self->{all_cache_position} = 0; $self->cursor->reset; return $self; @@ -1698,35 +1729,122 @@ 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} }; + + # "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}; + + # 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); + + $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 + } - my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/); - my $needs_subq = $needs_group_by_subq || $self->_has_resolved_attr(qw/rows offset/); + $needs_group_by_subq ||= exists $relation_classifications->{multiplying}; - if ($needs_group_by_subq or $needs_subq) { + # 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}; + + return $rsrc->storage->$op( + $rsrc, + $op eq 'update' ? $values : (), + $self->{cond} ? \[$sql, @bind] : (), + ); + } - # make a new $rs selecting only the PKs (that's all we really need) - my $attrs = $self->_resolved_attrs_copy; + # 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, + ) + ); + 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 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); - delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/; - $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ]; + 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, + ); + 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" @@ -1737,33 +1855,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 { - # 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}; + my $guard = $storage->txn_scope_guard; - return $rsrc->storage->$op( + my @op_condition; + for my $row ($subrs->search({}, { group_by => $subq_group_by })->cursor->all) { + push @op_condition, { map + { $idcols->[$_] => $row->[$_] } + (0 .. $#$idcols) + }; + } + + my $res = $storage->$op ( $rsrc, $op eq 'update' ? $values : (), - $self->{cond} ? \[$sql, @bind] : (), + \@op_condition, ); + + $guard->commit; + + return $res; } } @@ -1783,7 +1895,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 @@ -1796,7 +1908,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 @@ -1851,7 +1963,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. @@ -1980,7 +2092,7 @@ sub populate { push(@created, $self->create($item)); } return wantarray ? @created : \@created; - } + } else { my $first = $data->[0]; @@ -2115,107 +2227,6 @@ 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) = @_; @@ -2234,70 +2245,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 - - require Data::Page; - 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 @@ -2743,6 +2699,23 @@ all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. +If you need to know if an existing row was found or a new one created use +L and L instead. Don't forget +to call L to save the newly created row to the +database! + + my $cd = $schema->resultset('CD')->find_or_new({ + cdid => 5, + artist => 'Massive Attack', + title => 'Mezzanine', + year => 2005, + }); + + if( $cd->in_storage ) { + # do some stuff + $cd->insert; + } + =cut sub find_or_create { @@ -2804,6 +2777,25 @@ all in the call to C, even when set to C. See also L and L. For information on how to declare unique constraints, see L. +If you need to know if an existing row was updated or a new one created use +L and L instead. Don't forget +to call L to save the newly created row to the +database! + + my $cd = $schema->resultset('CD')->update_or_new( + { + artist => 'Massive Attack', + title => 'Mezzanine', + year => 1998, + }, + { key => 'cd_artist_title' } + ); + + if( $cd->in_storage ) { + # do some stuff + $cd->insert; + } + =cut sub update_or_create { @@ -2865,7 +2857,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 @@ -3033,7 +3025,7 @@ sub related_resultset { if (my $cache = $self->get_cache) { if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) { - $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} } + $new_cache = [ map { @{$_->related_resultset($rel)->get_cache||[]} } @$cache ]; } } @@ -3093,9 +3085,9 @@ source alias of the current result set: my $me = $self->current_source_alias; - return $self->search( + return $self->search({ "$me.modified" => $user->id, - ); + }); } =cut @@ -3336,14 +3328,10 @@ sub _resolved_attrs { if $attrs->{select}; # assume all unqualified selectors to apply to the current alias (legacy stuff) - for (@sel) { - $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_"; - } + $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" for @sel; - # disqualify all $alias.col as-bits (collapser mandated) - for (@as) { - $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_; - } + # disqualify all $alias.col as-bits (inflate-map mandated) + $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_ for @as; # de-duplicate the result (remove *identical* select/as pairs) # and also die on duplicate {as} pointing to different {select}s @@ -3430,15 +3418,17 @@ sub _resolved_attrs { } } - $attrs->{collapse} ||= {}; - if ($attrs->{prefetch}) { + # generate selections based on the prefetch helper + my $prefetch; + $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ) + if defined $attrs->{prefetch}; + + if ($prefetch) { $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}") if $attrs->{_dark_selector}; - my $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} ); - - my $prefetch_ordering = []; + $attrs->{collapse} = 1; # this is a separate structure (we don't look in {from} directly) # as the resolver needs to shift things off the lists to work @@ -3461,8 +3451,7 @@ sub _resolved_attrs { } } - my @prefetch = - $source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} ); + my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map ); # we need to somehow mark which columns came from prefetch if (@prefetch) { @@ -3472,11 +3461,40 @@ sub _resolved_attrs { push @{ $attrs->{select} }, (map { $_->[0] } @prefetch); push @{ $attrs->{as} }, (map { $_->[1] } @prefetch); + } + + $attrs->{_single_object_inflation} = ! List::Util::first { $_ =~ /\./ } @{$attrs->{as}}; + + # run through the resulting joinstructure (starting from our current slot) + # and unset collapse if proven unnesessary + if ($attrs->{collapse} && ref $attrs->{from} eq 'ARRAY') { - push( @{$attrs->{order_by}}, @$prefetch_ordering ); - $attrs->{_collapse_order_by} = \@$prefetch_ordering; + if (@{$attrs->{from}} > 1) { + + # find where our table-spec starts and consider only things after us + my @fromlist = @{$attrs->{from}}; + while (@fromlist) { + my $t = shift @fromlist; + $t = $t->[0] if ref $t eq 'ARRAY'; #me vs join from-spec mismatch + last if ($t->{-alias} && $t->{-alias} eq $alias); + } + + for (@fromlist) { + $attrs->{collapse} = ! $_->[0]{-is_single} + and last; + } + } + else { + # no joins - no collapse + $attrs->{collapse} = 0; + } } + if (! $attrs->{order_by} and $attrs->{collapse}) { + # default order for collapsing unless the user asked for something + $attrs->{order_by} = [ map { "$alias.$_" } $source->primary_columns ]; + $attrs->{_ordered_for_collapse} = 1; + } # 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 @@ -3585,6 +3603,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 ); @@ -3699,6 +3718,14 @@ sub STORABLE_freeze { # A cursor in progress can't be serialized (and would make little sense anyway) delete $to_serialize->{cursor}; + # the parser can be regenerated + delete $to_serialize->{_row_parser}; + + # 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); } @@ -4220,6 +4247,24 @@ rows per page if the page attribute or method is used. Specifies the (zero-based) row number for the first row to be returned, or the of the first row of the first page if paging is used. +=head2 software_limit + +=over 4 + +=item Value: (0 | 1) + +=back + +When combined with L and/or L the generated SQL will not +include any limit dialect stanzas. Instead the entire result will be selected +as if no limits were specified, and DBIC will perform the limit locally, by +artificially advancing and finishing the resulting L. + +This is the recommended way of performing resultset limiting when no sane RDBMS +implementation is available (e.g. +L using the +L hack) + =head2 group_by =over 4 @@ -4273,6 +4318,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