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