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