lib/DBIx/Class/Relationship/ProxyMethods.pm

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