view release on metacpan or  search on metacpan

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

  my %resolve = (
    rel_name => $rel,
    self_result_object => $self,
    foreign_alias => $rel,
    self_alias => 'me',
  );

  # ADR 0071: the foreign key the parent gives is inherited, the keys of $data
  # are the caller's assignment and may not contradict it
  if (ref $data eq 'HASH' and %$data and ref( ($rsrc->relationship_info($rel) || {})->{cond} ) eq 'HASH') {
    $rsrc->related_source($rel)->_assert_scope_agrees(
      { map { ref $data->{$_} ? () : ( $_ => $data->{$_} ) } keys %$data },
      $rsrc->_resolve_relationship_condition(infer_values_based_on => {}, %resolve)->{inferred_values} || {},
    );
  }

  my $rs = $self->search_related($rel);

  # new_result reads which keys these are from the resultset (a new object)
  $rs->{_caller_keys} = [ keys %$data ] if ref $data eq 'HASH';

  return $rs->new_result( $rsrc->_resolve_relationship_condition (
    infer_values_based_on => $data,
    %resolve,
  )->{inferred_values} );
}


sub create_related {
  my $self = shift;
  my $rel = shift;
  my $obj = $self->new_related($rel, @_)->insert;
  delete $self->{related_resultsets}->{$rel};
  return $obj;
}


sub find_related {
  #my ($self, $rel, @args) = @_;
  return shift->search_related(shift)->find(@_);
}


sub find_or_new_related {
  my ($self, $rel) = (shift, shift);

  return $self->related_resultset($rel)->find_or_new(@_);
}


sub find_or_create_related {
  my ($self, $rel) = (shift, shift);

  my $obj = $self->related_resultset($rel)->find_or_create(@_);
  delete $self->{related_resultsets}{$rel};

  return $obj;
}


sub update_or_create_related {
  #my ($self, $rel, @args) = @_;
  shift->related_resultset(shift)->update_or_create(@_);
}


sub set_from_related {
  my ($self, $rel, $f_obj) = @_;

  $self->set_columns($self->_inferred_from_related($rel, $f_obj));

  return 1;
}

# The column values set_from_related sets on this row for a related object (or
# a hash of its columns, or undef): { column => value }.
sub _inferred_from_related {
  my ($self, $rel, $f_obj) = @_;

  my $inferred = $self->result_source->_resolve_relationship_condition (
    infer_values_based_on => {},
    rel_name => $rel,
    foreign_values => $f_obj,
    foreign_alias => $rel,
    self_alias => 'me',
  )->{inferred_values};

  # A plain hashref of the related row's own columns can resolve to a condition
  # that does not pin this row's columns -- e.g. a might_have searched by a
  # non-key column infers { self_pk => undef }. Applying that would clobber real
  # key columns with an undef foreign key. Refuse it rather than corrupt the row
  # (ADR 0034). A blessed related object or an explicit undef (disassociation)
  # is left to resolve as before.
  if (ref $f_obj eq 'HASH') {
    my @unresolved = sort grep { ! defined $inferred->{$_} } keys %$inferred;

    $self->throw_exception(
      "Relationship '$rel' does not resolve to a concrete column condition"
    . " (column(s) '@{[ join q{, }, @unresolved ]}' would be set to undef)"
    ) if @unresolved;
  }

  return $inferred || {};
}


sub update_from_related {
  my $self = shift;
  $self->set_from_related(@_);
  $self->update;
}


sub delete_related {
  my $self = shift;
  my $obj = $self->search_related(@_)->delete;
  delete $self->{related_resultsets}->{$_[0]};
  return $obj;
}


1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBIO::Relationship::Base - Inter-table relationships

=head1 VERSION

version 0.900005

=head1 SYNOPSIS

  __PACKAGE__->add_relationship(
    spiders => 'My::DB::Result::Creatures',
    sub {
      my $args = shift;
      return {
        "$args->{foreign_alias}.id"   => { -ident => "$args->{self_alias}.id" },
        "$args->{foreign_alias}.type" => 'arachnid'
      };
    },
  );

See F<t/relationship/dynamic_foreign_columns.t> for a runnable example.

=head1 DESCRIPTION

This class provides methods to describe the relationships between the
tables in your database model. These are the "bare bones" relationships
methods, for predefined ones, look in L<DBIO::Relationship>.

=head1 METHODS

=head2 add_relationship

=over 4

=item Arguments: $rel_name, $foreign_class, $condition, $attrs

=back