use Try::Tiny;
use List::Util 'first';
use Scalar::Util qw/weaken isweak/;
-use Storable qw/nfreeze thaw/;
use namespace::clean;
use base qw/DBIx::Class/;
my $columns_info = $source->columns_info;
Like L</column_info> but returns information for the requested columns. If
-the optional column-list arrayref is ommitted it returns info on all columns
+the optional column-list arrayref is omitted it returns info on all columns
currently defined on the ResultSource via L</add_columns>.
=cut
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;
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
}
}
-sub STORABLE_freeze { nfreeze($_[0]->handle) }
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
sub STORABLE_thaw {
my ($self, $cloning, $ice) = @_;
- %$self = %{ (thaw $ice)->resolve };
+ %$self = %{ (Storable::thaw($ice))->resolve };
}
=head2 throw_exception