X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=11f275cacb2ad96a3654994687aa95769de538c0;hp=4fe52768d42339a3cb6229f49db3622ac126ce7a;hb=68f3b0dd9e91421b02c818ca42543b79bc197dfd;hpb=7af8b477f07d8ae5b759a285ae95d0c0f1697c8a diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 4fe5276..11f275c 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -3,17 +3,19 @@ package DBIx::Class::ResultSet; use strict; use warnings; use overload - '0+' => \&count, - 'bool' => sub { 1; }, + '0+' => "count", + 'bool' => "_bool", fallback => 1; use Carp::Clan qw/^DBIx::Class/; use Data::Page; use Storable; use DBIx::Class::ResultSetColumn; +use DBIx::Class::ResultSourceHandle; +use List::Util (); +use Scalar::Util (); use base qw/DBIx::Class/; -__PACKAGE__->load_components(qw/AccessorGroup/); -__PACKAGE__->mk_group_accessors('simple' => qw/result_source result_class/); +__PACKAGE__->mk_group_accessors('simple' => qw/result_class _source_handle/); =head1 NAME @@ -21,8 +23,8 @@ DBIx::Class::ResultSet - Responsible for fetching and creating resultset. =head1 SYNOPSIS - my $rs = $schema->resultset('User')->search(registered => 1); - my @rows = $schema->resultset('CD')->search(year => 2005); + my $rs = $schema->resultset('User')->search({ registered => 1 }); + my @rows = $schema->resultset('CD')->search({ year => 2005 })->all(); =head1 DESCRIPTION @@ -50,6 +52,13 @@ In the examples below, the following table classes are used: __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Artist'); 1; +=head1 OVERLOADING + +If a resultset is used in a numeric context it returns the L. +However, if it is used in a booleand context it is always true. So if +you want to check if a resultset has any results use C. +C will always be true. + =head1 METHODS =head2 new @@ -85,19 +94,21 @@ sub new { return $class->new_result(@_) if ref $class; my ($source, $attrs) = @_; - #weaken $source; + $source = $source->handle + unless $source->isa('DBIx::Class::ResultSourceHandle'); + $attrs = { %{$attrs||{}} }; if ($attrs->{page}) { $attrs->{rows} ||= 10; - $attrs->{offset} ||= 0; - $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1)); } $attrs->{alias} ||= 'me'; + # Creation of {} and bless separated to mitigate RH perl bug + # see https://bugzilla.redhat.com/show_bug.cgi?id=196836 my $self = { - result_source => $source, - result_class => $attrs->{result_class} || $source->result_class, + _source_handle => $source, + result_class => $attrs->{result_class} || $source->resolve->result_class, cond => $attrs->{where}, count => undef, pager => undef, @@ -133,7 +144,12 @@ call it as C. columns => [qw/name artistid/], }); -For a list of attributes that can be passed to C, see L. For more examples of using this function, see L. +For a list of attributes that can be passed to C, see +L. For more examples of using this function, see +L. For a complete +documentation for the first argument, see L. + +For more help on using joins with search, see L. =cut @@ -161,18 +177,26 @@ always return a resultset, even in list context. sub search_rs { my $self = shift; - my $rows; - - unless (@_) { # no search, effectively just a clone - $rows = $self->get_cache; - } - my $attrs = {}; $attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH'; my $our_attrs = { %{$self->{attrs}} }; my $having = delete $our_attrs->{having}; my $where = delete $our_attrs->{where}; + my $rows; + + my %safe = (alias => 1, cache => 1); + + unless ( + (@_ && defined($_[0])) # @_ == () or (undef) + || + (keys %$attrs # empty attrs or only 'safe' attrs + && List::Util::first { !$safe{$_} } keys %$attrs) + ) { + # no search, effectively just a clone + $rows = $self->get_cache; + } + my $new_attrs = { %{$our_attrs}, %{$attrs} }; # merge new attrs into inherited @@ -261,6 +285,13 @@ sub search_rs { Pass a literal chunk of SQL to be added to the conditional part of the resultset query. +CAVEAT: C is provided for Class::DBI compatibility and should +only be used in that context. There are known problems using C +in chained queries; it can result in bind values in the wrong order. See +L and +L for searching techniques that do not +require C. + =cut sub search_literal { @@ -305,11 +336,15 @@ Additionally, you can specify the columns explicitly by name: If the C is specified as C, it searches only on the primary key. If no C is specified, it searches on all unique constraints defined on the -source, including the primary key. +source for which column data is provided, including the primary key. If your table does not have a primary key, you B provide a value for the C attribute matching one of the unique constraints on the source. +Note: If your query does not return only one row, a warning is generated: + + Query returned more than one row + See also L and L. For information on how to declare unique constraints, see L. @@ -345,11 +380,13 @@ sub find { my (%related, $info); - foreach my $key (keys %$input_query) { + KEY: foreach my $key (keys %$input_query) { if (ref($input_query->{$key}) && ($info = $self->result_source->relationship_info($key))) { + my $val = delete $input_query->{$key}; + next KEY if (ref($val) eq 'ARRAY'); # has_many for multi_create my $rel_q = $self->result_source->resolve_condition( - $info->{cond}, delete $input_query->{$key}, $key + $info->{cond}, $val, $key ); die "Can't handle OR join condition in find" if ref($rel_q) eq 'ARRAY'; @related{keys %$rel_q} = values %$rel_q; @@ -359,25 +396,46 @@ sub find { @{$input_query}{@keys} = values %related; } - my @unique_queries = $self->_unique_queries($input_query, $attrs); # Build the final query: Default to the disjunction of the unique queries, # but allow the input query in case the ResultSet defines the query or the # user is abusing find my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias}; - my $query = @unique_queries - ? [ map { $self->_add_alias($_, $alias) } @unique_queries ] - : $self->_add_alias($input_query, $alias); + my $query; + if (exists $attrs->{key}) { + my @unique_cols = $self->result_source->unique_constraint_columns($attrs->{key}); + my $unique_query = $self->_build_unique_query($input_query, \@unique_cols); + $query = $self->_add_alias($unique_query, $alias); + } + else { + my @unique_queries = $self->_unique_queries($input_query, $attrs); + $query = @unique_queries + ? [ map { $self->_add_alias($_, $alias) } @unique_queries ] + : $self->_add_alias($input_query, $alias); + } # Run the query if (keys %$attrs) { my $rs = $self->search($query, $attrs); - return keys %{$rs->_resolved_attrs->{collapse}} ? $rs->next : $rs->single; + if (keys %{$rs->_resolved_attrs->{collapse}}) { + my $row = $rs->next; + carp "Query returned more than one row" if $rs->next; + return $row; + } + else { + return $rs->single; + } } else { - return keys %{$self->_resolved_attrs->{collapse}} - ? $self->search($query)->next - : $self->single($query); + if (keys %{$self->_resolved_attrs->{collapse}}) { + my $rs = $self->search($query); + my $row = $rs->next; + carp "Query returned more than one row" if $rs->next; + return $row; + } + else { + return $self->single($query); + } } } @@ -408,21 +466,23 @@ sub _unique_queries { ? ($attrs->{key}) : $self->result_source->unique_constraint_names; + my $where = $self->_collapse_cond($self->{attrs}{where} || {}); + my $num_where = scalar keys %$where; + my @unique_queries; foreach my $name (@constraint_names) { my @unique_cols = $self->result_source->unique_constraint_columns($name); my $unique_query = $self->_build_unique_query($query, \@unique_cols); + my $num_cols = scalar @unique_cols; my $num_query = scalar keys %$unique_query; - next unless $num_query; - # XXX: Assuming quite a bit about $self->{attrs}{where} - my $num_cols = scalar @unique_cols; - my $num_where = exists $self->{attrs}{where} - ? scalar keys %{ $self->{attrs}{where} } - : 0; - push @unique_queries, $unique_query - if $num_query + $num_where == $num_cols; + my $total = $num_query + $num_where; + if ($num_query && ($num_query == $num_cols || $total == $num_cols)) { + # The query is either unique on its own or is unique in combination with + # the existing where clause + push @unique_queries, $unique_query; + } } return @unique_queries; @@ -465,6 +525,17 @@ sub search_related { return shift->related_resultset(shift)->search(@_); } +=head2 search_related_rs + +This method works exactly the same as search_related, except that +it guarantees a restultset, even in list context. + +=cut + +sub search_related_rs { + return shift->related_resultset(shift)->search_rs(@_); +} + =head2 cursor =over 4 @@ -504,9 +575,17 @@ sub cursor { Inflates the first result without creating a cursor if the resultset has any records in it; if not returns nothing. Used by L as an optimisation. -Can optionally take an additional condition *only* - this is a fast-code-path -method; if you need to add extra joins or similar call ->search and then -->single without a condition on the $rs returned from that. +Can optionally take an additional condition B - this is a fast-code-path +method; if you need to add extra joins or similar call L and then +L without a condition on the L returned from +that. + +B: As of 0.08100, this method assumes that the query returns only one +row. If more than one row is returned, you will receive a warning: + + Query returned more than one row + +In this case, you should be using L or L instead. =cut @@ -536,7 +615,7 @@ sub single { $attrs->{where}, $attrs ); - return (@data ? ($self->_construct_object(@data))[0] : ()); + return (@data ? ($self->_construct_object(@data))[0] : undef); } # _is_unique_query @@ -731,7 +810,7 @@ sub next { ? @{delete $self->{stashed_row}} : $self->cursor->next ); - return unless (@row); + return undef unless (@row); my ($row, @more) = $self->_construct_object(@row); $self->{stashed_objects} = \@more if @more; return $row; @@ -747,78 +826,123 @@ sub _construct_object { } sub _collapse_result { - my ($self, $as, $row, $prefix) = @_; + my ($self, $as_proto, $row) = @_; - my %const; my @copy = @$row; - - foreach my $this_as (@$as) { - my $val = shift @copy; - if (defined $prefix) { - if ($this_as =~ m/^\Q${prefix}.\E(.+)$/) { - my $remain = $1; - $remain =~ /^(?:(.*)\.)?([^.]+)$/; - $const{$1||''}{$2} = $val; - } - } else { - $this_as =~ /^(?:(.*)\.)?([^.]+)$/; - $const{$1||''}{$2} = $val; - } - } - my $alias = $self->{attrs}{alias}; - my $info = [ {}, {} ]; - foreach my $key (keys %const) { - if (length $key && $key ne $alias) { - my $target = $info; - my @parts = split(/\./, $key); - foreach my $p (@parts) { - $target = $target->[1]->{$p} ||= []; + # '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 + + # store just the index so we can check the array positions from the row + # without having to contruct the full hash + + if (keys %collapse) { + my %pri = map { ($_ => 1) } $self->result_source->primary_columns; + 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); } - $target->[0] = $const{$key}; - } else { - $info->[0] = $const{$key}; + last unless keys %pri; # short circuit (Johnny Five Is Alive!) } } - - my @collapse; - if (defined $prefix) { - @collapse = map { - m/^\Q${prefix}.\E(.+)$/ ? ($1) : () - } keys %{$self->{_attrs}{collapse}} - } else { - @collapse = keys %{$self->{_attrs}{collapse}}; - }; - if (@collapse) { - my ($c) = sort { length $a <=> length $b } @collapse; - my $target = $info; - foreach my $p (split(/\./, $c)) { - $target = $target->[1]->{$p} ||= []; + # 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; + + do { # no need to check anything at the front, we always want the first row + + my %const; + + foreach my $this_as (@construct_as) { + $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy); } - my $c_prefix = (defined($prefix) ? "${prefix}.${c}" : $c); - my @co_key = @{$self->{_attrs}{collapse}{$c_prefix}}; - my $tree = $self->_collapse_result($as, $row, $c_prefix); - my %co_check = map { ($_, $tree->[0]->{$_}); } @co_key; - my (@final, @raw); - - while ( - !( + + 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 + + @copy = $self->cursor->next; + $self->{stashed_row} = \@copy; + + # last thing in do block, counts as true if anything doesn't match + + # check xor defined first for NULL vs. NOT NULL then if one is + # defined the other must be so check string equality + grep { - !defined($tree->[0]->{$_}) || $co_check{$_} ne $tree->[0]->{$_} - } @co_key - ) - ) { - push(@final, $tree); - last unless (@raw = $self->cursor->next); - $row = $self->{stashed_row} = \@raw; - $tree = $self->_collapse_result($as, $row, $c_prefix); + (defined $pri_vals{$_} ^ defined $copy[$_]) + || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_])) + } @pri_index; + } + ); + + my $alias = $self->{attrs}{alias}; + my $info = []; + + my %collapse_pos; + + 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}; + } } - @$target = (@final ? @final : [ {}, {} ]); - # single empty result to indicate an empty prefetched has_many } - #print "final info: " . Dumper($info); return $info; } @@ -866,7 +990,7 @@ Performs an SQL C with the same query as the resultset was built with to find the number of elements. If passed arguments, does a search on the resultset and counts the results of that. -Note: When using C with C, L emulates C +Note: When using C with C, L emulates C using C. Some databases (notably SQLite) do not support C with multiple columns. If you are using such a database, you should only use columns from the main table in your C @@ -881,9 +1005,12 @@ sub count { my $count = $self->_count; return 0 unless $count; - $count -= $self->{attrs}{offset} if $self->{attrs}{offset}; + # need to take offset from resolved attrs + + $count -= $self->{_attrs}{offset} if $self->{_attrs}{offset}; $count = $self->{attrs}{rows} if $self->{attrs}{rows} and $self->{attrs}{rows} < $count; + $count = 0 if ($count < 0); return $count; } @@ -921,6 +1048,10 @@ sub _count { # Separated out so pager can get the full count return $count; } +sub _bool { + return 1; +} + =head2 count_literal =over 4 @@ -1184,6 +1315,141 @@ sub delete_all { return 1; } +=head2 populate + +=over 4 + +=item Arguments: \@data; + +=back + +Pass an arrayref of hashrefs. Each hashref should be a structure suitable for +submitting to a $resultset->create(...) method. + +In void context, C in L is used +to insert the data, as this is a faster method. + +Otherwise, each set of data is inserted into the database using +L, and a arrayref of the resulting row +objects is returned. + +Example: Assuming an Artist Class that has many CDs Classes relating: + + my $Artist_rs = $schema->resultset("Artist"); + + ## Void Context Example + $Artist_rs->populate([ + { artistid => 4, name => 'Manufactured Crap', cds => [ + { title => 'My First CD', year => 2006 }, + { title => 'Yet More Tweeny-Pop crap', year => 2007 }, + ], + }, + { artistid => 5, name => 'Angsty-Whiny Girl', cds => [ + { title => 'My parents sold me to a record company' ,year => 2005 }, + { title => 'Why Am I So Ugly?', year => 2006 }, + { title => 'I Got Surgery and am now Popular', year => 2007 } + ], + }, + ]); + + ## Array Context Example + my ($ArtistOne, $ArtistTwo, $ArtistThree) = $Artist_rs->populate([ + { name => "Artist One"}, + { name => "Artist Two"}, + { name => "Artist Three", cds=> [ + { title => "First CD", year => 2007}, + { title => "Second CD", year => 2008}, + ]} + ]); + + print $ArtistOne->name; ## response is 'Artist One' + print $ArtistThree->cds->count ## reponse is '2' + +Please note an important effect on your data when choosing between void and +wantarray context. Since void context goes straight to C in +L this will skip any component that is overriding +c. So if you are using something like L to +create primary keys for you, you will find that your PKs are empty. In this +case you will have to use the wantarray context in order to create those +values. + +=cut + +sub populate { + my ($self, $data) = @_; + + if(defined wantarray) { + my @created; + foreach my $item (@$data) { + push(@created, $self->create($item)); + } + return @created; + } else { + my ($first, @rest) = @$data; + + my @names = grep {!ref $first->{$_}} keys %$first; + my @rels = grep { $self->result_source->has_relationship($_) } keys %$first; + my @pks = $self->result_source->primary_columns; + + ## do the belongs_to relationships + foreach my $index (0..$#$data) { + if( grep { !defined $data->[$index]->{$_} } @pks ) { + my @ret = $self->populate($data); + return; + } + + foreach my $rel (@rels) { + next unless $data->[$index]->{$rel} && 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 $related = $result->result_source->resolve_condition( + $result->result_source->relationship_info($reverse)->{cond}, + $self, + $result, + ); + + delete $data->[$index]->{$rel}; + $data->[$index] = {%{$data->[$index]}, %$related}; + + push @names, keys %$related if $index == 0; + } + } + + ## do bulk insert on current row + my @values = map { [ @$_{@names} ] } @$data; + + $self->result_source->storage->insert_bulk( + $self->result_source, + \@names, + \@values, + ); + + ## do the has_many relationships + foreach my $item (@$data) { + + foreach my $rel (@rels) { + next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY"; + + my $parent = $self->find(map {{$_=>$item->{$_}} } @pks) + || $self->throw_exception('Cannot find the relating object.'); + + my $child = $parent->$rel; + + my $related = $child->result_source->resolve_condition( + $parent->result_source->relationship_info($rel)->{cond}, + $child, + $parent, + ); + + my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel}); + my @populate = map { {%$_, %$related} } @rows_to_add; + + $child->populate( \@populate ); + } + } + } +} + =head2 pager =over 4 @@ -1240,7 +1506,12 @@ sub page { =back -Creates an object in the resultset's result class and returns it. +Creates a new row object in the resultset's result class and returns +it. The row is not inserted into the database at this point, call +L to do that. Calling L +will tell you whether the row object has been inserted or not. + +Passes the hashref of input on to L. =cut @@ -1248,20 +1519,60 @@ sub new_result { my ($self, $values) = @_; $self->throw_exception( "new_result needs a hash" ) unless (ref $values eq 'HASH'); - $self->throw_exception( - "Can't abstract implicit construct, condition not a hash" - ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH')); + my %new; my $alias = $self->{attrs}{alias}; - my $collapsed_cond = $self->{cond} ? $self->_collapse_cond($self->{cond}) : {}; - my %new = ( + + if ( + defined $self->{cond} + && $self->{cond} eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION + ) { + %new = %{$self->{attrs}{related_objects}}; + } else { + $self->throw_exception( + "Can't abstract implicit construct, condition not a hash" + ) if ($self->{cond} && !(ref $self->{cond} eq 'HASH')); + + my $collapsed_cond = ( + $self->{cond} + ? $self->_collapse_cond($self->{cond}) + : {} + ); + + # precendence must be given to passed values over values inherited from + # the cond, so the order here is important. + my %implied = %{$self->_remove_alias($collapsed_cond, $alias)}; + while( my($col,$value) = each %implied ){ + if(ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '='){ + $new{$col} = $value->{'='}; + next; + } + $new{$col} = $value if $self->_is_deterministic_value($value); + } + } + + %new = ( + %new, %{ $self->_remove_alias($values, $alias) }, - %{ $self->_remove_alias($collapsed_cond, $alias) }, - -result_source => $self->result_source, + -source_handle => $self->_source_handle, + -result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED ); - my $obj = $self->result_class->new(\%new); - return $obj; + return $self->result_class->new(\%new); +} + +# _is_deterministic_value +# +# Make an effor to strip non-deterministic values from the condition, +# to make sure new_result chokes less + +sub _is_deterministic_value { + my $self = shift; + my $value = shift; + my $ref_type = ref $value; + return 1 if $ref_type eq '' || $ref_type eq 'SCALAR'; + return 1 if Scalar::Util::blessed($value); + return 0; } # _collapse_cond @@ -1354,14 +1665,63 @@ sub find_or_new { =item Arguments: \%vals -=item Return Value: $object +=item Return Value: a L $object =back -Inserts a record into the resultset and returns the object representing it. +Attempt to create a single new row or a row with multiple related rows +in the table represented by the resultset (and related tables). This +will not check for duplicate rows before inserting, use +L to do that. + +To create one row for this resultset, pass a hashref of key/value +pairs representing the columns of the table and the values you wish to +store. If the appropriate relationships are set up, foreign key fields +can also be passed an object representing the foreign row, and the +value will be set to it's primary key. + +To create related objects, pass a hashref for the value if the related +item is a foreign key relationship (L), +and use the name of the relationship as the key. (NOT the name of the field, +necessarily). For C and C relationships, pass an arrayref +of hashrefs containing the data for each of the rows to create in the foreign +tables, again using the relationship name as the key. + +Instead of hashrefs of plain related data (key/value pairs), you may +also pass new or inserted objects. New objects (not inserted yet, see +L), will be inserted into their appropriate tables. Effectively a shortcut for C<< ->new_result(\%vals)->insert >>. +Example of creating a new row. + + $person_rs->create({ + name=>"Some Person", + email=>"somebody@someplace.com" + }); + +Example of creating a new row and also creating rows in a related C +or C resultset. Note Arrayref. + + $artist_rs->create( + { artistid => 4, name => 'Manufactured Crap', cds => [ + { title => 'My First CD', year => 2006 }, + { title => 'Yet More Tweeny-Pop crap', year => 2007 }, + ], + }, + ); + +Example of creating a new row and also creating a row in a related +Cresultset. Note Hashref. + + $cd_rs->create({ + title=>"Music for Silly Walks", + year=>2000, + artist => { + name=>"Silly Musician", + } + }); + =cut sub create { @@ -1404,6 +1764,12 @@ constraint. For example: { key => 'cd_artist_title' } ); +Note: Because find_or_create() reads from the database and then +possibly inserts based on the result, this method is subject to a race +condition. Another process could create a record in the table after +the find has completed and before the create has started. To avoid +this problem, use find_or_create() inside a transaction. + See also L and L. For information on how to declare unique constraints, see L. @@ -1483,6 +1849,9 @@ sub update_or_create { Gets the contents of the cache for the resultset, if the cache is set. +The cache is populated either by using the L attribute to +L or by calling L. + =cut sub get_cache { @@ -1504,6 +1873,9 @@ of objects of the same class as those produced by the resultset. Note that if the cache is set the resultset will return the cached objects rather than re-querying the database even if the cache attr is not set. +The contents of the cache can also be populated by using the +L attribute to L. + =cut sub set_cache { @@ -1555,7 +1927,7 @@ sub related_resultset { my $rel_obj = $self->result_source->relationship_info($rel); $self->throw_exception( - "search_related: result source '" . $self->result_source->name . + "search_related: result source '" . $self->result_source->source_name . "' has no such relationship $rel") unless $rel_obj; @@ -1564,18 +1936,47 @@ sub related_resultset { my $join_count = $seen->{$rel}; my $alias = ($join_count > 1 ? join('_', $rel, $join_count) : $rel); - $self->result_source->schema->resultset($rel_obj->{class})->search_rs( - undef, { - %{$self->{attrs}||{}}, - join => undef, - prefetch => undef, - select => undef, - as => undef, - alias => $alias, - where => $self->{cond}, - seen_join => $seen, - from => $from, - }); + #XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi + my %attrs = %{$self->{attrs}||{}}; + delete @attrs{qw(result_class alias)}; + + my $new_cache; + + if (my $cache = $self->get_cache) { + if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) { + $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} } + @$cache ]; + } + } + + my $rel_source = $self->result_source->related_source($rel); + + my $new = do { + + # The reason we do this now instead of passing the alias to the + # search_rs below is that if you wrap/overload resultset on the + # source you need to know what alias it's -going- to have for things + # to work sanely (e.g. RestrictWithObject wants to be able to add + # extra query restrictions, and these may need to be $alias.) + + my $attrs = $rel_source->resultset_attributes; + local $attrs->{alias} = $alias; + + $rel_source->resultset + ->search_rs( + undef, { + %attrs, + join => undef, + prefetch => undef, + select => undef, + as => undef, + where => $self->{cond}, + seen_join => $seen, + from => $from, + }); + }; + $new->set_cache($new_cache) if $new_cache; + $new; }; } @@ -1592,9 +1993,14 @@ sub _resolve_from { my $join = ($attrs->{join} ? [ $attrs->{join}, $extra_join ] : $extra_join); + + # we need to take the prefetch the attrs into account before we + # ->resolve_join as otherwise they get lost - captainL + my $merged = $self->_merge_attr( $join, $attrs->{prefetch} ); + $from = [ @$from, - ($join ? $source->resolve_join($join, $attrs->{alias}, $seen) : ()), + ($join ? $source->resolve_join($merged, $attrs->{alias}, $seen) : ()), ]; return ($from,$seen); @@ -1605,7 +2011,7 @@ sub _resolved_attrs { return $self->{_attrs} if $self->{_attrs}; my $attrs = { %{$self->{attrs}||{}} }; - my $source = $self->{result_source}; + my $source = $self->result_source; my $alias = $attrs->{alias}; $attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols}; @@ -1655,6 +2061,7 @@ sub _resolved_attrs { $join = $self->_merge_attr( $join, $attrs->{prefetch} ); + } $attrs->{from} = # have to copy here to avoid corrupting the original @@ -1662,6 +2069,7 @@ sub _resolved_attrs { @{$attrs->{from}}, $source->resolve_join($join, $alias, { %{$attrs->{seen_join}||{}} }) ]; + } $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct}; @@ -1690,51 +2098,127 @@ sub _resolved_attrs { } $attrs->{collapse} = $collapse; + if ($attrs->{page}) { + $attrs->{offset} ||= 0; + $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1)); + } + return $self->{_attrs} = $attrs; } +sub _rollout_attr { + my ($self, $attr) = @_; + + if (ref $attr eq 'HASH') { + return $self->_rollout_hash($attr); + } elsif (ref $attr eq 'ARRAY') { + return $self->_rollout_array($attr); + } else { + return [$attr]; + } +} + +sub _rollout_array { + my ($self, $attr) = @_; + + my @rolled_array; + foreach my $element (@{$attr}) { + if (ref $element eq 'HASH') { + push( @rolled_array, @{ $self->_rollout_hash( $element ) } ); + } elsif (ref $element eq 'ARRAY') { + # XXX - should probably recurse here + push( @rolled_array, @{$self->_rollout_array($element)} ); + } else { + push( @rolled_array, $element ); + } + } + return \@rolled_array; +} + +sub _rollout_hash { + my ($self, $attr) = @_; + + my @rolled_array; + foreach my $key (keys %{$attr}) { + push( @rolled_array, { $key => $attr->{$key} } ); + } + return \@rolled_array; +} + +sub _calculate_score { + my ($self, $a, $b) = @_; + + if (ref $b eq 'HASH') { + my ($b_key) = keys %{$b}; + if (ref $a eq 'HASH') { + my ($a_key) = keys %{$a}; + if ($a_key eq $b_key) { + return (1 + $self->_calculate_score( $a->{$a_key}, $b->{$b_key} )); + } else { + return 0; + } + } else { + return ($a eq $b_key) ? 1 : 0; + } + } else { + if (ref $a eq 'HASH') { + my ($a_key) = keys %{$a}; + return ($b eq $a_key) ? 1 : 0; + } else { + return ($b eq $a) ? 1 : 0; + } + } +} + sub _merge_attr { my ($self, $a, $b) = @_; + return $b unless defined($a); return $a unless defined($b); - if (ref $b eq 'HASH' && ref $a eq 'HASH') { - foreach my $key (keys %{$b}) { - if (exists $a->{$key}) { - $a->{$key} = $self->_merge_attr($a->{$key}, $b->{$key}); - } else { - $a->{$key} = $b->{$key}; + $a = $self->_rollout_attr($a); + $b = $self->_rollout_attr($b); + + my $seen_keys; + foreach my $b_element ( @{$b} ) { + # find best candidate from $a to merge $b_element into + my $best_candidate = { position => undef, score => 0 }; my $position = 0; + foreach my $a_element ( @{$a} ) { + my $score = $self->_calculate_score( $a_element, $b_element ); + if ($score > $best_candidate->{score}) { + $best_candidate->{position} = $position; + $best_candidate->{score} = $score; } + $position++; } - return $a; - } else { - $a = [$a] unless ref $a eq 'ARRAY'; - $b = [$b] unless ref $b eq 'ARRAY'; - - my $hash = {}; - my @array; - foreach my $x ($a, $b) { - foreach my $element (@{$x}) { - if (ref $element eq 'HASH') { - $hash = $self->_merge_attr($hash, $element); - } elsif (ref $element eq 'ARRAY') { - push(@array, @{$element}); - } else { - push(@array, $element) unless $b == $x - && grep { $_ eq $element } @array; - } + my ($b_key) = ( ref $b_element eq 'HASH' ) ? keys %{$b_element} : ($b_element); + + if ($best_candidate->{score} == 0 || exists $seen_keys->{$b_key}) { + push( @{$a}, $b_element ); + } else { + my $a_best = $a->[$best_candidate->{position}]; + # merge a_best and b_element together and replace original with merged + if (ref $a_best ne 'HASH') { + $a->[$best_candidate->{position}] = $b_element; + } elsif (ref $b_element eq 'HASH') { + my ($key) = keys %{$a_best}; + $a->[$best_candidate->{position}] = { $key => $self->_merge_attr($a_best->{$key}, $b_element->{$key}) }; } } - - @array = grep { !exists $hash->{$_} } @array; - - return keys %{$hash} - ? ( scalar(@array) - ? [$hash, @array] - : $hash - ) - : \@array; + $seen_keys->{$b_key} = 1; # don't merge the same key twice } + + return $a; +} + +sub result_source { + my $self = shift; + + if (@_) { + $self->_source_handle($_[0]->handle); + } else { + $self->_source_handle->resolve; + } } =head2 throw_exception @@ -1745,7 +2229,12 @@ See L for details. sub throw_exception { my $self=shift; - $self->result_source->schema->throw_exception(@_); + if (ref $self && $self->_source_handle->schema) { + $self->_source_handle->schema->throw_exception(@_) + } else { + croak(@_); + } + } # XXX: FIXME: Attributes docs need clearing up @@ -1801,7 +2290,9 @@ Shortcut to include additional columns in the returned results - for example }); would return all CDs and include a 'name' column to the information -passed to object inflation +passed to object inflation. Note that the 'artist' is the name of the +column (or relationship) accessor, and 'name' is the name of the column +accessor in the related table. =head2 select @@ -1832,7 +2323,7 @@ return a column named C in the above example. =over 4 Indicates additional columns to be selected from storage. Works the same as -L but adds columns to the selection. =back @@ -1840,7 +2331,7 @@ L, usually when C. + +The C attribute is used in conjunction with C contains one or more function or stored procedure names: $rs = $schema->resultset('Employee')->search(undef, { @@ -1956,6 +2452,8 @@ to Earth' and a cd with title 'Popular'. If you want to fetch related objects from other tables as well, see C below. +For more help on using joins with search, see L. + =head2 prefetch =over 4 @@ -1964,10 +2462,11 @@ below. =back -Contains one or more relationships that should be fetched along with the main -query (when they are accessed afterwards they will have already been -"prefetched"). This is useful for when you know you will need the related -objects, because it saves at least one query: +Contains one or more relationships that should be fetched along with +the main query (when they are accessed afterwards the data will +already be available, without extra queries to the database). This is +useful for when you know you will need the related objects, because it +saves at least one query: my $rs = $schema->resultset('Tag')->search( undef, @@ -1989,13 +2488,27 @@ C or C relationships, which saves us two SQL statements in this case. Simple prefetches will be joined automatically, so there is no need -for a C attribute in the above search. If you're prefetching to -depth (e.g. { cd => { artist => 'label' } or similar), you'll need to -specify the join as well. +for a C attribute in the above search. C can be used with the following relationship types: C, C (or if you're using C, any relationship declared -with an accessor type of 'single' or 'filter'). +with an accessor type of 'single' or 'filter'). A more complex example that +prefetches an artists cds, the tracks on those cds, and the tags associted +with that artist is given below (assuming many-to-many from artists to tags): + + my $rs = $schema->resultset('Artist')->search( + undef, + { + prefetch => [ + { cds => 'tracks' }, + { artist_tags => 'tags' } + ] + } + ); + + +B If you specify a C attribute, the C and C