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