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_col = $proxy_map{$meth_name};
  29     my $name = join '::', $class, $meth_name;
  30     *$name = Sub::Name::subname $name => sub {
  31       my $self = shift;
  32       my $relobj = $self->$rel;
  33       if (@_ && !defined $relobj) {
  34         $relobj = $self->create_related($rel, { $proxy_to_col => $_[0] });
  35         @_ = ();
  36       }
  37       return ($relobj ? $relobj->$proxy_to_col(@_) : undef);
  38    }
  39   }
  40 }
  41
  42 sub _build_proxy_map_from {
  43   my ( $class, $proxy_arg ) = @_;
  44   my $ref = ref $proxy_arg;
  45
  46   if ($ref eq 'HASH') {
  47     return %$proxy_arg;
  48   }
  49   elsif ($ref eq 'ARRAY') {
  50     return map {
  51       (ref $_ eq 'HASH')
  52         ? (%$_)
  53         : ($_ => $_)
  54     } @$proxy_arg;
  55   }
  56   elsif ($ref) {
  57     $class->throw_exception("Unable to process the 'proxy' argument $proxy_arg");
  58   }
  59   else {
  60     return ( $proxy_arg => $proxy_arg );
  61   }
  62 }
  63
  64 1;