Back out constructor/prefetch rewrite introduced mainly by 43245ada4a

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 818341b..8bf7d67 100644 (file)
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -3,8 +3,6 @@ package DBIx::Class::ResultSource;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/;
-
 use DBIx::Class::ResultSet;
 use DBIx::Class::ResultSourceHandle;
 
@@ -14,9 +12,10 @@ use Devel::GlobalDestruction;
 use Try::Tiny;
 use List::Util 'first';
 use Scalar::Util qw/blessed weaken isweak/;
-
 use namespace::clean;
 
+use base qw/DBIx::Class/;
+
 __PACKAGE__->mk_group_accessors(simple => qw/
   source_name name source_info
   _ordered_columns _columns _primaries _unique_constraints
@@ -1545,8 +1544,8 @@ sub _resolve_join {
                 ,
                -join_path => [@$jpath, { $join => $as } ],
                -is_single => (
-                  (! $rel_info->{attrs}{accessor})
-                    or
+                  $rel_info->{attrs}{accessor}
+                    &&
                   first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
                 ),
                -alias => $as,
@@ -1747,6 +1746,113 @@ sub _resolve_condition {
   }
 }
 
+# Accepts one or more relationships for the current source and returns an
+# array of column names for each of those relationships. Column names are
+# prefixed relative to the current source, in accordance with where they appear
+# in the supplied relationships.
+sub _resolve_prefetch {
+  my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
+  $pref_path ||= [];
+
+  if (not defined $pre or not length $pre) {
+    return ();
+  }
+  elsif( ref $pre eq 'ARRAY' ) {
+    return
+      map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
+        @$pre;
+  }
+  elsif( ref $pre eq 'HASH' ) {
+    my @ret =
+    map {
+      $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
+      $self->related_source($_)->_resolve_prefetch(
+               $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
+    } keys %$pre;
+    return @ret;
+  }
+  elsif( ref $pre ) {
+    $self->throw_exception(
+      "don't know how to resolve prefetch reftype ".ref($pre));
+  }
+  else {
+    my $p = $alias_map;
+    $p = $p->{$_} for (@$pref_path, $pre);
+
+    $self->throw_exception (
+      "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
+      . join (' -> ', @$pref_path, $pre)
+    ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
+
+    my $as = shift @{$p->{-join_aliases}};
+
+    my $rel_info = $self->relationship_info( $pre );
+    $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
+      unless $rel_info;
+    my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
+    my $rel_source = $self->related_source($pre);
+
+    if ($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 $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
+
+      if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
+                         keys %{$collapse}) {
+        my ($last) = ($fail =~ /([^\.]+)$/);
+        carp (
+          "Prefetching multiple has_many rels ${last} and ${pre} "
+          .(length($as_prefix)
+            ? "at the same level (${as_prefix}) "
+            : "at top level "
+          )
+          . 'will explode the number of row objects retrievable via ->next or ->all. '
+          . 'Use at your own risk.'
+        );
+      }
+
+      #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
+      #              values %{$rel_info->{cond}};
+      $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
+        # action at a distance. prepending the '.' allows simpler code
+        # in ResultSet->_collapse_result
+      my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
+                    keys %{$rel_info->{cond}};
+      push @$order, map { "${as}.$_" } @key;
+
+      if (my $rel_order = $rel_info->{attrs}{order_by}) {
+        # this is kludgy and incomplete, I am well aware
+        # but the parent method is going away entirely anyway
+        # so sod it
+        my $sql_maker = $self->storage->sql_maker;
+        my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
+        my $sep = $sql_maker->name_sep;
+
+        # install our own quoter, so we can catch unqualified stuff
+        local $sql_maker->{quote_char} = ["\x00", "\xFF"];
+
+        my $quoted_prefix = "\x00${as}\xFF";
+
+        for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
+          my @bind;
+          ($chunk, @bind) = @$chunk if ref $chunk;
+
+          $chunk = "${quoted_prefix}${sep}${chunk}"
+            unless $chunk =~ /\Q$sep/;
+
+          $chunk =~ s/\x00/$orig_ql/g;
+          $chunk =~ s/\xFF/$orig_qr/g;
+          push @$order, \[$chunk, @bind];
+        }
+      }
+    }
+
+    return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
+      $rel_source->columns;
+  }
+}
+
 =head2 related_source
 
 =over 4