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   _install_coderef "${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   if ($INC{'Moo/HandleMoose.pm'}) {
  26     Moo::HandleMoose::inject_fake_metaclass_for($target);
  27   }
  28   goto &Role::Tiny::import;
  29 }
  30
  31 sub _inhale_if_moose {
  32   my ($self, $role) = @_;
  33   _load_module($role);
  34   if (!$INFO{$role} and $INC{"Moose.pm"}) {
  35     if (my $meta = Class::MOP::class_of($role)) {
  36       $INFO{$role}{methods} = {
  37         map +($_ => $role->can($_)), $meta->get_method_list
  38       };
  39       $Role::Tiny::APPLIED_TO{$role} = {
  40         map +($_->name => 1), $meta->calculate_all_roles
  41       };
  42       $INFO{$role}{requires} = [ $meta->get_required_method_list ];
  43       $INFO{$role}{attributes} = {
  44         map +($_ => $meta->get_attribute($_)), $meta->get_attribute_list
  45       };
  46       my $mods = $INFO{$role}{modifiers} = [];
  47       foreach my $type (qw(before after around)) {
  48         my $map = $meta->${\"get_${type}_method_modifiers_map"};
  49         foreach my $method (keys %$map) {
  50           foreach my $mod (@{$map->{$method}}) {
  51             push @$mods, [ $type => $method => $mod ];
  52           }
  53         }
  54       }
  55       require Class::Method::Modifiers if @$mods;
  56       $INFO{$role}{inhaled_from_moose} = 1;
  57     }
  58   }
  59 }
  60
  61 sub _make_accessors_if_moose {
  62   my ($self, $role, $target) = @_;
  63   if ($INFO{$role}{inhaled_from_moose}) {
  64     if (my $attrs = $INFO{$role}{attributes}) {
  65       my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
  66         require Method::Generate::Accessor;
  67         Method::Generate::Accessor->new
  68       });
  69       foreach my $name (keys %{$attrs}) {
  70         $acc_gen->generate_method($target, $name, $attrs->{$name});
  71       }
  72     }
  73   }
  74 }
  75
  76 sub apply_single_role_to_package {
  77   my ($me, $to, $role) = @_;
  78   $me->_inhale_if_moose($role);
  79   $me->_make_accessors_if_moose($role, $to);
  80   $me->SUPER::apply_single_role_to_package($to, $role);
  81   $me->_handle_constructor($to, $INFO{$role}{attributes});
  82 }
  83
  84 sub create_class_with_roles {
  85   my ($me, $superclass, @roles) = @_;
  86
  87   my $new_name = join(
  88     '__WITH__', $superclass, my $compose_name = join '__AND__', @roles
  89   );
  90
  91   return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
  92
  93   $me->_inhale_if_moose($_) for @roles;
  94
  95   require Sub::Quote;
  96
  97   $me->SUPER::create_class_with_roles($superclass, @roles);
  98
  99   foreach my $role (@roles) {
 100     die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
 101   }
 102
 103   $Moo::MAKERS{$new_name} = {};
 104
 105   $me->_handle_constructor(
 106     $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }, $superclass
 107   );
 108
 109   return $new_name;
 110 }
 111
 112 sub _composable_package_for {
 113   my ($self, $role) = @_;
 114   my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
 115   return $composed_name if $Role::Tiny::COMPOSED{role}{$composed_name};
 116   $self->_make_accessors_if_moose($role, $composed_name);
 117   $self->SUPER::_composable_package_for($role);
 118 }
 119
 120 sub _install_single_modifier {
 121   my ($me, @args) = @_;
 122   _install_modifier(@args);
 123 }
 124
 125 sub _handle_constructor {
 126   my ($me, $to, $attr_info, $superclass) = @_;
 127   return unless $attr_info && keys %$attr_info;
 128   if ($INFO{$to}) {
 129     @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
 130   } else {
 131     # only fiddle with the constructor if the target is a Moo class
 132     if ($INC{"Moo.pm"}
 133         and my $con = Moo->_constructor_maker_for($to, $superclass)) {
 134       $con->register_attribute_specs(%$attr_info);
 135     }
 136   }
 137 }
 138
 139 1;
 140
 141 =head1 NAME
 142
 143 Moo::Role - Minimal Object Orientation support for Roles
 144
 145 =head1 SYNOPSIS
 146
 147  package My::Role;
 148
 149  use Moo::Role;
 150
 151  sub foo { ... }
 152
 153  sub bar { ... }
 154
 155  has baz => (
 156    is => 'ro',
 157  );
 158
 159  1;
 160
 161 else where
 162
 163  package Some::Class;
 164
 165  use Moo;
 166
 167  # bar gets imported, but not foo
 168  with('My::Role');
 169
 170  sub foo { ... }
 171
 172  1;
 173
 174 =head1 DESCRIPTION
 175
 176 C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
 177 documentation on how this works.  The main addition here is extra bits to make
 178 the roles more "Moosey;" which is to say, it adds L</has>.
 179
 180 =head1 IMPORTED SUBROUTINES
 181
 182 See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
 183 imported by this module.
 184
 185 =head2 has
 186
 187  has attr => (
 188    is => 'ro',
 189  );
 190
 191 Declares an attribute for the class to be composed into.  See
 192 L<Moo/has> for all options.
 193
 194 =head1 AUTHORS
 195
 196 See L<Moo> for authors.
 197
 198 =head1 COPYRIGHT AND LICENSE
 199
 200 See L<Moo> for the copyright and license.
 201
 202 =cut