view release on metacpan or  search on metacpan

lib/DBIO/Relationship/Base.pm  view on Meta::CPAN

package DBIO::Relationship::Base;
# ABSTRACT: Inter-table relationships

use strict;
use warnings;

use base qw/DBIO::Base/;

use Scalar::Util qw/weaken blessed/;
use Try::Tiny;
use DBIO::Util 'UNRESOLVABLE_CONDITION';
use namespace::clean;


sub register_relationship { }


sub related_resultset {
  my $self = shift;

  $self->throw_exception("Can't call *_related as class methods")
    unless ref $self;

  my $rel = shift;

  return $self->{related_resultsets}{$rel}
    if defined $self->{related_resultsets}{$rel};

  return $self->{related_resultsets}{$rel} = do {

    my $rsrc = $self->result_source;

    my $rel_info = $rsrc->relationship_info($rel)
      or $self->throw_exception( "No such relationship '$rel'" );

    my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
    $attrs = { %{$rel_info->{attrs} || {}}, %$attrs };

    $self->throw_exception( "Invalid query: @_" )
      if (@_ > 1 && (@_ % 2 == 1));
    my $query = ((@_ > 1) ? {@_} : shift);

    # condition resolution may fail if an incomplete master-object prefetch
    # is encountered - that is ok during prefetch construction (not yet in_storage)
    my ($cond, $is_crosstable) = try {
      $rsrc->_resolve_condition( $rel_info->{cond}, $rel, $self, $rel )
    }
    catch {
      $self->throw_exception ($_) if $self->in_storage;
      UNRESOLVABLE_CONDITION;  # RV, no return()
    };

    # keep in mind that the following if() block is part of a do{} - no return()s!!!
    if ($is_crosstable and ref $rel_info->{cond} eq 'CODE') {

      # A WHOREIFFIC hack to reinvoke the entire condition resolution
      # with the correct alias. Another way of doing this involves a
      # lot of state passing around, and the @_ positions are already
      # mapped out, making this crap a less icky option.
      #
      # The point of this exercise is to retain the spirit of the original
      # $obj->search_related($rel) where the resulting rset will have the
      # root alias as 'me', instead of $rel (as opposed to invoking
      # $rs->search_related)

      # make the fake 'me' rel
      local $rsrc->{_relationships}{me} = {
        %{ $rsrc->{_relationships}{$rel} },
        _original_name => $rel,
      };

      my $obj_table_alias = lc($rsrc->source_name) . '__row';
      $obj_table_alias =~ s/\W+/_/g;

      $rsrc->resultset->search(
        $self->ident_condition($obj_table_alias),
        { alias => $obj_table_alias },
      )->search_related('me', $query, $attrs)
    }
    else {
      # FIXME - this conditional doesn't seem correct - got to figure out
      # at some point what it does. Also the entire UNRESOLVABLE_CONDITION
      # business seems shady - we could simply not query *at all*
      if ($cond eq UNRESOLVABLE_CONDITION) {
        my $reverse = $rsrc->reverse_relationship_info($rel);
        foreach my $rev_rel (keys %$reverse) {
          if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
            weaken($attrs->{related_objects}{$rev_rel}[0] = $self);
          } else {
            weaken($attrs->{related_objects}{$rev_rel} = $self);
          }
        }
      }
      elsif (ref $cond eq 'ARRAY') {
        $cond = [ map {
          if (ref $_ eq 'HASH') {
            my $hash;
            foreach my $key (keys %$_) {
              my $newkey = $key !~ /\./ ? "me.$key" : $key;
              $hash->{$newkey} = $_->{$key};
            }
            $hash;
          } else {
            $_;
          }
        } @$cond ];
      }
      elsif (ref $cond eq 'HASH') {
       foreach my $key (grep { ! /\./ } keys %$cond) {
          $cond->{"me.$key"} = delete $cond->{$key};
        }
      }

      $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
      $rsrc->related_source($rel)->resultset->search(
        $query, $attrs
      );
    }
  };
}


sub search_related {
  return shift->related_resultset(shift)->search(@_);
}


sub search_related_rs {
  return shift->related_resultset(shift)->search_rs(@_);
}


sub count_related {
  shift->search_related(@_)->count;
}


sub new_related {
  my ($self, $rel, $data) = @_;

  return $self->search_related($rel)->new_result( $self->result_source->_resolve_relationship_condition (
    infer_values_based_on => $data,
    rel_name => $rel,
    self_result_object => $self,
    foreign_alias => $rel,
    self_alias => 'me',
  )->{inferred_values} );
}