X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=d8dcfcaa45255a3127422b2767426de101daea88;hb=fe0708a2d68b5d34b6bc6f7e70164c3e569f1dd0;hp=7f9174cefe925468c8087dcf69945827e15de1fc;hpb=3170049a4e06723c0ce480532dd25d6c3e4847f6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 7f9174c..d8dcfca 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 Test::Deep::NoTest 'eq_deeply'; +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 eq_deeply( $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,7 +1038,7 @@ sub single { my $attrs = $self->_resolved_attrs_copy; - if (keys %{$attrs->{collapse}}) { + if ($attrs->{collapse}) { $self->throw_exception( 'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead' ); @@ -1022,7 +1061,10 @@ sub single { $attrs->{where}, $attrs ); - return (@data ? ($self->_construct_object(@data))[0] : undef); + return @data + ? ($self->_construct_objects(@data))[0] + : undef + ; } @@ -1199,141 +1241,361 @@ sub next { : $self->cursor->next ); return undef unless (@row); - my ($row, @more) = $self->_construct_object(@row); + my ($row, @more) = $self->_construct_objects(@row); $self->{stashed_objects} = \@more if @more; return $row; } -sub _construct_object { +# takes a single DBI-row of data and coinstructs as many objects +# as the resultset attributes call for. +# This can be a bit of an action at a distance - it takes as an argument +# the *current* cursor-row (already taken off the $sth), but if +# collapsing is requested it will keep advancing the cursor either +# until the current row-object is assembled (the collapser was able to +# order the result sensibly) OR until the cursor is exhausted (an +# unordered collapsing resultset effectively triggers ->all) + +# FIXME: why the *FUCK* do we pass around DBI data by copy?! Sadly needs +# assessment before changing... +# +sub _construct_objects { my ($self, @row) = @_; + my $attrs = $self->_resolved_attrs; + my $keep_collapsing = $attrs->{collapse}; + + my $res_index; +=begin + do { + my $me_pref_col = $attrs->{_row_parser}->($row_ref); + + my $container; + if ($keep_collapsing) { + + # FIXME - we should be able to remove these 2 checks after the design validates + $self->throw_exception ('Collapsing without a top-level collapse-set... can not happen') + unless @{$me_ref_col->[2]}; + $self->throw_exception ('Top-level collapse-set contains a NULL-value... can not happen') + if grep { ! defined $_ } @{$me_pref_col->[2]}; + + my $main_ident = join "\x00", @{$me_pref_col->[2]}; - my $info = $self->_collapse_result($self->{_attrs}{as}, \@row) + if (! $res_index->{$main_ident}) { + # this is where we bail out IFF we are ordered, and the $main_ident changes + + $res_index->{$main_ident} = { + all_me_pref => [, + index => scalar keys %$res_index, + }; + } + } + + + + $container = $res_index->{$main_ident}{container}; + }; + + push @$container, [ @{$me_pref_col}[0,1] ]; + + + + } while ( + $keep_collapsing + && + do { $row_ref = [$self->cursor->next]; $self->{stashed_row} = $row_ref if @$row_ref; scalar @$row_ref } + ); + + # attempt collapse all rows with same collapse identity + if (@to_collapse > 1) { + my @collapsed; + while (@to_collapse) { + $self->_merge_result(\@collapsed, shift @to_collapse); + } + } +=cut + + my $mepref_structs = $self->_collapse_result($attrs->{as}, \@row, $keep_collapsing) 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; + + my $rsrc = $self->result_source; + my $res_class = $self->result_class; + my $inflator = $res_class->can ('inflate_result'); + + my @objs = + $res_class->$inflator ($rsrc, @$mepref_structs); + + if (my $f = $attrs->{record_filter}) { + @objs = map { $f->($_) } @objs; + } + + return @objs; } + sub _collapse_result { - my ($self, $as_proto, $row) = @_; + my ( $self, $as_proto, $row_ref, $keep_collapsing ) = @_; + my $collapse = $self->_resolved_attrs->{collapse}; + my $parser = $self->result_source->_mk_row_parser( $as_proto, $collapse ); + my $result = []; + my $register = {}; + my $rel_register = {}; - my @copy = @$row; + my @row = @$row_ref; + do { + my $row = $parser->( \@row ); - # 'foo' => [ undef, 'foo' ] - # 'foo.bar' => [ 'foo', 'bar' ] - # 'foo.bar.baz' => [ 'foo.bar', 'baz' ] + # init register + $self->_check_register( $register, $row ) unless ( keys %$register ); - my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto; + $self->_merge_result( $result, $row, $rel_register ) + if ( !$collapse + || ( $collapse = $self->_check_register( $register, $row ) ) ); - my %collapse = %{$self->{_attrs}{collapse}||{}}; + } while ( + $collapse + && do { @row = $self->cursor->next; $self->{stashed_row} = \@row if @row; } + + # run this as long as there is a next row and we are not yet done collapsing + ); + return $result; +} - 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 +# Taubenschlag +sub _check_register { + my ( $self, $register, $obj ) = @_; + return undef unless ( ref $obj eq 'ARRAY' && ref $obj->[2] eq 'ARRAY' ); + my @ids = @{ $obj->[2] }; + while ( defined( my $id = shift @ids ) ) { + return $register->{$id} if ( exists $register->{$id} && !@ids ); + $register->{$id} = @ids ? {} : $obj unless ( exists $register->{$id} ); + $register = $register->{$id}; + } + return undef; +} - # store just the index so we can check the array positions from the row - # without having to contruct the full hash +sub _merge_result { + my ( $self, $result, $row, $register ) = @_; + return @$result = @$row if ( @$result == 0 ); # initialize with $row - 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 ( undef, $rels, $ids ) = @$result; + my ( undef, $new_rels, $new_ids ) = @$row; + + my @rels = keys %{ { %{$rels||{} }, %{ $new_rels||{} } } }; + foreach my $rel (@rels) { + $register = $register->{$rel} ||= {}; + + my $new_data = $new_rels->{$rel}; + my $data = $rels->{$rel}; + @$data = [@$data] unless ( ref $data->[0] eq 'ARRAY' ); + + $self->_check_register( $register, $data->[0] ) + unless ( keys %$register ); + + if ( my $found = $self->_check_register( $register, $new_data ) ) { + $self->_merge_result( $found, $new_data, $register ); + } + else { + push( @$data, $new_data ); } } + return 1; +} + +=begin - # no need to do an if, it'll be empty if @pri_index is empty anyway +# two arguments: $as_proto is an arrayref of column names, +# $row_ref is an arrayref of the data. If none of the row data +# is defined we return undef (that's copied from the old +# _collapse_result). Next we decide whether we need to collapse +# the resultset (i.e. we prefetch something) or not. $collapse +# indicates that. The do-while loop will run once if we do not need +# to collapse the result and will run as long as _merge_result returns +# a true value. It will return undef if the current added row does not +# match the previous row. A bit of stashing and cursor magic is +# required so that the cursor is not mixed up. - my %pri_vals = map { ($_ => $copy[$_]) } @pri_index; +# "$rows" is a bit misleading. In the end, there should only be one +# element in this arrayref. - my @const_rows; +sub _collapse_result { + my ( $self, $as_proto, $row_ref ) = @_; + my $has_def; + for (@$row_ref) { + if ( defined $_ ) { + $has_def++; + last; + } + } + return undef unless $has_def; + + my $collapse = $self->_resolved_attrs->{collapse}; + my $rows = []; + my @row = @$row_ref; + do { + my $i = 0; + my $row = { map { $_ => $row[ $i++ ] } @$as_proto }; + $row = $self->result_source->_parse_row($row, $collapse); + unless ( scalar @$rows ) { + push( @$rows, $row ); + } + $collapse = undef unless ( $self->_merge_result( $rows, $row ) ); + } while ( + $collapse + && do { @row = $self->cursor->next; $self->{stashed_row} = \@row if @row; } + ); - do { # no need to check anything at the front, we always want the first row + return $rows->[0]; - my %const; +} - foreach my $this_as (@construct_as) { - $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy); +# _merge_result accepts an arrayref of rows objects (again, an arrayref of two elements) +# and a row object which should be merged into the first object. +# First we try to find out whether $row is already in $rows. If this is the case +# we try to merge them by iteration through their relationship data. We call +# _merge_result again on them, so they get merged. + +# If we don't find the $row in $rows, we append it to $rows and return undef. +# _merge_result returns 1 otherwise (i.e. $row has been found in $rows). + +sub _merge_result { + my ( $self, $rows, $row ) = @_; + my ( $columns, $rels ) = @$row; + my $found = undef; + foreach my $seen (@$rows) { + my $match = 1; + foreach my $column ( keys %$columns ) { + if ( defined $seen->[0]->{$column} ^ defined $columns->{$column} + or defined $columns->{$column} + && $seen->[0]->{$column} ne $columns->{$column} ) + { + + $match = 0; + last; + } + } + if ($match) { + $found = $seen; + last; + } } + if ($found) { + foreach my $rel ( keys %$rels ) { + my $old_rows = $found->[1]->{$rel}; + $self->_merge_result( + ref $found->[1]->{$rel}->[0] eq 'HASH' ? [ $found->[1]->{$rel} ] + : $found->[1]->{$rel}, + ref $rels->{$rel}->[0] eq 'HASH' ? [ $rels->{$rel}->[0], $rels->{$rel}->[1] ] + : $rels->{$rel}->[0] + ); - push(@const_rows, \%const); + my $attrs = $self->_resolved_attrs; + my ($keep_collapsing, $set_ident) = @{$attrs}{qw/collapse _collapse_ident/}; + + # FIXME this is temporary, need to calculate in _resolved_attrs + $set_ident ||= { me => [ $self->result_source->_pri_cols ], pref => {} }; + + my @cur_row = @$row_ref; + my (@to_collapse, $last_ident); + + do { + my $row_hr = { map { $as_proto->[$_] => $cur_row[$_] } (0 .. $#$as_proto) }; + + # see if we are switching to another object + # this can be turned off and things will still work + # since _merge_prefetch knows about _collapse_ident +# my $cur_ident = [ @{$row_hr}{@$set_ident} ]; + my $cur_ident = []; + $last_ident ||= $cur_ident; + +# if ($keep_collapsing = Test::Deep::eq_deeply ($cur_ident, $last_ident)) { +# push @to_collapse, $self->result_source->_parse_row ( +# $row_hr, +# ); +# } + } while ( + $keep_collapsing + && + do { @cur_row = $self->cursor->next; $self->{stashed_row} = \@cur_row if @cur_row; } + ); - } until ( # no pri_index => no collapse => drop straight out - !@pri_index - or - do { # get another row, stash it, drop out if different PK + die Dumper \@to_collapse; - @copy = $self->cursor->next; - $self->{stashed_row} = \@copy; - # last thing in do block, counts as true if anything doesn't match + # attempt collapse all rows with same collapse identity + if (@to_collapse > 1) { + my @collapsed; + while (@to_collapse) { + $self->_merge_result(\@collapsed, shift @to_collapse); + } + @to_collapse = @collapsed; + } - # check xor defined first for NULL vs. NOT NULL then if one is - # defined the other must be so check string equality + # still didn't fully collapse + $self->throw_exception ('Resultset collapse failed (theoretically impossible). Maybe a wrong collapse_ident...?') + if (@to_collapse > 1); - grep { - (defined $pri_vals{$_} ^ defined $copy[$_]) - || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_])) - } @pri_index; - } - ); + return $to_collapse[0]; +} - my $alias = $self->{attrs}{alias}; - my $info = []; - my %collapse_pos; +# two arguments: $as_proto is an arrayref of 'as' column names, +# $row_ref is an arrayref of the data. The do-while loop will run +# once if we do not need to collapse the result and will run as long as +# _merge_result returns a true value. It will return undef if the +# current added row does not match the previous row, which in turn +# means we need to stash the row for the subsequent ->next call +sub _collapse_result { + my ( $self, $as_proto, $row_ref ) = @_; - my @const_keys; + my $attrs = $self->_resolved_attrs; + my ($keep_collapsing, $set_ident) = @{$attrs}{qw/collapse _collapse_ident/}; - 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}; - } - } + die Dumper [$as_proto, $row_ref, $keep_collapsing, $set_ident ]; + + + my @cur_row = @$row_ref; + my (@to_collapse, $last_ident); + + do { + my $row_hr = { map { $as_proto->[$_] => $cur_row[$_] } (0 .. $#$as_proto) }; + + # see if we are switching to another object + # this can be turned off and things will still work + # since _merge_prefetch knows about _collapse_ident +# my $cur_ident = [ @{$row_hr}{@$set_ident} ]; + my $cur_ident = []; + $last_ident ||= $cur_ident; + +# if ($keep_collapsing = eq_deeply ($cur_ident, $last_ident)) { +# push @to_collapse, $self->result_source->_parse_row ( +# $row_hr, +# ); +# } + } while ( + $keep_collapsing + && + do { @cur_row = $self->cursor->next; $self->{stashed_row} = \@cur_row if @cur_row; } + ); + + # attempt collapse all rows with same collapse identity +} +=cut + +# Takes an arrayref of me/pref pairs and a new me/pref pair that should +# be merged on a preexisting matching me (or should be pushed into $merged +# as a new me/pref pair for further invocations). It should be possible to +# use this function to collapse complete ->all results, provided _collapse_result() is adjusted +# to provide everything to this sub not to barf when $merged contains more than one +# arrayref) +sub _merge_prefetch { + my ($self, $merged, $next_row) = @_; + + unless (@$merged) { + push @$merged, $next_row; + return; } - return $info; } =head2 result_source @@ -1502,10 +1764,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 @@ -1619,30 +1886,32 @@ sub all { $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()"); } - return @{ $self->get_cache } if $self->get_cache; + if (my $c = $self->get_cache) { + return @$c; + } - my @obj; + my @objects; - if (keys %{$self->_resolved_attrs->{collapse}}) { + if ($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 + # _construct_objects to survive the approach $self->cursor->reset; my @row = $self->cursor->next; while (@row) { - push(@obj, $self->_construct_object(@row)); + push(@objects, $self->_construct_objects(@row)); @row = (exists $self->{stashed_row} ? @{delete $self->{stashed_row}} : $self->cursor->next); } } else { - @obj = map { $self->_construct_object(@$_) } $self->cursor->all; + @objects = map { $self->_construct_objects(@$_) } $self->cursor->all; } - $self->set_cache(\@obj) if $self->{attrs}{cache}; + $self->set_cache(\@objects) if $self->{attrs}{cache}; - return @obj; + return @objects; } =head2 reset @@ -1698,35 +1967,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 + } + + $needs_group_by_subq ||= exists $relation_classifications->{multiplying}; - 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/); + # 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}; - if ($needs_group_by_subq or $needs_subq) { + 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 _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); - 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 +2093,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 +2133,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 +2146,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 @@ -1830,7 +2180,7 @@ sub update_all { unless ref $values eq 'HASH'; my $guard = $self->result_source->schema->txn_scope_guard; - $_->update($values) for $self->all; + $_->update({%$values}) for $self->all; # shallow copy - update will mangle it $guard->commit; return 1; } @@ -1851,7 +2201,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. @@ -1972,13 +2322,15 @@ sub populate { # cruft placed in standalone method my $data = $self->_normalize_populate_args(@_); + return unless @$data; + if(defined wantarray) { my @created; foreach my $item (@$data) { push(@created, $self->create($item)); } return wantarray ? @created : \@created; - } + } else { my $first = $data->[0]; @@ -2076,7 +2428,10 @@ sub _normalize_populate_args { my ($self, $arg) = @_; if (ref $arg eq 'ARRAY') { - if (ref $arg->[0] eq 'HASH') { + if (!@$arg) { + return []; + } + elsif (ref $arg->[0] eq 'HASH') { return $arg; } elsif (ref $arg->[0] eq 'ARRAY') { @@ -2110,107 +2465,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) = @_; @@ -2229,70 +2483,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 @@ -2738,6 +2937,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 { @@ -2799,6 +3015,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 { @@ -2860,7 +3095,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 @@ -3088,9 +3323,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 @@ -3425,15 +3660,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 @@ -3456,8 +3693,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) { @@ -3467,9 +3703,31 @@ sub _resolved_attrs { push @{ $attrs->{select} }, (map { $_->[0] } @prefetch); push @{ $attrs->{as} }, (map { $_->[1] } @prefetch); + } + + # run through the resulting joinstructure (starting from our current slot) + # and unset collapse if proven unnesessary + if ($attrs->{collapse} && ref $attrs->{from} eq 'ARRAY') { + + if (@{$attrs->{from}} > 1) { - push( @{$attrs->{order_by}}, @$prefetch_ordering ); - $attrs->{_collapse_order_by} = \@$prefetch_ordering; + # 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; + } } @@ -3580,6 +3838,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 ); @@ -3694,6 +3953,11 @@ sub STORABLE_freeze { # A cursor in progress can't be serialized (and would make little sense anyway) delete $to_serialize->{cursor}; + # 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); } @@ -4215,6 +4479,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 @@ -4268,6 +4550,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