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_args = $info->{attrs}{proxy}) {
  17     $class->proxy_to_related($rel, $proxy_args);
  18   }
  19   $class->next::method($rel, $info);
  20 }
  21
  22 sub proxy_to_related {
  23   my ($class, $rel, $proxy_args) = @_;
  24   my %proxy_map = $class->_build_proxy_map_from($proxy_args);
  25   no strict 'refs';
  26   no warnings 'redefine';
  27   foreach my $meth_name ( keys %proxy_map ) {
  28     my $proxy_to = $proxy_map{$meth_name};
  29     my $name = join '::', $class, $meth_name;
  30     *$name = Sub::Name::subname $name,
  31       sub {
  32         my $self = shift;
  33         my $val = $self->$rel;
  34         if (@_ && !defined $val) {
  35           $val = $self->create_related($rel, { $proxy_to => $_[0] });
  36           @_ = ();
  37         }
  38         return ($val ? $val->$proxy_to(@_) : undef);
  39      }
  40   }
  41 }
  42
  43 sub _build_proxy_map_from {
  44   my ( $class, $proxy_arg ) = @_;
  45   my $ref = ref $proxy_arg;
  46
  47   if ($ref eq 'HASH') {
  48     return %$proxy_arg;
  49   }
  50   elsif ($ref eq 'ARRAY') {
  51     return map {
  52       (ref $_ eq 'HASH')
  53         ? (%$_)
  54         : ($_ => $_)
  55     } @$proxy_arg;
  56   }
  57   elsif ($ref) {
  58     $class->throw_exception("Unable to process the 'proxy' argument $proxy_arg");
  59   }
  60   else {
  61     return ( $proxy_arg => $proxy_arg );
  62   }
  63 }
  64
  65 1;