lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use strict;
   3 use warnings;
   4
   5 use Mouse::Util qw(not_supported english_list);
   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     # check conflicting
 202     my %method_provided;
 203     my @method_conflicts;
 204     my %attr_provided;
 205     my %override_provided;
 206
 207     foreach my $role_spec (@roles) {
 208         my $role      = $role_spec->[0]->meta;
 209         my $role_name = $role->name;
 210
 211         # methods
 212         foreach my $method_name($role->get_method_list){
 213             next if $class->has_method($method_name); # manually resolved
 214
 215             my $code = do{ no strict 'refs'; \&{ $role_name . '::' . $method_name } };
 216
 217             my $c = $method_provided{$method_name};
 218
 219             if($c && $c->[0] != $code){
 220                 push @{$c}, $role;
 221                 push @method_conflicts, $c;
 222             }
 223             else{
 224                 $method_provided{$method_name} = [$code, $method_name, $role];
 225             }
 226         }
 227
 228         # attributes
 229         foreach my $attr_name($role->get_attribute_list){
 230             my $attr = $role->get_attribute($attr_name);
 231             my $c    = $attr_provided{$attr_name};
 232             if($c && $c != $attr){
 233                 $class->throw_error("We have encountered an attribute conflict with '$attr_name' "\r
 234                                    . "during composition. This is fatal error and cannot be disambiguated.")
 235             }
 236             else{
 237                 $attr_provided{$attr_name} = $attr;
 238             }
 239         }
 240
 241         # override modifiers
 242         foreach my $method_name($role->get_method_modifier_list('override')){
 243             my $override = $role->get_override_method_modifier($method_name);
 244             my $c        = $override_provided{$method_name};
 245             if($c && $c != $override){
 246                 $class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "\r
 247                                    . "composition (Two 'override' methods of the same name encountered). "\r
 248                                    . "This is fatal error.")
 249             }
 250             else{
 251                 $override_provided{$method_name} = $override;
 252             }
 253         }
 254     }
 255     if(@method_conflicts){
 256         my $error;
 257
 258         if(@method_conflicts == 1){
 259             my($code, $method_name, @roles) = @{$method_conflicts[0]};
 260             $class->throw_error(
 261                 sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
 262                     english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $class->name
 263             );
 264         }
 265         else{
 266             @method_conflicts = sort { $a->[0] cmp $b->[0] } @method_conflicts; # to avoid hash-ordering bugs
 267             my $methods = english_list(map{ sprintf q{'%s'}, $_->[1] } @method_conflicts);
 268             my $roles   = english_list(
 269                 map{ sprintf q{'%s'}, $_->name }
 270                 map{ my($code, $method_name, @roles) = @{$_}; @roles } @method_conflicts
 271             );
 272
 273             $class->throw_error(
 274                 sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
 275                     $roles, $methods, $class->name
 276             );
 277         }
 278     }
 279
 280     foreach my $role_spec (@roles) {
 281         my($role_name, $args) = @{$role_spec};
 282
 283         my $role = $role_name->meta;
 284
 285         $role->_check_required_methods($class, $args, @roles);
 286         $role->_apply_methods($class, $args);
 287         $role->_apply_attributes($class, $args);
 288         $role->_apply_modifiers($class, $args);
 289         $role->_append_roles($class, $args);
 290     }
 291     return;
 292 }
 293
 294 for my $modifier_type (qw/before after around/) {
 295
 296     my $modifier = "${modifier_type}_method_modifiers";
 297     my $add_method_modifier =  sub {
 298         my ($self, $method_name, $method) = @_;
 299
 300         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 301         return;
 302     };
 303     my $has_method_modifiers = sub{
 304         my($self, $method_name) = @_;
 305         my $m = $self->{$modifier}->{$method_name};
 306         return $m && @{$m} != 0;
 307     };
 308     my $get_method_modifiers = sub {
 309         my ($self, $method_name) = @_;
 310         return @{ $self->{$modifier}->{$method_name} ||= [] }
 311     };
 312
 313     no strict 'refs';
 314     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 315     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
 316     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 317 }
 318
 319 sub add_override_method_modifier{
 320     my($self, $method_name, $method) = @_;
 321
 322     if($self->has_method($method_name)){
 323         # This error happens in the override keyword or during role composition,
 324         # so I added a message, "A local method of ...", only for compatibility (gfx)
 325         $self->throw_error("Cannot add an override of method '$method_name' "\r
 326                    . "because there is a local version of '$method_name'"
 327                    . "(A local method of the same name as been found)");
 328     }
 329
 330     $self->{override_method_modifiers}->{$method_name} = $method;
 331 }
 332
 333 sub has_override_method_modifier {\r
 334     my ($self, $method_name) = @_;\r
 335     return exists $self->{override_method_modifiers}->{$method_name};\r
 336 }\r
 337 \r
 338 sub get_override_method_modifier {\r
 339     my ($self, $method_name) = @_;\r
 340     return $self->{override_method_modifiers}->{$method_name};\r
 341 }
 342
 343 sub get_method_modifier_list {
 344     my($self, $modifier_type) = @_;
 345
 346     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
 347 }
 348
 349 # This is currently not passing all the Moose tests.
 350 sub does_role {
 351     my ($self, $role_name) = @_;
 352
 353     (defined $role_name)
 354         || $self->throw_error("You must supply a role name to look for");
 355
 356     # if we are it,.. then return true
 357     return 1 if $role_name eq $self->name;
 358     # otherwise.. check our children
 359     for my $role (@{ $self->get_roles }) {
 360         return 1 if $role->does_role($role_name);
 361     }
 362     return 0;
 363 }
 364
 365
 366 1;
 367