lib/Mouse/Meta/Role.pm

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