From: Peter Rabbitson Date: Tue, 15 Feb 2011 11:36:35 +0000 (+0100) Subject: Fix rev_rel_info on prototype sources X-Git-Tag: v0.08191~81 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1e0daa970a7d91ad1e9d6fd3c80a85760ca69327;p=dbsrgits%2FDBIx-Class.git Fix rev_rel_info on prototype sources --- diff --git a/Changes b/Changes index d21fa4b..079159b 100644 --- a/Changes +++ b/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 diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index ec516f5..a8c2e85 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1327,45 +1327,74 @@ L. 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 diff --git a/t/relationship/info.t b/t/relationship/info.t new file mode 100644 index 0000000..00e5cb4 --- /dev/null +++ b/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;