Clarification cascade_* attribute defaults documentation
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Relationship / Accessor.pm
1 package # hide from PAUSE
2     DBIx::Class::Relationship::Accessor;
3
4 use strict;
5 use warnings;
6 use Sub::Name ();
7
8 our %_pod_inherit_config = 
9   (
10    class_map => { 'DBIx::Class::Relationship::Accessor' => 'DBIx::Class::Relationship' }
11   );
12
13 sub 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
21 sub 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
81 1;