From: Will Hawes Date: Wed, 15 Feb 2006 14:25:53 +0000 (+0000) Subject: introduce row caching using related_resultset; has_many prefetch (single-level only... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=64acc2bc801dcc1c982b16fe45434e9b82edcef6;p=dbsrgits%2FDBIx-Class-Historic.git introduce row caching using related_resultset; has_many prefetch (single-level only); **NOTE** breaks some tests in t/cdbi-t --- diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 7e6542d..8925121 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -85,41 +85,15 @@ sub register_relationship { } sub search_related { my $self = shift; - die "Can't call *_related as class methods" unless ref $self; my $rel = shift; - my $attrs = { }; - if (@_ > 1 && ref $_[$#_] eq 'HASH') { - $attrs = { %{ pop(@_) } }; + my $rs = $self->related_resultset($rel); + if( @_ ) { + return $rs->search(@_); } - my $rel_obj = $self->relationship_info($rel); - $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj; - $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} }; - - $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); - my $query = ((@_ > 1) ? {@_} : shift); - - my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self); - if (ref $cond eq 'ARRAY') { - $cond = [ map { my %hash; - foreach my $key (keys %{$_}) { - unless ($key =~ m/\./) { - $hash{"me.$key"} = $_->{$key}; - } else { - $hash{$key} = $_->{$key}; - } - }; \%hash; } @$cond ]; - } else { - foreach my $key (keys %$cond) { - unless ($key =~ m/\./) { - $cond->{"me.$key"} = delete $cond->{$key}; - } - } + else { + # search() returns a new resultset, so related_resultsets would be lost + return wantarray ? $rs->all : $rs; } - $query = ($query ? { '-and' => [ $cond, $query ] } : $cond); - #use Data::Dumper; warn Dumper($cond); - #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]}); - return $self->result_source->related_source($rel - )->resultset->search($query, $attrs); } =head2 count_related @@ -142,7 +116,9 @@ sub count_related { sub create_related { my $self = shift; my $rel = shift; - return $self->search_related($rel)->create(@_); + my $obj = $self->search_related($rel)->create(@_); + delete $self->{related_resultsets}->{$rel}; + return $obj; } =head2 new_related @@ -222,11 +198,72 @@ sub update_from_related { sub delete_related { my $self = shift; - return $self->search_related(@_)->delete; + my $obj = $self->search_related(@_)->delete; + delete $self->{related_resultsets}->{$_[0]}; + return $obj; } 1; +=head2 related_resultset($name) + +Returns a L for the relationship named $name. + + $rs = My::Table->related_resultset('related_table'); + +=cut + +sub related_resultset { + my $self = shift; + $self->throw_exception("Can't call *_related as class methods") unless ref $self; + my $rel = shift; + $self->{related_resultsets} ||= {}; + #use Data::Dumper; warn "related_resultsets: ", Dumper $self->{related_resultsets}; + my $resultsets = $self->{related_resultsets}; + if( !exists $resultsets->{$rel} ) { + + #warn "creating related resultset for relation '$rel'", \$self; + my $source = $self->result_source; + # if relation exists but resultset doesn't, create the resultset + + my $attrs = { }; + if (@_ > 1 && ref $_[$#_] eq 'HASH') { + $attrs = { %{ pop(@_) } }; + } + + my $rel_obj = $self->relationship_info($rel); + $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj; + $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} }; + + $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); + my $query = ((@_ > 1) ? {@_} : shift); + + my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self); + if (ref $cond eq 'ARRAY') { + $cond = [ map { my %hash; + foreach my $key (keys %{$_}) { + unless ($key =~ m/\./) { + $hash{"me.$key"} = $_->{$key}; + } else { + $hash{$key} = $_->{$key}; + } + }; \%hash; } @$cond ]; + } else { + foreach my $key (keys %$cond) { + unless ($key =~ m/\./) { + $cond->{"me.$key"} = delete $cond->{$key}; + } + } + } + $query = ($query ? { '-and' => [ $cond, $query ] } : $cond); + #use Data::Dumper; warn Dumper($cond); + #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]}); + $resultsets->{$rel} = + $self->result_source->related_source($rel)->resultset->search($query, $attrs); + } + return $resultsets->{$rel}; +} + =head1 AUTHORS Matt S. Trout diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index e8c020a..e0e321a 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -255,22 +255,7 @@ records. =cut sub search_related { - my ($self, $rel, @rest) = @_; - my $rel_obj = $self->result_source->relationship_info($rel); - $self->throw_exception( - "No such relationship ${rel} in search_related") - unless $rel_obj; - my $rs = $self->search(undef, { join => $rel }); - my $alias = ($rs->{attrs}{seen_join}{$rel} > 1 - ? join('_', $rel, $rs->{attrs}{seen_join}{$rel}) - : $rel); - return $self->result_source->schema->resultset($rel_obj->{class} - )->search( undef, - { %{$rs->{attrs}}, - alias => $alias, - select => undef(), - as => undef() } - )->search(@rest); + return shift->related_resultset(shift)->search(@_); } =head2 cursor @@ -368,6 +353,13 @@ Can be used to efficiently iterate over records in the resultset: sub next { my ($self) = @_; + my $cache = $self->get_cache; + if( @$cache ) { + $self->{all_cache_position} ||= 0; + my $obj = $cache->[$self->{all_cache_position}]; + $self->{all_cache_position}++; + return $obj; + } my @row = $self->cursor->next; # warn Dumper(\@row); use Data::Dumper; return unless (@row); @@ -376,17 +368,71 @@ sub next { sub _construct_object { my ($self, @row) = @_; + my @row_orig = @row; # copy @row for key comparison later, because @row will change my @as = @{ $self->{attrs}{as} }; #warn "@cols -> @row"; my $info = [ {}, {} ]; foreach my $as (@as) { + my $rs = $self; my $target = $info; my @parts = split(/\./, $as); my $col = pop(@parts); foreach my $p (@parts) { $target = $target->[1]->{$p} ||= []; + + # if cache is enabled, fetch inflated objs for prefetch + if( $rs->{attrs}->{cache} ) { + my $rel_info = $rs->result_source->relationship_info($p); + my $cond = $rel_info->{cond}; + my $parent_rs = $rs; + $rs = $rs->related_resultset($p); + $rs->{attrs}->{cache} = 1; + my @objs = (); + + # populate related resultset's cache if empty + if( !@{ $rs->get_cache } ) { + $rs->all; + } + + # get ordinals for pk columns in $row, so values can be compared + my $map = {}; + keys %$cond; + my $re = qr/^\w+\./; + while( my( $rel_key, $pk ) = ( each %$cond ) ) { + $rel_key =~ s/$re//; + $pk =~ s/$re//; + $map->{$rel_key} = $pk; + } #die Dumper $map; + + keys %$map; + while( my( $rel_key, $pk ) = each( %$map ) ) { + my $i = 0; + foreach my $col ( $parent_rs->result_source->columns ) { + if( $col eq $pk ) { + $map->{$rel_key} = $i; + } + $i++; + } + } #die Dumper $map; + + $rs->reset(); # reset cursor/cache position + + # get matching objects for inflation + OBJ: while( my $rel_obj = $rs->next ) { + keys %$map; + KEYS: while( my( $rel_key, $ordinal ) = each %$map ) { + # use get_column to avoid auto inflation (want scalar value) + if( $rel_obj->get_column($rel_key) ne $row_orig[$ordinal] ) { + next OBJ; + } + push @objs, $rel_obj; + } + } + $target->[0] = \@objs; + } } - $target->[0]->{$col} = shift @row; + $target->[0]->{$col} = shift @row + if ref($target->[0]) ne 'ARRAY'; # arrayref is pre-inflated objects, do not overwrite } #use Data::Dumper; warn Dumper(\@as, $info); my $new = $self->result_source->result_class->inflate_result( @@ -421,6 +467,8 @@ sub count { my $self = shift; return $self->search(@_)->count if @_ && defined $_[0]; unless (defined $self->{count}) { + return scalar @{ $self->get_cache } + if @{ $self->get_cache }; my $group_by; my $select = { 'count' => '*' }; if( $group_by = delete $self->{attrs}{group_by} ) { @@ -477,6 +525,14 @@ is returned in list context. sub all { my ($self) = @_; + return @{ $self->get_cache } + if @{ $self->get_cache }; + if( $self->{attrs}->{cache} ) { + my @obj = map { $self->_construct_object(@$_); } + $self->cursor->all; + $self->set_cache( \@obj ); + return @{ $self->get_cache }; + } return map { $self->_construct_object(@$_); } $self->cursor->all; } @@ -489,6 +545,7 @@ Resets the resultset's cursor, so you can iterate through the elements again. sub reset { my ($self) = @_; + $self->{all_cache_position} = 0; $self->cursor->reset; return $self; } @@ -751,6 +808,90 @@ sub update_or_create { return $row; } +=head2 get_cache + +Gets the contents of the cache for the resultset. + +=cut + +sub get_cache { + my $self = shift; + return $self->{all_cache} || []; +} + +=head2 set_cache + +Sets the contents of the cache for the resultset. Expects an arrayref of objects of the same class as those produced by the resultset. + +=cut + +sub set_cache { + my ( $self, $data ) = @_; + $self->throw_exception("set_cache requires an arrayref") + if ref $data ne 'ARRAY'; + my $result_class = $self->result_source->result_class; + foreach( @$data ) { + $self->throw_exception("cannot cache object of type '$_', expected '$result_class'") + if ref $_ ne $result_class; + } + $self->{all_cache} = $data; +} + +=head2 clear_cache + +Clears the cache for the resultset. + +=cut + +sub clear_cache { + my $self = shift; + $self->set_cache([]); +} + +=head2 related_resultset + +Returns a related resultset for the supplied relationship name. + + $rs = $rs->related_resultset('foo'); + +=cut + +sub related_resultset { + my ( $self, $rel, @rest ) = @_; + $self->{related_resultsets} ||= {}; + my $resultsets = $self->{related_resultsets}; + if( !exists $resultsets->{$rel} ) { + #warn "fetching related resultset for rel '$rel'"; + my $rel_obj = $self->result_source->relationship_info($rel); + $self->throw_exception( + "search_related: result source '" . $self->result_source->name . + "' has no such relationship ${rel}") + unless $rel_obj; #die Dumper $self->{attrs}; + my $rs; + if( $self->{attrs}->{cache} ) { + $rs = $self->search(undef); + } + else { + $rs = $self->search(undef, { join => $rel }); + } + #use Data::Dumper; die Dumper $rs->{attrs};#$rs = $self->search( undef ); + #use Data::Dumper; warn Dumper $self->{attrs}, Dumper $rs->{attrs}; + my $alias = (defined $rs->{attrs}{seen_join}{$rel} + && $rs->{attrs}{seen_join}{$rel} > 1 + ? join('_', $rel, $rs->{attrs}{seen_join}{$rel}) + : $rel); + $resultsets->{$rel} = + $self->result_source->schema->resultset($rel_obj->{class} + )->search( undef, + { %{$rs->{attrs}}, + alias => $alias, + select => undef(), + as => undef() } + )->search(@rest); + } + return $resultsets->{$rel}; +} + =head2 throw_exception See Schema's throw_exception diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 0d4a8a4..85a70a8 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -66,6 +66,7 @@ sub insert { $source->storage->insert($source->from, { $self->get_columns }); $self->in_storage(1); $self->{_dirty_columns} = {}; + $self->{related_resultsets} = {}; return $self; } @@ -109,6 +110,7 @@ sub update { $self->throw_exception("Can't update ${self}: updated more than one row"); } $self->{_dirty_columns} = {}; + $self->{related_resultsets} = {}; return $self; } @@ -292,25 +294,35 @@ sub inflate_result { }, ref $class || $class); my $schema; - PRE: foreach my $pre (keys %{$prefetch||{}}) { - my $pre_source = $source->related_source($pre); - $class->throw_exception("Can't prefetch non-existant relationship ${pre}") unless $pre_source; - my $fetched; - unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_} - and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns) - { - $fetched = $pre_source->result_class->inflate_result( - $pre_source, @{$prefetch->{$pre}}); + foreach my $pre (keys %{$prefetch||{}}) { + my $pre_val = $prefetch->{$pre}; + # if first prefetch item is arrayref, assume this is a has_many prefetch + # and that objects are pre inflated (TODO: check arrayref contents using "ref" to make sure) + if( ref $pre_val->[0] eq 'ARRAY' ) { + $new->related_resultset($pre)->set_cache( $pre_val->[0] ); } - my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; - $class->throw_exception("No accessor for prefetched $pre") - unless defined $accessor; - if ($accessor eq 'single') { - $new->{_relationship_data}{$pre} = $fetched; - } elsif ($accessor eq 'filter') { - $new->{_inflated_column}{$pre} = $fetched; - } else { - $class->throw_exception("Don't know how to store prefetched $pre"); + else { + my $pre_source = $source->related_source($pre); + $class->throw_exception("Can't prefetch non-existent relationship ${pre}") unless $pre_source; + my $fetched; + unless ($pre_source->primary_columns == grep { exists $prefetch->{$pre}[0]{$_} + and !defined $prefetch->{$pre}[0]{$_} } $pre_source->primary_columns) + { + $fetched = $pre_source->result_class->inflate_result( + $pre_source, @{$prefetch->{$pre}}); + } + my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; + $class->throw_exception("No accessor for prefetched $pre") + unless defined $accessor; + if ($accessor eq 'single') { + $new->{_relationship_data}{$pre} = $fetched; + } elsif ($accessor eq 'filter') { + $new->{_inflated_column}{$pre} = $fetched; + } elsif ($accessor eq 'multi') { + $class->throw_exception("Cache must be enabled for has_many prefetch '$pre'"); + } else { + $class->throw_exception("Prefetch not supported with accessor '$accessor'"); + } } } return $new; diff --git a/t/basicrels/22cache.t b/t/basicrels/22cache.t new file mode 100644 index 0000000..1f8672a --- /dev/null +++ b/t/basicrels/22cache.t @@ -0,0 +1,7 @@ +use Test::More; +use lib qw(t/lib); +use DBICTest; +use DBICTest::BasicRels; + +require "t/run/22cache.tl"; +run_tests(DBICTest->schema); diff --git a/t/lib/DBICTest/Schema/BasicRels.pm b/t/lib/DBICTest/Schema/BasicRels.pm index 2a4942c..fedeec9 100644 --- a/t/lib/DBICTest/Schema/BasicRels.pm +++ b/t/lib/DBICTest/Schema/BasicRels.pm @@ -5,7 +5,7 @@ use base 'DBIx::Class::Core'; DBICTest::Schema::Artist->add_relationship( cds => 'DBICTest::Schema::CD', { 'foreign.artist' => 'self.artistid' }, - { order_by => 'year', join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1 } + { order_by => 'year', join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1, accessor => 'multi' } ); DBICTest::Schema::Artist->add_relationship( twokeys => 'DBICTest::Schema::TwoKeys', diff --git a/t/run/22cache.tl b/t/run/22cache.tl new file mode 100644 index 0000000..68d6a93 --- /dev/null +++ b/t/run/22cache.tl @@ -0,0 +1,79 @@ +sub run_tests { +my $schema = shift; + +eval "use DBD::SQLite"; +plan skip_all => 'needs DBD::SQLite for testing' if $@; +plan tests => 8; + +my $rs = $schema->resultset("Artist")->search( + { artistid => 1 } +); + +my $artist = $rs->first; + +is( scalar @{ $rs->get_cache }, 0, 'cache is not populated without cache attribute' ); + +$rs = $schema->resultset("Artist")->search( + { 'artistid' => 1 }, + { + prefetch => [qw/ cds /], + cache => 1, + } +); + +# use Data::Dumper; $Data::Dumper::Deparse = 1; + +# start test for prefetch SELECT count +unlink 't/var/dbic.trace' if -e 't/var/dbic.trace'; +DBI->trace(1, 't/var/dbic.trace'); + +$artist = $rs->first; +$rs->reset(); + +# make sure artist contains a related resultset for cds +is( ref $artist->{related_resultsets}->{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' ); + +# check if $artist->cds->get_cache is populated +is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records'); + +# ensure that $artist->cds returns correct number of objects +is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' ); + +# ensure that $artist->cds->count returns correct value +is( $artist->cds->count, 3, 'artist->cds->count returns correct value' ); + +# ensure that $artist->count_related('cds') returns correct value +is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' ); + +# count the SELECTs +DBI->trace(0, undef); +my $selects = 0; +my $trace = IO::File->new('t/var/dbic.trace', '<') + or die "Unable to read trace file"; +while (<$trace>) { + $selects++ if /SELECT/; +} +$trace->close; +unlink 't/var/dbic.trace'; +is($selects, 2, 'only one SQL statement for each cached table'); + +# make sure related_resultset is deleted after object is updated +$artist->set_column('name', 'New Name'); +$artist->update(); + +is( scalar keys %{$artist->{related_resultsets}}, 0, 'related resultsets deleted after update' ); + +# todo: make sure caching works with nested prefetch e.g. $artist->cds->tracks +$rs = $schema->resultset("Artist")->search( + { artistid => 1 }, + { + prefetch => { + cds => 'tags' + }, + cache => 1 + } +); + +} + +1;