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;