lib/DBIx/Class/Relationship/ProxyMethods.pm

   1 package # hide from PAUSE
   2     DBIx::Class::Relationship::ProxyMethods;
   3
   4 use strict;
   5 use warnings;
   6 use Sub::Name ();
   7 use base qw/DBIx::Class/;
   8
   9 sub register_relationship {
  10   my ($class, $rel, $info) = @_;
  11   if (my $proxy_list = $info->{attrs}{proxy}) {
  12     $class->proxy_to_related($rel,
  13               (ref $proxy_list ? @$proxy_list : $proxy_list));
  14   }
  15   $class->next::method($rel, $info);
  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     my $name = join '::', $class, $proxy;
  24     *$name = Sub::Name::subname $name,
  25       sub {
  26         my $self = shift;
  27         my $val = $self->$rel;
  28         if (@_ && !defined $val) {
  29           $val = $self->create_related($rel, { $proxy => $_[0] });
  30           @_ = ();
  31         }
  32         return ($val ? $val->$proxy(@_) : undef);
  33      }
  34   }
  35 }
  36
  37 1;