collapse result refac hopefully complete

diff --git a/lib/DBIx/Class/ResultClass/HashRefInflator.pm b/lib/DBIx/Class/ResultClass/HashRefInflator.pm
index ca6741e..9a2c8eb 100644 (file)
--- a/lib/DBIx/Class/ResultClass/HashRefInflator.pm
+++ b/lib/DBIx/Class/ResultClass/HashRefInflator.pm
@@ -63,6 +63,16 @@ sub mk_hash {
     # to avoid emtpy has_many rels contain one empty hashref
     return if (not keys %$me);
 
+    my $def;
+
+    foreach (values %$me) {
+        if (defined $_) {
+            $def = 1;
+            last;
+        }
+    }
+    return unless $def;
+
     return { %$me,
         map {
           ( $_ =>

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 9367b3c..d2cee9a 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -98,8 +98,8 @@ sub new {
   $attrs->{alias} ||= 'me';
 
   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,
@@ -782,7 +782,8 @@ sub _collapse_result {
   if (keys %collapse) {
     my %pri = map { ($_ => 1) } $self->result_source->primary_columns;
     foreach my $i (0 .. $#construct_as) {
-      if (delete $pri{$construct_as[$i]}) {
+      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!)
@@ -793,14 +794,18 @@ sub _collapse_result {
 
   my %pri_vals = map { ($_ => $copy[$_]) } @pri_index;
 
-  my %const;
+  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);
     }
 
+    push(@const_rows, \%const);
+
   } until ( # no pri_index => no collapse => drop straight out
       !@pri_index
     or
@@ -824,17 +829,49 @@ sub _collapse_result {
   # THIS BIT STILL NEEDS TO DO THE COLLAPSE
 
   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} ||= [];
+  my $info = [];
+
+  my %collapse_pos;
+
+  my @const_keys;
+
+  use Data::Dumper;
+
+  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->[0] = $const{$key};
-    } else {
-      $info->[0] = $const{$key};
     }
   }
 

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 4bb6ff6..e4d30e9 100644 (file)
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -175,7 +175,7 @@ sub add_columns {
   return $self;
 }
 
-*add_column = \&add_columns;
+sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 
 =head2 has_column
 
@@ -286,7 +286,7 @@ sub remove_columns {
   $self->_ordered_columns(\@remaining);
 }
 
-*remove_column = \&remove_columns;
+sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
 
 =head2 set_primary_key
 
@@ -874,9 +874,13 @@ sub resolve_prefetch {
       $self->throw_exception(
         "Can't prefetch has_many ${pre} (join cond too complex)")
         unless ref($rel_info->{cond}) eq 'HASH';
+      #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
+      #              values %{$rel_info->{cond}};
+      $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
+        # action at a distance. prepending the '.' allows simpler code
+        # in ResultSet->_collapse_result
       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
                     keys %{$rel_info->{cond}};
-      $collapse->{"${as_prefix}${pre}"} = \@key;
       my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
                    ? @{$rel_info->{attrs}{order_by}}
                    : (defined $rel_info->{attrs}{order_by}
@@ -1034,3 +1038,4 @@ You may distribute this code under the same terms as Perl itself.
 
 =cut
 
+1;

diff --git a/t/76joins.t b/t/76joins.t
index b172d29..57a9ffc 100644 (file)
--- a/t/76joins.t
+++ b/t/76joins.t
@@ -408,9 +408,5 @@ sub make_hash_struc {
 my $prefetch_result = make_hash_struc($art_rs_pr);
 my $nonpre_result   = make_hash_struc($art_rs);
 
-TODO: {
-  local $TODO = 'fixing collapse in -current';
 is_deeply( $prefetch_result, $nonpre_result,
     'Compare 2 level prefetch result to non-prefetch result' );
-}
-

diff --git a/t/83cache.t b/t/83cache.t
index 78113b3..63de0d3 100644 (file)
--- a/t/83cache.t
+++ b/t/83cache.t
@@ -12,7 +12,7 @@ $schema->storage->debugcb( sub{ $queries++ } );
 
 eval "use DBD::SQLite";
 plan skip_all => 'needs DBD::SQLite for testing' if $@;
-plan tests => 22;
+plan tests => 23;
 
 my $rs = $schema->resultset("Artist")->search(
   { artistid => 1 }
@@ -158,7 +158,15 @@ while( my $tag = $tags->next ) {
   push @objs, $tag->id; #warn "tag: ", $tag->ID;
 }
 
-is_deeply( \@objs, [ 2, 5, 8 ], 'second cd has correct tags' );
+is_deeply( \@objs, [ 1 ], 'second 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 ], 'third cd has correct tags' );
 
 is( $queries, 0, 'no additional SQL statements while checking nested data' );
 

diff --git a/t/90join_torture.t b/t/90join_torture.t
index d2fcd97..7c66799 100644 (file)
--- a/t/90join_torture.t
+++ b/t/90join_torture.t
@@ -13,7 +13,7 @@ my @rs1a_results = $schema->resultset("Artist")->search_related('cds', {title =>
 is($rs1a_results[0]->title, 'Forkful of bees', "bare field conditions okay after search related");
 my $rs1 = $schema->resultset("Artist")->search({ 'tags.tag' => 'Blue' }, { join => {'cds' => 'tracks'}, prefetch => {'cds' => 'tags'} });
 my @artists = $rs1->all;
-cmp_ok(@artists, '==', 1, "Two artists returned");
+cmp_ok(@artists, '==', 2, "Two artists returned");
 
 my $rs2 = $rs1->search({ artistid => '1' }, { join => {'cds' => {'cd_to_producer' => 'producer'} } });