lib/Mouse/Meta/Role.pm

   1 package Mouse::Meta::Role;
   2 use Mouse::Util qw(:meta not_supported english_list); # enables strict and warnings
   3
   4 use Mouse::Meta::Module;
   5 our @ISA = qw(Mouse::Meta::Module);
   6
   7 sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
   8
   9 sub _construct_meta {
  10     my $class = shift;
  11
  12     my %args  = @_;
  13
  14     $args{methods}          ||= {};
  15     $args{attributes}       ||= {};
  16     $args{required_methods} ||= [];
  17     $args{roles}            ||= [];
  18
  19     my $self = bless \%args, ref($class) || $class;
  20     if($class ne __PACKAGE__){
  21         $self->meta->_initialize_object($self, \%args);
  22     }
  23
  24     return $self;
  25 }
  26
  27 sub create_anon_role{
  28     my $self = shift;
  29     return $self->create(undef, @_);
  30 }
  31
  32 sub is_anon_role{
  33     return exists $_[0]->{anon_serial_id};
  34 }
  35
  36 sub get_roles { $_[0]->{roles} }
  37
  38 sub get_required_method_list{
  39     return @{ $_[0]->{required_methods} };
  40 }
  41
  42 sub add_required_methods {
  43     my($self, @methods) = @_;
  44     push @{$self->{required_methods}}, @methods;
  45 }
  46
  47 sub requires_method {
  48     my($self, $name) = @_;
  49     return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
  50 }
  51
  52 sub add_attribute {
  53     my $self = shift;
  54     my $name = shift;
  55
  56     $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
  57 }
  58
  59 sub _canonicalize_apply_args{
  60     my($self, $applicant, %args) = @_;
  61
  62     if($applicant->isa('Mouse::Meta::Class')){ # Application::ToClass
  63         $args{_to} = 'class';
  64     }
  65     elsif($applicant->isa('Mouse::Meta::Role')){ # Application::ToRole
  66         $args{_to} = 'role';
  67     }
  68     else{ # Appplication::ToInstance
  69         $args{_to} = 'class';
  70
  71         my $metaclass = $applicant->meta->create_anon_class(
  72             superclasses => [ref $applicant],
  73             cache        => 1,
  74         );
  75         bless $applicant, $metaclass->name; # rebless
  76
  77         $applicant = $metaclass;
  78     }
  79
  80     if($args{alias} && !exists $args{-alias}){
  81         $args{-alias} = $args{alias};
  82     }
  83     if($args{excludes} && !exists $args{-excludes}){
  84         $args{-excludes} = $args{excludes};
  85     }
  86
  87     if(my $excludes = $args{-excludes}){
  88         $args{-excludes} = {}; # replace with a hash ref
  89         if(ref $excludes){
  90             %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
  91         }
  92         else{
  93             $args{-excludes}{$excludes} = undef;
  94         }
  95     }
  96
  97     return( $applicant, \%args );
  98 }
  99
 100 sub _check_required_methods{
 101     my($role, $class, $args, @other_roles) = @_;
 102
 103     if($args->{_to} eq 'class'){
 104         my $class_name = $class->name;
 105         my $role_name  = $role->name;
 106         my @missing;
 107         foreach my $method_name(@{$role->{required_methods}}){
 108             if(!$class_name->can($method_name)){
 109                 my $has_method      = 0;
 110
 111                 foreach my $another_role_spec(@other_roles){
 112                     my $another_role_name = $another_role_spec->[0];
 113                     if($role_name ne $another_role_name && $another_role_name->can($method_name)){
 114                         $has_method = 1;
 115                         last;
 116                     }
 117                 }
 118
 119                 push @missing, $method_name if !$has_method;
 120             }
 121         }
 122         if(@missing){
 123             $class->throw_error("'$role_name' requires the "
 124                 . (@missing == 1 ? 'method' : 'methods')
 125                 . " "
 126                 . english_list(map{ sprintf q{'%s'}, $_ } @missing)
 127                 . " to be implemented by '$class_name'");
 128         }
 129     }
 130     else {
 131         # apply role($role) to role($class)
 132         foreach my $method_name($role->get_required_method_list){
 133             next if $class->has_method($method_name); # already has it
 134             $class->add_required_methods($method_name);
 135         }
 136     }
 137
 138     return;
 139 }
 140
 141 sub _apply_methods{
 142     my($role, $class, $args) = @_;
 143
 144     my $role_name  = $role->name;
 145     my $class_name = $class->name;
 146
 147     my $alias    = $args->{-alias};
 148     my $excludes = $args->{-excludes};
 149
 150     foreach my $method_name($role->get_method_list){
 151         next if $method_name eq 'meta';
 152
 153         my $code = $role_name->can($method_name);
 154
 155         if(!exists $excludes->{$method_name}){
 156             if(!$class->has_method($method_name)){
 157                 $class->add_method($method_name => $code);
 158             }
 159         }
 160
 161         if($alias && $alias->{$method_name}){
 162             my $dstname = $alias->{$method_name};
 163
 164             my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} };
 165
 166             if(defined($dstcode) && $dstcode != $code){
 167                 $class->throw_error("Cannot create a method alias if a local method of the same name exists");
 168             }
 169             else{
 170                 $class->add_method($dstname => $code);
 171             }
 172         }
 173     }
 174
 175     return;
 176 }
 177
 178 sub _apply_attributes{
 179     my($role, $class, $args) = @_;
 180
 181     if ($args->{_to} eq 'class') {
 182         # apply role to class
 183         for my $attr_name ($role->get_attribute_list) {
 184             next if $class->has_attribute($attr_name);
 185
 186             my $spec = $role->get_attribute($attr_name);
 187
 188             $class->add_attribute($attr_name => %{$spec});
 189         }
 190     }
 191     else {
 192         # apply role to role
 193         for my $attr_name ($role->get_attribute_list) {
 194             next if $class->has_attribute($attr_name);
 195
 196             my $spec = $role->get_attribute($attr_name);
 197             $class->add_attribute($attr_name => $spec);
 198         }
 199     }
 200
 201     return;
 202 }
 203
 204 sub _apply_modifiers{
 205     my($role, $class, $args) = @_;
 206
 207     for my $modifier_type (qw/override before around after/) {
 208         my $add_modifier = "add_${modifier_type}_method_modifier";
 209         my $modifiers    = $role->{"${modifier_type}_method_modifiers"};
 210
 211         while(my($method_name, $modifier_codes) = each %{$modifiers}){
 212             foreach my $code(ref($modifier_codes) eq 'ARRAY' ? @{$modifier_codes} : $modifier_codes){
 213                 $class->$add_modifier($method_name => $code);
 214             }
 215         }
 216     }
 217     return;
 218 }
 219
 220 sub _append_roles{
 221     my($role, $class, $args) = @_;
 222
 223     my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles;
 224
 225     foreach my $r($role, @{$role->get_roles}){
 226         if(!$class->does_role($r->name)){
 227             push @{$roles}, $r;
 228         }
 229     }
 230     return;
 231 }
 232
 233 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 234 sub apply {
 235     my $self      = shift;
 236     my $applicant = shift;
 237     my $args;
 238
 239     ($applicant, $args) = $self->_canonicalize_apply_args($applicant, @_);
 240
 241     $self->_check_required_methods($applicant, $args);
 242     $self->_apply_methods($applicant, $args);
 243     $self->_apply_attributes($applicant, $args);
 244     $self->_apply_modifiers($applicant, $args);
 245     $self->_append_roles($applicant, $args);
 246     return;
 247 }
 248
 249 sub combine_apply {
 250     my($role_class, $applicant, @roles) = @_;
 251
 252     ($applicant) = $role_class->_canonicalize_apply_args($applicant);
 253
 254     # check conflicting
 255     my %method_provided;
 256     my @method_conflicts;
 257     my %attr_provided;
 258     my %override_provided;
 259
 260     foreach my $role_spec (@roles) {
 261         my $role      = $role_spec->[0]->meta;
 262         my $role_name = $role->name;
 263
 264         # methods
 265         foreach my $method_name($role->get_method_list){
 266             next if $applicant->has_method($method_name); # manually resolved
 267
 268             my $code = do{ no strict 'refs'; \&{ $role_name . '::' . $method_name } };
 269
 270             my $c = $method_provided{$method_name};
 271
 272             if($c && $c->[0] != $code){
 273                 push @{$c}, $role;
 274                 push @method_conflicts, $c;
 275             }
 276             else{
 277                 $method_provided{$method_name} = [$code, $method_name, $role];
 278             }
 279         }
 280
 281         # attributes
 282         foreach my $attr_name($role->get_attribute_list){
 283             my $attr = $role->get_attribute($attr_name);
 284             my $c    = $attr_provided{$attr_name};
 285             if($c && $c != $attr){
 286                 $role_class->throw_error("We have encountered an attribute conflict with '$attr_name' "
 287                                    . "during composition. This is fatal error and cannot be disambiguated.")
 288             }
 289             else{
 290                 $attr_provided{$attr_name} = $attr;
 291             }
 292         }
 293
 294         # override modifiers
 295         foreach my $method_name($role->get_method_modifier_list('override')){
 296             my $override = $role->get_override_method_modifier($method_name);
 297             my $c        = $override_provided{$method_name};
 298             if($c && $c != $override){
 299                 $role_class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
 300                                    . "composition (Two 'override' methods of the same name encountered). "
 301                                    . "This is fatal error.")
 302             }
 303             else{
 304                 $override_provided{$method_name} = $override;
 305             }
 306         }
 307     }
 308     if(@method_conflicts){
 309         my $error;
 310
 311         if(@method_conflicts == 1){
 312             my($code, $method_name, @roles) = @{$method_conflicts[0]};
 313             $role_class->throw_error(
 314                 sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
 315                     english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $applicant->name
 316             );
 317         }
 318         else{
 319             @method_conflicts = sort { $a->[0] cmp $b->[0] } @method_conflicts; # to avoid hash-ordering bugs
 320             my $methods = english_list(map{ sprintf q{'%s'}, $_->[1] } @method_conflicts);
 321             my $roles   = english_list(
 322                 map{ sprintf q{'%s'}, $_->name }
 323                 map{ my($code, $method_name, @roles) = @{$_}; @roles } @method_conflicts
 324             );
 325
 326             $role_class->throw_error(
 327                 sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
 328                     $roles, $methods, $applicant->name
 329             );
 330         }
 331     }
 332
 333     foreach my $role_spec (@roles) {
 334         my($role_name, $args) = @{$role_spec};
 335
 336         my $role = $role_name->meta;
 337
 338         ($applicant, $args) = $role->_canonicalize_apply_args($applicant, %{$args});
 339
 340         $role->_check_required_methods($applicant, $args, @roles);
 341         $role->_apply_methods($applicant, $args);
 342         $role->_apply_attributes($applicant, $args);
 343         $role->_apply_modifiers($applicant, $args);
 344         $role->_append_roles($applicant, $args);
 345     }
 346     return;
 347 }
 348
 349 for my $modifier_type (qw/before after around/) {
 350
 351     my $modifier = "${modifier_type}_method_modifiers";
 352     my $add_method_modifier =  sub {
 353         my ($self, $method_name, $method) = @_;
 354
 355         push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
 356         return;
 357     };
 358     my $has_method_modifiers = sub{
 359         my($self, $method_name) = @_;
 360         my $m = $self->{$modifier}->{$method_name};
 361         return $m && @{$m} != 0;
 362     };
 363     my $get_method_modifiers = sub {
 364         my ($self, $method_name) = @_;
 365         return @{ $self->{$modifier}->{$method_name} ||= [] }
 366     };
 367
 368     no strict 'refs';
 369     *{ 'add_' . $modifier_type . '_method_modifier'  } = $add_method_modifier;
 370     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
 371     *{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
 372 }
 373
 374 sub add_override_method_modifier{
 375     my($self, $method_name, $method) = @_;
 376
 377     if($self->has_method($method_name)){
 378         # This error happens in the override keyword or during role composition,
 379         # so I added a message, "A local method of ...", only for compatibility (gfx)
 380         $self->throw_error("Cannot add an override of method '$method_name' "
 381                    . "because there is a local version of '$method_name'"
 382                    . "(A local method of the same name as been found)");
 383     }
 384
 385     $self->{override_method_modifiers}->{$method_name} = $method;
 386 }
 387
 388 sub has_override_method_modifier {
 389     my ($self, $method_name) = @_;
 390     return exists $self->{override_method_modifiers}->{$method_name};
 391 }
 392
 393 sub get_override_method_modifier {
 394     my ($self, $method_name) = @_;
 395     return $self->{override_method_modifiers}->{$method_name};
 396 }
 397
 398 sub get_method_modifier_list {
 399     my($self, $modifier_type) = @_;
 400
 401     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
 402 }
 403
 404 # This is currently not passing all the Moose tests.
 405 sub does_role {
 406     my ($self, $role_name) = @_;
 407
 408     (defined $role_name)
 409         || $self->throw_error("You must supply a role name to look for");
 410
 411     # if we are it,.. then return true
 412     return 1 if $role_name eq $self->name;
 413     # otherwise.. check our children
 414     for my $role (@{ $self->get_roles }) {
 415         return 1 if $role->does_role($role_name);
 416     }
 417     return 0;
 418 }
 419
 420
 421 1;
 422
 423 __END__
 424
 425 =head1 NAME
 426
 427 Mouse::Meta::Role - The Mouse Role metaclass
 428
 429 =head1 SEE ALSO
 430
 431 L<Moose::Meta::Role>
 432
 433 =cut