1package # hide from PAUSE
2    DBIx::Class::Relationship::Accessor;
3
4use strict;
5use warnings;
6use Sub::Name ();
7
8our %_pod_inherit_config =
9  (
10   class_map => { 'DBIx::Class::Relationship::Accessor' => 'DBIx::Class::Relationship' }
11  );
12
13sub register_relationship {
14  my ($class, $rel, $info) = @_;
15  if (my $acc_type = $info->{attrs}{accessor}) {
16    $class->add_relationship_accessor($rel => $acc_type);
17  }
18  $class->next::method($rel => $info);
19}
20
21sub add_relationship_accessor {
22  my ($class, $rel, $acc_type) = @_;
23  my %meth;
24  if ($acc_type eq 'single') {
25    my $rel_info = $class->relationship_info($rel);
26    $meth{$rel} = sub {
27      my $self = shift;
28      if (@_) {
29        $self->set_from_related($rel, @_);
30        return $self->{_relationship_data}{$rel} = $_[0];
31      } elsif (exists $self->{_relationship_data}{$rel}) {
32        return $self->{_relationship_data}{$rel};
33      } else {
34        my $cond = $self->result_source->_resolve_condition(
35          $rel_info->{cond}, $rel, $self
36        );
37        if ($rel_info->{attrs}->{undef_on_null_fk}){
38          return undef unless ref($cond) eq 'HASH';
39          return undef if grep { not defined $_ } values %$cond;
40        }
41        my $val = $self->find_related($rel, {}, {});
42        return $val unless $val;  # $val instead of undef so that null-objects can go through
43
44        return $self->{_relationship_data}{$rel} = $val;
45      }
46    };
47  } elsif ($acc_type eq 'filter') {
48    $class->throw_exception("No such column $rel to filter")
49       unless $class->has_column($rel);
50    my $f_class = $class->relationship_info($rel)->{class};
51    $class->inflate_column($rel,
52      { inflate => sub {
53          my ($val, $self) = @_;
54          return $self->find_or_new_related($rel, {}, {});
55        },
56        deflate => sub {
57          my ($val, $self) = @_;
58          $self->throw_exception("$val isn't a $f_class") unless $val->isa($f_class);
59          return ($val->_ident_values)[0];
60            # WARNING: probably breaks for multi-pri sometimes. FIXME
61        }
62      }
63    );
64  } elsif ($acc_type eq 'multi') {
65    $meth{$rel} = sub { shift->search_related($rel, @_) };
66    $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) };
67    $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); };
68  } else {
69    $class->throw_exception("No such relationship accessor type $acc_type");
70  }
71  {
72    no strict 'refs';
73    no warnings 'redefine';
74    foreach my $meth (keys %meth) {
75      my $name = join '::', $class, $meth;
76      *$name = Sub::Name::subname($name, $meth{$meth});
77    }
78  }
79}
80
811;
82