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 method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
   9
  10 sub _new {
  11     my $class = shift;
  12     my %args  = @_;
  13
  14     $args{methods}          ||= {};
  15     $args{attributes}       ||= {};
  16     $args{required_methods} ||= [];
  17     $args{roles}            ||= [];
  18
  19     bless \%args, $class;
  20 }
  21
  22 sub get_roles { $_[0]->{roles} }
  23
  24 sub get_required_method_list{
  25     return @{ $_[0]->{required_methods} };
  26 }
  27
  28 sub add_required_methods {
  29     my $self = shift;
  30     my @methods = @_;
  31     push @{$self->{required_methods}}, @methods;
  32 }
  33
  34 sub requires_method {
  35     my($self, $name) = @_;
  36     return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
  37 }
  38
  39 sub add_attribute {
  40     my $self = shift;
  41     my $name = shift;
  42
  43     $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
  44 }
  45
  46 sub _check_required_methods{
  47     my($role, $class, $args, @other_roles) = @_;
  48
  49     if($class->isa('Mouse::Meta::Class')){
  50         my $class_name = $class->name;
  51         foreach my $method_name(@{$role->{required_methods}}){
  52             unless($class_name->can($method_name)){
  53                 my $role_name       = $role->name;
  54                 my $has_method      = 0;
  55
  56                 foreach my $another_role_spec(@other_roles){
  57                     my $another_role_name = $another_role_spec->[0];
  58                     if($role_name ne $another_role_name && $another_role_name->can($method_name)){
  59                         $has_method = 1;
  60                         last;
  61                     }
  62                 }
  63
  64                 $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
  65                     unless $has_method;
  66             }
  67         }
  68     }
  69
  70     return;
  71 }
  72
  73 sub _apply_methods{
  74     my($role, $class, $args) = @_;
  75
  76     my $role_name  = $role->name;
  77     my $class_name = $class->name;
  78
  79     my $alias    = (exists $args->{alias}    && !exists $args->{-alias})    ? $args->{alias}    : $args->{-alias};
  80     my $excludes = (exists $args->{excludes} && !exists $args->{-excludes}) ? $args->{excludes} : $args->{-excludes};
  81
  82     my %exclude_map;
  83
  84     if(defined $excludes){
  85         if(ref $excludes){
  86             %exclude_map = map{ $_ => undef } @{$excludes};
  87         }
  88         else{
  89             $exclude_map{$excludes} = undef;
  90         }
  91     }
  92
  93     foreach my $method_name($role->get_method_list){
  94         next if $method_name eq 'meta';
  95
  96         my $code = $role_name->can($method_name);
  97
  98         if(!exists $exclude_map{$method_name}){
  99             if(!$class->has_method($method_name)){
 100                 $class->add_method($method_name => $code);
 101             }
 102         }
 103
 104         if($alias && $alias->{$method_name}){
 105             my $dstname = $alias->{$method_name};
 106
 107             my $slot = do{ no strict 'refs'; \*{$class_name . '::' . $dstname} };
 108             if(defined(*{$slot}{CODE}) && *{$slot}{CODE} != $code){
 109                 $class->throw_error("Cannot create a method alias if a local method of the same name exists");
 110             }
 111             else{
 112                 $class->add_method($dstname => $code);
 113             }
 114         }
 115     }
 116
 117     return;
 118 }
 119
 120 sub _apply_attributes{
 121     my($role, $class, $args) = @_;
 122
 123     if ($class->isa('Mouse::Meta::Class')) {
 124         # apply role to class
 125         for my $attr_name ($role->get_attribute_list) {
 126             next if $class->has_attribute($attr_name);
 127
 128             my $spec = $role->get_attribute($attr_name);
 129
 130             my $attr_metaclass = 'Mouse::Meta::Attribute';
 131             if ( my $metaclass_name = $spec->{metaclass} ) {
 132                 $attr_metaclass = Mouse::Util::resolve_metaclass_alias(
 133                     'Attribute',
 134                     $metaclass_name
 135                 );
 136             }
 137
 138             $attr_metaclass->create($class, $attr_name => %$spec);
 139         }
 140     } else {
 141         # apply role to role
 142         for my $attr_name ($role->get_attribute_list) {
 143             next if $class->has_attribute($attr_name);
 144
 145             my $spec = $role->get_attribute($attr_name);
 146             $class->add_attribute($attr_name => $spec);
 147         }
 148     }
 149
 150     return;
 151 }
 152
 153 sub _apply_modifiers{
 154     my($role, $class, $args) = @_;
 155
 156     for my $modifier_type (qw/before after around override/) {
 157         my $add_modifier = "add_${modifier_type}_method_modifier";
 158         my $modifiers    = $role->{"${modifier_type}_method_modifiers"};
 159
 160         while(my($method_name, $modifier_codes) = each %{$modifiers}){
 161             foreach my $code(ref($modifier_codes) eq 'ARRAY' ? @{$modifier_codes} : $modifier_codes){
 162                 $class->$add_modifier($method_name => $code);
 163             }
 164         }
 165     }
 166     return;
 167 }
 168
 169 sub _append_roles{
 170     my($role, $class, $args) = @_;
 171
 172     my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
 173
 174     foreach my $r($role, @{$role->get_roles}){
 175         if(!$class->does_role($r->name)){
 176             push @{$roles}, $r;
 177         }
 178     }
 179     return;
 180 }
 181
 182 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 183 sub apply {
 184     my($self, $class, %args) = @_;
 185
 186     if ($class->isa('Mouse::Object')) {
 187         not_supported 'Application::ToInstance';
 188     }
 189
 190     $self->_check_required_methods($class, \%args);
 191     $self->_apply_methods($class, \%args);
 192     $self->_apply_attributes($class, \%args);
 193     $self->_apply_modifiers($class, \%args);
 194     $self->_append_roles($class, \%args);
 195     return;
 196 }
 197
 198 sub combine_apply {
 199     my(undef, $class, @roles) = @_;
 200
 201     foreach my $role_spec (@roles) {
 202         my($role_name, $args) = @{$role_spec};
 203
 204         my $role = $role_name->meta;
 205
 206         $role->_check_required_methods($class, $args, @roles);
 207         $role->_apply_methods($class, $args);
 208         $role->_apply_attributes($class, $args);
 209         $role->_apply_modifiers($class, $args);
 210         $role->_append_roles($class, $args);
 211     }
 212     return;
 213 }
 214
 215 for my $modifier_type (qw/before after around/) {
 216
 217     my $modifier = "${modifier_type}_method_modifiers";
 218     my $add_method_modifier =  sub {
 219         my ($self, $method_name, $method) = @_;
 220
 221         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 222         return;
 223     };
 224     my $has_method_modifiers = sub{
 225         my($self, $method_name) = @_;
 226         my $m = $self->{$modifier}->{$method_name};
 227         return $m && @{$m} != 0;
 228     };
 229     my $get_method_modifiers = sub {
 230         my ($self, $method_name) = @_;
 231         return @{ $self->{$modifier}->{$method_name} ||= [] }
 232     };
 233
 234     no strict 'refs';
 235     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 236     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
 237     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 238 }
 239
 240 sub add_override_method_modifier{
 241     my($self, $method_name, $method) = @_;
 242
 243     (!$self->has_method($method_name))\r
 244         || $self->throw_error("Cannot add an override of method '$method_name' " .\r
 245                    "because there is a local version of '$method_name'");
 246
 247     $self->{override_method_modifiers}->{$method_name} = $method;
 248 }
 249
 250 sub has_override_method_modifier {\r
 251     my ($self, $method_name) = @_;\r
 252     return exists $self->{override_method_modifiers}->{$method_name};\r
 253 }\r
 254 \r
 255 sub get_override_method_modifier {\r
 256     my ($self, $method_name) = @_;\r
 257     return $self->{override_method_modifiers}->{$method_name};\r
 258 }
 259
 260 sub get_method_modifier_list {
 261     my($self, $modifier_type) = @_;
 262
 263     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
 264 }
 265
 266 # This is currently not passing all the Moose tests.
 267 sub does_role {
 268     my ($self, $role_name) = @_;
 269
 270     (defined $role_name)
 271         || $self->throw_error("You must supply a role name to look for");
 272
 273     # if we are it,.. then return true
 274     return 1 if $role_name eq $self->name;
 275     # otherwise.. check our children
 276     for my $role (@{ $self->get_roles }) {
 277         return 1 if $role->does_role($role_name);
 278     }
 279     return 0;
 280 }
 281
 282
 283 1;
 284