Fix rev_rel_info on prototype sources

Changes

@@ -18,6 +18,8 @@ Revision history for DBIx::Class
         - Better error handling when prepare() fails silently
         - Fixes skipped lines when a comment is followed by a statement
           when deploying a schema via sql file
+        - Fix reverse_relationship_info on prototypical result sources
+          (sources not yet registered with a schema)
 
 0.08127 2011-01-19 16:40 (UTC)
     * New Features / Changes

lib/DBIx/Class/ResultSource.pm

@@ -1327,45 +1327,74 @@ L</relationship_info>.
 
 sub reverse_relationship_info {
   my ($self, $rel) = @_;
-  my $rel_info = $self->relationship_info($rel);
+
+  my $rel_info = $self->relationship_info($rel)
+    or $self->throw_exception("No such relationship '$rel'");
+
   my $ret = {};
 
   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
 
-  my @cond = keys(%{$rel_info->{cond}});
-  my @refkeys = map {/^\w+\.(\w+)$/} @cond;
-  my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+  my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
+
+  my $rsrc_schema_moniker = $self->source_name
+    if try { $self->schema };
 
-  # Get the related result source for this relationship
-  my $othertable = $self->related_source($rel);
+  # this may be a partial schema or something else equally esoteric
+  my $other_rsrc = try { $self->related_source($rel) }
+    or return $ret;
 
   # Get all the relationships for that source that related to this source
   # whose foreign column set are our self columns on $rel and whose self
-  # columns are our foreign columns on $rel.
-  my @otherrels = $othertable->relationships();
-  my $otherrelationship;
-  foreach my $otherrel (@otherrels) {
-    # this may be a partial schema with the related source not being
-    # available at all
-    my $back = try { $othertable->related_source($otherrel) } or next;
-
-    # did we get back to ourselves?
-    next unless $back->source_name eq $self->source_name;
-
-    my $otherrel_info = $othertable->relationship_info($otherrel);
-
-    next unless ref $otherrel_info->{cond} eq 'HASH';
-
-    my @other_cond = keys(%{$otherrel_info->{cond}});
-    my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
-    my @other_keys = map {$otherrel_info->{cond}{$_} =~ /^\w+\.(\w+)$/} @other_cond;
-    next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
-             !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
-    $ret->{$otherrel} =  $otherrel_info;
+  # columns are our foreign columns on $rel
+  foreach my $other_rel ($other_rsrc->relationships) {
+
+    # only consider stuff that points back to us
+    # "us" here is tricky - if we are in a schema registration, we want
+    # to use the source_names, otherwise we will use the actual classes
+
+    # the schema may be partial
+    my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+      or next;
+
+    if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+      next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
+    }
+    else {
+      next unless $self->result_class eq $roundtrip_rsrc->result_class;
+    }
+
+    my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+    # this can happen when we have a self-referential class
+    next if $other_rel_info eq $rel_info;
+
+    next unless ref $other_rel_info->{cond} eq 'HASH';
+    my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+    $ret->{$other_rel} = $other_rel_info if (
+      $self->_compare_relationship_keys (
+        [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+      )
+        and
+      $self->_compare_relationship_keys (
+        [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+      )
+    );
   }
+
   return $ret;
 }
 
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+  +{
+    map
+      { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+      keys %{$_[1]}
+  }
+}
+
 sub compare_relationship_keys {
   carp 'compare_relationship_keys is a private method, stop calling it';
   my $self = shift;
@@ -1691,7 +1720,18 @@ sub related_source {
   if( !$self->has_relationship( $rel ) ) {
     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
   }
-  return $self->schema->source($self->relationship_info($rel)->{source});
+
+  # if we are not registered with a schema - just use the prototype
+  # however if we do have a schema - ask for the source by name (and
+  # throw in the process if all fails)
+  if (my $schema = try { $self->schema }) {
+    $schema->source($self->relationship_info($rel)->{source});
+  }
+  else {
+    my $class = $self->relationship_info($rel)->{class};
+    $self->ensure_class_loaded($class);
+    $class->result_source_instance;
+  }
 }
 
 =head2 related_class

t/relationship/info.t

@@ -0,0 +1,98 @@
+use strict;
+use warnings;
+
+#
+# The test must be performed on non-registered result classes
+#
+{
+  package DBICTest::Thing;
+  use warnings;
+  use strict;
+  use base qw/DBIx::Class::Core/;
+  __PACKAGE__->table('thing');
+  __PACKAGE__->add_columns(qw/id ancestor_id/);
+  __PACKAGE__->set_primary_key('id');
+  __PACKAGE__->has_many(children => __PACKAGE__, 'id');
+  __PACKAGE__->belongs_to(parent => __PACKAGE__, 'id', { join_type => 'left' } );
+
+  __PACKAGE__->has_many(subthings => 'DBICTest::SubThing', 'thing_id');
+}
+
+{
+  package DBICTest::SubThing;
+  use warnings;
+  use strict;
+  use base qw/DBIx::Class::Core/;
+  __PACKAGE__->table('subthing');
+  __PACKAGE__->add_columns(qw/thing_id/);
+  __PACKAGE__->belongs_to(thing => 'DBICTest::Thing', 'thing_id');
+  __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } );
+}
+
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema;
+
+for my $without_schema (1,0) {
+
+  my ($t, $s) = $without_schema
+    ? (qw/DBICTest::Thing DBICTest::SubThing/)
+    : do {
+      $schema->register_class(relinfo_thing => 'DBICTest::Thing');
+      $schema->register_class(relinfo_subthing => 'DBICTest::SubThing');
+
+      map { $schema->source ($_) } qw/relinfo_thing relinfo_subthing/;
+    }
+  ;
+
+  is_deeply(
+    [ sort $t->relationships ],
+    [qw/ children parent subthings/],
+    "Correct relationships on $t",
+  );
+
+  is_deeply(
+    [ sort $s->relationships ],
+    [qw/ thing thing2 /],
+    "Correct relationships on $s",
+  );
+
+  is_deeply(
+    _instance($s)->reverse_relationship_info('thing'),
+    { subthings => $t->relationship_info('subthings') },
+    'reverse_rel_info works cross-class belongs_to direction',
+  );
+  is_deeply(
+    _instance($s)->reverse_relationship_info('thing2'),
+    { subthings => $t->relationship_info('subthings') },
+    'reverse_rel_info works cross-class belongs_to direction 2',
+  );
+
+  is_deeply(
+    _instance($t)->reverse_relationship_info('subthings'),
+    { map { $_ => $s->relationship_info($_) } qw/thing thing2/ },
+    'reverse_rel_info works cross-class has_many direction',
+  );
+
+  is_deeply(
+    _instance($t)->reverse_relationship_info('parent'),
+    { children => $t->relationship_info('children') },
+    'reverse_rel_info works in-class belongs_to direction',
+  );
+  is_deeply(
+    _instance($t)->reverse_relationship_info('children'),
+    { parent => $t->relationship_info('parent') },
+    'reverse_rel_info works in-class has_many direction',
+  );
+}
+
+sub _instance {
+  $_[0]->isa('DBIx::Class::ResultSource')
+    ? $_[0]
+    : $_[0]->result_source_instance
+}
+
+done_testing;