Commit | Line | Data |
4a07648a |
1 | package DBIx::Class::Relationship::Accessor; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | sub add_relationship { |
7 | my ($class, $rel, @rest) = @_; |
8 | my $ret = $class->NEXT::ACTUAL::add_relationship($rel => @rest); |
9 | my $rel_obj = $class->_relationships->{$rel}; |
10 | if (my $acc_type = $rel_obj->{attrs}{accessor}) { |
223b8fe3 |
11 | $class->add_relationship_accessor($rel => $acc_type); |
4a07648a |
12 | } |
13 | return $ret; |
14 | } |
15 | |
223b8fe3 |
16 | sub add_relationship_accessor { |
4a07648a |
17 | my ($class, $rel, $acc_type) = @_; |
18 | my %meth; |
19 | if ($acc_type eq 'single') { |
20 | $meth{$rel} = sub { |
21 | my $self = shift; |
22 | if (@_) { |
23 | $self->set_from_related($rel, @_); |
24 | return $self->{_relationship_data}{$rel} = $_[0]; |
25 | } elsif (exists $self->{_relationship_data}{$rel}) { |
26 | return $self->{_relationship_data}{$rel}; |
27 | } else { |
1a14aa3f |
28 | my $val = $self->find_related($rel, {}, {}); |
b28cc0ba |
29 | return unless $val; |
30 | return $self->{_relationship_data}{$rel} = $val; |
4a07648a |
31 | } |
32 | }; |
33 | } elsif ($acc_type eq 'filter') { |
34 | $class->throw("No such column $rel to filter") |
35 | unless exists $class->_columns->{$rel}; |
36 | my $f_class = $class->_relationships->{$rel}{class}; |
37 | $class->inflate_column($rel, |
38 | { inflate => sub { |
39 | my ($val, $self) = @_; |
40 | return $self->find_or_create_related($rel, {}, {}); |
41 | }, |
42 | deflate => sub { |
43 | my ($val, $self) = @_; |
44 | $self->throw("$val isn't a $f_class") unless $val->isa($f_class); |
45 | return ($val->_ident_values)[0]; |
46 | # WARNING: probably breaks for multi-pri sometimes. FIXME |
47 | } |
48 | } |
49 | ); |
50 | } elsif ($acc_type eq 'multi') { |
51 | $meth{$rel} = sub { shift->search_related($rel, @_) }; |
52 | $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; |
53 | } else { |
54 | $class->throw("No such relationship accessor type $acc_type"); |
55 | } |
56 | { |
57 | no strict 'refs'; |
58 | no warnings 'redefine'; |
59 | foreach my $meth (keys %meth) { |
60 | *{"${class}::${meth}"} = $meth{$meth}; |
61 | } |
62 | } |
63 | } |
64 | |
65 | 1; |