From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 15 Nov 2013 13:14:44 +0000 (+0000)
Subject: some support for dq in rs condition merging and populate
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4e959467d9c54583edad8804d564a811ad9288d;p=dbsrgits%2FDBIx-Class.git

some support for dq in rs condition merging and populate
---

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 1e73052..071d7e8 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -2338,6 +2338,10 @@ sub populate {
           $rel,
         );
 
+        if (ref($related) eq 'REF' and ref($$related) eq 'HASH') {
+          $related = $self->_extract_fixed_values_for($$related, $rel);
+        }
+
         my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
         my @populate = map { {%$_, %$related} } @rows_to_add;
 
@@ -2347,6 +2351,42 @@ sub populate {
   }
 }
 
+sub _extract_fixed_values_for {
+  my ($self, $dq, $alias) = @_;
+  my $fixed = $self->_extract_fixed_conditions_for($dq, $alias);
+  return +{ map {
+    is_Value($fixed->{$_})
+      ? ($_ => $fixed->{$_}{value})
+      : ()
+  } keys %$fixed };
+}
+
+sub _extract_fixed_conditions_for {
+  my ($self, $dq, $alias) = @_;
+  my (@q, %found) = ($dq);
+  while (my $n = shift @q) {
+    if (is_Operator($n)) {
+      if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) {
+        my ($l, $r) = @{$n->{args}};
+        if (
+          is_Identifier($r) and @{$r->{elements}} == 2
+          and $r->{elements}[0] eq $alias
+        ) {
+          ($l, $r) = ($r, $l);
+        }
+        if (
+          is_Identifier($l) and @{$l->{elements}} == 2
+          and $l->{elements}[0] eq $alias
+        ) {
+          $found{$l->{elements}[1]} = $r;
+        } elsif (($n->{operator}{Perl}||'') eq 'and') {
+          push @q, @{$n->{args}};
+        }
+      }
+    }
+  }
+  return \%found;
+}
 
 # populate() arguments went over several incarnations
 # What we ultimately support is AoH
@@ -2516,12 +2556,7 @@ sub _merge_with_rscond {
     %new_data = %{ $self->{attrs}{related_objects} || {} };  # nothing might have been inserted yet
     @cols_from_relations = keys %new_data;
   }
-  elsif (ref $self->{cond} ne 'HASH') {
-    $self->throw_exception(
-      "Can't abstract implicit construct, resultset condition not a hash"
-    );
-  }
-  else {
+  elsif (ref $self->{cond} eq 'HASH') {
     # precedence must be given to passed values over values inherited from
     # the cond, so the order here is important.
     my $collapsed_cond = $self->_collapse_cond($self->{cond});
@@ -2543,6 +2578,14 @@ sub _merge_with_rscond {
       }
     }
   }
+  elsif (ref $self->{cond} eq 'REF' and ref ${$self->{cond}} eq 'HASH') {
+    %new_data = %{$self->_extract_fixed_values_for(${$self->{cond}}, $alias)};
+  }
+  else {
+    $self->throw_exception(
+      "Can't abstract implicit construct, resultset condition not a hash"
+    );
+  }
 
   %new_data = (
     %new_data,
diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index bad4876..e536cce 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -1498,12 +1498,42 @@ sub reverse_relationship_info {
 
 # all this does is removes the foreign/self prefix from a condition
 sub __strip_relcond {
-  return undef unless ref($_[1]) eq 'HASH';
-  +{
-    map
-      { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
-      keys %{$_[1]}
+  if (ref($_[1]) eq 'HASH') {
+    return +{
+      map
+        { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+        keys %{$_[1]}
+    };
+  } elsif (blessed($_[1]) and $_[1]->isa('Data::Query::ExprBuilder')) {
+    my (@q, %found) = ($_[1]->{expr});
+    Q: while (my $n = shift @q) {
+      if (is_Operator($n)) {
+        if (($n->{operator}{Perl}||'') =~ /^(?:==|eq)$/) {
+          my ($l, $r) = @{$n->{args}};
+          if (
+            is_Identifier($l) and @{$l->{elements}} == 2
+            and is_Identifier($r) and @{$r->{elements}} == 2
+          ) {
+            ($l, $r) = ($r, $l) if $l->{elements}[0] eq 'self';
+            if (
+              $l->{elements}[0] eq 'foreign'
+              and $r->{elements}[0] eq 'self'
+            ) {
+              $found{$l->{elements}[1]} = $r->{elements}[1];
+              next Q;
+            }
+          }
+        } elsif (($n->{operator}{Perl}||'') eq 'and') {
+          push @q, @{$n->{args}};
+          next Q;
+        }
+      }
+      # didn't match as 'and' or 'foreign.x = self.y', can't handle this
+      return undef;
+    }
+    return \%found;
   }
+  return undef;
 }
 
 sub compare_relationship_keys {
diff --git a/t/lib/DBICTest/Schema/Artist.pm b/t/lib/DBICTest/Schema/Artist.pm
index 34532dc..82423fd 100644
--- a/t/lib/DBICTest/Schema/Artist.pm
+++ b/t/lib/DBICTest/Schema/Artist.pm
@@ -6,6 +6,7 @@ use strict;
 
 use base qw/DBICTest::BaseResult/;
 use Carp qw/confess/;
+use Data::Query::ExprDeclare;
 
 __PACKAGE__->table('artist');
 __PACKAGE__->source_info({
@@ -47,7 +48,8 @@ __PACKAGE__->mk_classdata('field_name_for', {
 # the undef condition in this rel is *deliberate*
 # tests oddball legacy syntax
 __PACKAGE__->has_many(
-    cds => 'DBICTest::Schema::CD', undef,
+    cds => 'DBICTest::Schema::CD',
+    expr { $_->foreign->artist == $_->self->artistid },
     { order_by => { -asc => 'year'} },
 );