From: Will Hawes <wdhawes@gmail.com>
Date: Wed, 22 Feb 2006 09:08:00 +0000 (+0000)
Subject: nested has_many prefetch + tests
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f9cc31dddebb6a36835c11348680ccd7d70939cc;p=dbsrgits%2FDBIx-Class-Historic.git

nested has_many prefetch + tests
---

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 920ee00..1e3925c 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -382,6 +382,7 @@ 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} };
+#use Data::Dumper; warn Dumper \@as;
   #warn "@cols -> @row";
   my $info = [ {}, {} ];
   foreach my $as (@as) {
@@ -392,57 +393,9 @@ sub _construct_object {
     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;
-      }
+      $rs = $rs->related_resultset($p) if $rs->{attrs}->{cache};
     }
+    
     $target->[0]->{$col} = shift @row
       if ref($target->[0]) ne 'ARRAY'; # arrayref is pre-inflated objects, do not overwrite
   }
@@ -451,8 +404,55 @@ sub _construct_object {
               $self->result_source, @$info);
   $new = $self->{attrs}{record_filter}->($new)
     if exists $self->{attrs}{record_filter};
+ 
+  if( $self->{attrs}->{cache} ) {
+    while( my( $rel, $rs ) = each( %{$self->{related_resultsets}} ) ) {
+      $rs->all;
+      #warn "$rel:", @{$rs->get_cache};
+    }
+    $self->build_rr( $self, $new );
+  }
+ 
   return $new;
 }
+  
+sub build_rr {
+  # build related resultsets for supplied object
+  my ( $self, $context, $obj ) = @_;
+  
+  my $re = qr/^\w+\./;
+  while( my ($rel, $rs) = each( %{$context->{related_resultsets}} ) ) {  
+    #warn "context:", $context->result_source->name, ", rel:$rel, rs:", $rs->result_source->name;
+    my @objs = ();
+    my $map = {};
+    my $cond = $context->result_source->relationship_info($rel)->{cond};
+    keys %$cond;
+    while( my( $rel_key, $pk ) = each(%$cond) ) {
+      $rel_key =~ s/$re//;
+      $pk =~ s/$re//;
+      $map->{$rel_key} = $pk;
+    }
+    
+    $rs->reset();
+    while( my $rel_obj = $rs->next ) {
+      while( my( $rel_key, $pk ) = each(%$map) ) {
+        if( $rel_obj->get_column($rel_key) eq $obj->get_column($pk) ) {
+          push @objs, $rel_obj;
+        }
+      }
+    }
+
+    my $rel_rs = $obj->related_resultset($rel);
+    $rel_rs->{attrs}->{cache} = 1;
+    $rel_rs->set_cache( \@objs );
+    
+    while( my $rel_obj = $rel_rs->next ) {
+      $self->build_rr( $rs, $rel_obj );
+    }
+    
+  }
+  
+}
 
 =head2 result_source
 
diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index 80cd18c..df8bba8 100644
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -297,33 +297,26 @@ sub inflate_result {
   my $schema;
   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 $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}});      
     }
-    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'");
-      }
+    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') {
+      
+    } else {
+     $class->throw_exception("Prefetch not supported with accessor '$accessor'");
     }
   }
   return $new;
diff --git a/t/lib/DBICTest/Schema/BasicRels.pm b/t/lib/DBICTest/Schema/BasicRels.pm
index fedeec9..ecb9cef 100644
--- a/t/lib/DBICTest/Schema/BasicRels.pm
+++ b/t/lib/DBICTest/Schema/BasicRels.pm
@@ -38,7 +38,7 @@ DBICTest::Schema::CD->add_relationship(
 DBICTest::Schema::CD->add_relationship(
     tags => 'DBICTest::Schema::Tag',
     { 'foreign.cd' => 'self.cdid' },
-    { join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1 }
+    { join_type => 'LEFT', cascade_delete => 1, cascade_copy => 1, accessor => 'multi' }
 );
 #DBICTest::Schema::CD->might_have(liner_notes => 'DBICTest::Schema::LinerNotes' => qw/notes/);
 DBICTest::Schema::CD->add_relationship(
diff --git a/t/run/22cache.tl b/t/run/22cache.tl
index 68d6a93..9402596 100644
--- a/t/run/22cache.tl
+++ b/t/run/22cache.tl
@@ -3,7 +3,7 @@ my $schema = shift;
 
 eval "use DBD::SQLite";
 plan skip_all => 'needs DBD::SQLite for testing' if $@;
-plan tests => 8;
+plan tests => 12;
 
 my $rs = $schema->resultset("Artist")->search(
   { artistid => 1 }
@@ -21,7 +21,7 @@ $rs = $schema->resultset("Artist")->search(
   }
 );
 
-# use Data::Dumper; $Data::Dumper::Deparse = 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';
@@ -74,6 +74,59 @@ $rs = $schema->resultset("Artist")->search(
   }
 );
 
+# SELECT count for nested has_many prefetch
+unlink 't/var/dbic.trace' if -e 't/var/dbic.trace';
+DBI->trace(1, 't/var/dbic.trace');
+
+$artist = $rs->first;
+
+# 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, 3, 'one SQL statement for each cached table with nested prefetch');
+
+my @objs;
+my $artist = $rs->find(1);
+
+unlink 't/var/dbic.trace' if -e 't/var/dbic.trace';
+DBI->trace(1, 't/var/dbic.trace');
+
+my $cds = $artist->cds;
+my $tags = $cds->next->tags;
+while( my $tag = $tags->next ) {
+  push @objs, $tag->tagid; #warn "tag:", $tag->ID;
+}
+
+is_deeply( \@objs, [ 1 ], 'first cd has correct tags' );
+
+$tags = $cds->next->tags;
+@objs = ();
+while( my $tag = $tags->next ) {
+  push @objs, $tag->id; #warn "tag: ", $tag->ID;
+}
+
+is_deeply( \@objs, [ 2, 5, 8 ], 'second cd has correct tags' );
+
+# 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, 0, 'no additional SQL statements while checking nested data' );
+
 }
 
 1;