partially working has_many prefetch

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index a39252a..ba36b7c 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -106,7 +106,10 @@ sub new {
     if $attrs->{order_by} && !ref($attrs->{order_by});
   $attrs->{order_by} ||= [];
 
+  my $collapse = {};
+
   if (my $prefetch = delete $attrs->{prefetch}) {
+    my @pre_order;
     foreach my $p (ref $prefetch eq 'ARRAY'
               ? (@{$prefetch}) : ($prefetch)) {
       if( ref $p eq 'HASH' ) {
@@ -120,11 +123,12 @@ sub new {
             unless $seen{$p};
       }
       my @prefetch = $source->resolve_prefetch(
-           $p, $attrs->{alias}, {}, $attrs->{order_by});
+           $p, $attrs->{alias}, {}, \@pre_order, $collapse);
       #die Dumper \@cols;
       push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
       push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
     }
+    push(@{$attrs->{order_by}}, @pre_order);
   }
 
   if ($attrs->{page}) {
@@ -132,11 +136,17 @@ sub new {
     $attrs->{offset} ||= 0;
     $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1));
   }
+
+#if (keys %{$collapse}) {
+#  use Data::Dumper; warn Dumper($collapse);
+#}
+
   my $new = {
     result_source => $source,
     result_class => $attrs->{result_class} || $source->result_class,
     cond => $attrs->{where},
     from => $attrs->{from},
+    collapse => $collapse,
     count => undef,
     page => delete $attrs->{page},
     pager => undef,
@@ -397,10 +407,12 @@ sub next {
     return $obj;
   }
   if ($self->{attrs}{cache}) {
-    $self->{all_cache_position} = 0;
+    $self->{all_cache_position} = 1;
     return ($self->all)[0];
   }
-  my @row = delete $self->{stashed_row} || $self->cursor->next;
+  my @row = (exists $self->{stashed_row}
+               ? @{delete $self->{stashed_row}}
+               : $self->cursor->next);
 #  warn Dumper(\@row); use Data::Dumper;
   return unless (@row);
   return $self->_construct_object(@row);
@@ -408,33 +420,77 @@ 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} };
-#use Data::Dumper; warn Dumper \@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} ||= [];
-      
-      $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
-  }
+
+  my $info = $self->_collapse_result(\@as, \@row);
+
   #use Data::Dumper; warn Dumper(\@as, $info);
   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;
 }
 
+sub _collapse_result {
+  my ($self, $as, $row, $prefix) = @_;
+
+  my %const;
+
+  my @copy = @$row;
+  foreach my $as (@$as) {
+    if (defined $prefix && !($as =~ s/\Q${prefix}\E\.//)) {
+      shift @copy;
+      next;
+    }
+    $as =~ /^(?:(.*)\.)?([^\.]+)$/;
+    $const{$1||''}{$2} = shift @copy;
+  }
+
+  #warn "@cols -> @row";
+  my $info = [ {}, {} ];
+  foreach my $key (keys %const) {
+    if (length $key) {
+      my $target = $info;
+      my @parts = split(/\./, $key);
+      foreach my $p (@parts) {
+        $target = $target->[1]->{$p} ||= [];
+      }
+      $target->[0] = $const{$key};
+    } else {
+      $info->[0] = $const{$key};
+    }
+  }
+
+  if (!defined($prefix) && keys %{$self->{collapse}}) {
+    my ($c) = sort { length $a <=> length $b } keys %{$self->{collapse}};
+    #warn "Collapsing ${c}";
+    my $target = $info;
+    #warn Data::Dumper::Dumper($target);
+    foreach my $p (split(/\./, $c)) {
+      $target = $target->[1]->{$p};
+    }
+    my @co_key = @{$self->{collapse}{$c}};
+    my %co_check = map { ($_, $target->[0]->{$_}); } @co_key;
+    my $tree = $self->_collapse_result($as, $row, $c);
+    #warn Data::Dumper::Dumper($target);
+    my (@final, @raw);
+    while ( !(grep { $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);
+    }
+    @{$target} = @final;
+    #warn Data::Dumper::Dumper($target);
+  }
+
+  #warn Dumper($info);
+
+  return $info;
+}
+
 =head2 result_source
 
 Returns a reference to the result source for this recordset.

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index edeb5b2..5c9d657 100644 (file)
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -545,21 +545,23 @@ in the supplied relationships. Examples:
 =cut
 
 sub resolve_prefetch {
-  my ($self, $pre, $alias, $seen, $order) = @_;
+  my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
   $seen ||= {};
   use Data::Dumper;
   #$alias ||= $self->name;
   #warn $alias, Dumper $pre;
   if( ref $pre eq 'ARRAY' ) {
-    return map { $self->resolve_prefetch( $_, $alias, $seen, $order ) } @$pre;
+    return
+      map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
+        @$pre;
   }
   elsif( ref $pre eq 'HASH' ) {
     my @ret =
     map {
-      $self->resolve_prefetch($_, $alias, $seen, $order),
+      $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
       $self->related_source($_)->resolve_prefetch(
-                                   $pre->{$_}, "${alias}.$_", $seen, $order)
-        } keys %$pre;
+               $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
+    } keys %$pre;
     #die Dumper \@ret;
     return @ret;
   }
@@ -575,9 +577,18 @@ sub resolve_prefetch {
       unless $rel_info;
     my $as_prefix = ($alias =~ /^.*?\.(.*)$/ ? $1.'.' : '');
     my $rel_source = $self->related_source($pre);
-    push(@$order,
-      map { "${as}.$_" }
-        (@{$rel_info->{order_by}||[]}, $rel_source->primary_columns));
+
+    if (exists $rel_info->{attrs}{accessor}
+         && $rel_info->{attrs}{accessor} eq 'multi') {
+      $self->throw_exception(
+        "Can't prefetch has_many ${pre} (join cond too complex)")
+        unless ref($rel_info->{cond}) eq 'HASH';
+      my @key = map { (/^foreign\.(.*)$/ ? ($1) : ()); }
+                    keys %{$rel_info->{cond}};
+      $collapse->{"${as_prefix}${pre}"} = \@key;
+      push(@$order, map { "${as}.$_" } (@key, @{$rel_info->{order_by}||[]}));
+    }
+
     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
       $rel_source->columns;
     #warn $alias, Dumper (\@ret);

diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index 83502cf..2466753 100644 (file)
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -304,7 +304,8 @@ sub inflate_result {
     my $pre_source = $source->related_source($pre);
     $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
       unless $pre_source;
-    if (ref $pre_val->[0] eq 'ARRAY') { # multi
+    #warn Data::Dumper::Dumper($pre_val)." ";
+    if (ref($pre_val->[0]) eq 'ARRAY') { # multi
       my @pre_objects;
       foreach my $pre_rec (@$pre_val) {
         unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}