lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use strict;
   3 use warnings;
   4
   5 use Mouse::Util qw(not_supported);
   6 use base qw(Mouse::Meta::Module);
   7
   8 sub _new {
   9     my $class = shift;
  10     my %args  = @_;
  11
  12     $args{methods}          ||= {};
  13     $args{attributes}       ||= {};
  14     $args{required_methods} ||= [];
  15     $args{roles}            ||= [];
  16
  17     bless \%args, $class;
  18 }
  19
  20 sub get_roles { $_[0]->{roles} }
  21
  22
  23 sub add_required_methods {
  24     my $self = shift;
  25     my @methods = @_;
  26     push @{$self->{required_methods}}, @methods;
  27 }
  28
  29 sub add_attribute {
  30     my $self = shift;
  31     my $name = shift;
  32     my $spec = shift;
  33     $self->{attributes}->{$name} = $spec;
  34 }
  35
  36 sub _check_required_methods{
  37     my($role, $class, $args, @other_roles) = @_;
  38
  39     if($class->isa('Mouse::Meta::Class')){
  40         my $class_name = $class->name;
  41         foreach my $method_name(@{$role->{required_methods}}){
  42             unless($class_name->can($method_name)){
  43                 my $role_name       = $role->name;
  44                 my $has_method      = 0;
  45
  46                 foreach my $another_role_spec(@other_roles){
  47                     my $another_role_name = $another_role_spec->[0];
  48                     if($role_name ne $another_role_name && $another_role_name->can($method_name)){
  49                         $has_method = 1;
  50                         last;
  51                     }
  52                 }
  53
  54                 $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
  55                     unless $has_method;
  56             }
  57         }
  58     }
  59
  60     return;
  61 }
  62
  63 sub _apply_methods{
  64     my($role, $class, $args) = @_;
  65
  66     my $role_name  = $role->name;
  67     my $class_name = $class->name;
  68     my $alias      = $args->{alias};
  69
  70     foreach my $method_name($role->get_method_list){
  71         next if $method_name eq 'meta';
  72
  73         my $code = $role_name->can($method_name);
  74         if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){
  75             # XXX what's Moose's behavior?
  76         }
  77         else{
  78             $class->add_method($method_name => $code);
  79         }
  80
  81         if($alias && $alias->{$method_name}){
  82             my $dstname = $alias->{$method_name};
  83             if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){
  84                 # XXX wat's Moose's behavior?
  85             }
  86             else{
  87                 $class->add_method($dstname => $code);
  88             }
  89         }
  90     }
  91
  92     return;
  93 }
  94
  95 sub _apply_attributes{
  96     my($role, $class, $args) = @_;
  97
  98     if ($class->isa('Mouse::Meta::Class')) {
  99         # apply role to class
 100         for my $attr_name ($role->get_attribute_list) {
 101             next if $class->has_attribute($attr_name);
 102
 103             my $spec = $role->get_attribute($attr_name);
 104
 105             my $attr_metaclass = 'Mouse::Meta::Attribute';
 106             if ( my $metaclass_name = $spec->{metaclass} ) {
 107                 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
 108                     'Attribute',
 109                     $metaclass_name
 110                 );
 111             }
 112
 113             $attr_metaclass->create($class, $attr_name => %$spec);
 114         }
 115     } else {
 116         # apply role to role
 117         for my $attr_name ($role->get_attribute_list) {
 118             next if $class->has_attribute($attr_name);
 119
 120             my $spec = $role->get_attribute($attr_name);
 121             $class->add_attribute($attr_name => $spec);
 122         }
 123     }
 124
 125     return;
 126 }
 127
 128 sub _apply_modifiers{
 129     my($role, $class, $args) = @_;
 130
 131     for my $modifier_type (qw/before after around override/) {
 132         my $add_modifier = "add_${modifier_type}_method_modifier";
 133         my $modifiers    = $role->{"${modifier_type}_method_modifiers"};
 134
 135         while(my($method_name, $modifier_codes) = each %{$modifiers}){
 136             foreach my $code(@{$modifier_codes}){
 137                 $class->$add_modifier($method_name => $code);
 138             }
 139         }
 140     }
 141     return;
 142 }
 143
 144 sub _append_roles{
 145     my($role, $class, $args) = @_;
 146
 147     my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
 148
 149     foreach my $r($role, @{$role->get_roles}){
 150         if(!$class->does_role($r->name)){
 151             push @{$roles}, $r;
 152         }
 153     }
 154     return;
 155 }
 156
 157 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 158 sub apply {
 159     my($self, $class, %args) = @_;
 160
 161     if ($class->isa('Mouse::Object')) {
 162         not_supported 'Application::ToInstance';
 163     }
 164
 165     $self->_check_required_methods($class, \%args);
 166     $self->_apply_methods($class, \%args);
 167     $self->_apply_attributes($class, \%args);
 168     $self->_apply_modifiers($class, \%args);
 169     $self->_append_roles($class, \%args);
 170     return;
 171 }
 172
 173 sub combine_apply {
 174     my(undef, $class, @roles) = @_;
 175
 176     foreach my $role_spec (@roles) {
 177         my($role_name, $args) = @{$role_spec};
 178
 179         my $role = $role_name->meta;
 180
 181         $role->_check_required_methods($class, $args, @roles);
 182         $role->_apply_methods($class, $args);
 183         $role->_apply_attributes($class, $args);
 184         $role->_apply_modifiers($class, $args);
 185         $role->_append_roles($class, $args);
 186     }
 187     return;
 188 }
 189
 190 for my $modifier_type (qw/before after around override/) {
 191
 192     my $modifier = "${modifier_type}_method_modifiers";
 193     my $add_method_modifier =  sub {
 194         my ($self, $method_name, $method) = @_;
 195
 196         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 197         return;
 198     };
 199     my $has_method_modifiers = sub{
 200         my($self, $method_name) = @_;
 201         my $m = $self->{$modifier}->{$method_name};
 202         return $m && @{$m} != 0;
 203     };
 204     my $get_method_modifiers = sub {
 205         my ($self, $method_name) = @_;
 206         return @{ $self->{$modifier}->{$method_name} ||= [] }
 207     };
 208
 209     no strict 'refs';
 210     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 211     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
 212     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 213 }
 214
 215 # This is currently not passing all the Moose tests.
 216 sub does_role {
 217     my ($self, $role_name) = @_;
 218
 219     (defined $role_name)
 220         || $self->throw_error("You must supply a role name to look for");
 221
 222     # if we are it,.. then return true
 223     return 1 if $role_name eq $self->name;
 224     # otherwise.. check our children
 225     for my $role (@{ $self->get_roles }) {
 226         return 1 if $role->does_role($role_name);
 227     }
 228     return 0;
 229 }
 230
 231
 232 1;
 233