lib/Moo/Role.pm

   1 package Moo::Role;
   2
   3 use strictures 1;
   4 use Moo::_Utils;
   5 use base qw(Role::Tiny);
   6
   7 BEGIN { *INFO = \%Role::Tiny::INFO }
   8
   9 our %INFO;
  10
  11 sub import {
  12   my $target = caller;
  13   strictures->import;
  14   # get symbol table reference
  15   my $stash = do { no strict 'refs'; \%{"${target}::"} };
  16   *{_getglob "${target}::has"} = sub {
  17     my ($name, %spec) = @_;
  18     ($INFO{$target}{accessor_maker} ||= do {
  19       require Method::Generate::Accessor;
  20       Method::Generate::Accessor->new
  21     })->generate_method($target, $name, \%spec);
  22     $INFO{$target}{attributes}{$name} = \%spec;
  23   };
  24   goto &Role::Tiny::import;
  25 }
  26
  27 sub apply_role_to_package {
  28   my ($me, $role, $to) = @_;
  29   $me->SUPER::apply_role_to_package($role, $to);
  30   $me->_handle_constructor($to, $INFO{$role}{attributes});
  31 }
  32
  33 sub create_class_with_roles {
  34   my ($me, $superclass, @roles) = @_;
  35
  36   my $new_name = join('+', $superclass, my $compose_name = join '+', @roles);
  37   return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
  38
  39   require Sub::Quote;
  40
  41   $me->SUPER::create_class_with_roles($superclass, @roles);
  42
  43   foreach my $role (@roles) {
  44     die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
  45   }
  46
  47   $me->_handle_constructor(
  48     $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }
  49   );
  50
  51   return $new_name;
  52 }
  53
  54 sub _install_modifiers {
  55   my ($me, $to, $modifiers) = @_;
  56   foreach my $modifier (@{$modifiers||[]}) {
  57     _install_modifier($to, @{$modifier});
  58   }
  59 }
  60
  61 sub _handle_constructor {
  62   my ($me, $to, $attr_info) = @_;
  63   return unless $attr_info && keys %$attr_info;
  64   if ($INFO{$to}) {
  65     @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
  66   } else {
  67     # only fiddle with the constructor if the target is a Moo class
  68     if ($INC{"Moo.pm"}
  69         and my $con = Moo->_constructor_maker_for($to)) {
  70       $con->register_attribute_specs(%$attr_info);
  71     }
  72   }
  73 }
  74
  75 1;