lib/DBIx/Class/Relationship/ProxyMethods.pm

   1 package DBIx::Class::Relationship::ProxyMethods;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Class::Data::Inheritable/;
   7
   8 sub add_relationship {
   9   my ($class, $rel, @rest) = @_;
  10   my $ret = $class->NEXT::ACTUAL::add_relationship($rel => @rest);
  11   if (my $proxy_list = $class->_relationships->{$rel}->{attrs}{proxy}) {
  12     $class->proxy_to_related($rel,
  13               (ref $proxy_list ? @$proxy_list : $proxy_list));
  14   }
  15   return $ret;
  16 }
  17
  18 sub proxy_to_related {
  19   my ($class, $rel, @proxy) = @_;
  20   no strict 'refs';
  21   no warnings 'redefine';
  22   foreach my $proxy (@proxy) {
  23     *{"${class}::${proxy}"} =
  24       sub {
  25         my $self = shift;
  26         my $val = $self->$rel;
  27         if (@_ && !defined $val) {
  28           $val = $self->create_related($rel, { $proxy => $_[0] });
  29           @_ = ();
  30         }
  31         return ($val ? $val->$proxy(@_) : undef);
  32      }
  33   }
  34 }
  35
  36 1;