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 our %_pod_inherit_config =
  10   (
  11    class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' }
  12   );
  13
  14 sub register_relationship {
  15   my ($class, $rel, $info) = @_;
  16   if (my $proxy_list = $info->{attrs}{proxy}) {
  17     $class->proxy_to_related($rel,
  18               (ref $proxy_list ? @$proxy_list : $proxy_list));
  19   }
  20   $class->next::method($rel, $info);
  21 }
  22
  23 sub proxy_to_related {
  24   my ($class, $rel, @proxy) = @_;
  25   no strict 'refs';
  26   no warnings 'redefine';
  27   foreach my $proxy (@proxy) {
  28     my $name = join '::', $class, $proxy;
  29     *$name = Sub::Name::subname $name,
  30       sub {
  31         my $self = shift;
  32         my $val = $self->$rel;
  33         if (@_ && !defined $val) {
  34           $val = $self->create_related($rel, { $proxy => $_[0] });
  35           @_ = ();
  36         }
  37         return ($val ? $val->$proxy(@_) : undef);
  38      }
  39   }
  40 }
  41
  42 1;