lib/Moose/Meta/Role/Application/RoleSummation.pm

   1 package Moose::Meta::Role::Application::RoleSummation;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use Scalar::Util 'blessed';
   8
   9 use Moose::Meta::Role::Composite;
  10
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Moose::Meta::Role::Application';
  14
  15 __PACKAGE__->meta->add_attribute('role_params' => (
  16     reader  => 'role_params',
  17     default => sub { {} }
  18 ));
  19
  20 sub get_exclusions_for_role {
  21     my ($self, $role) = @_;
  22     $role = $role->name if blessed $role;
  23     my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ?
  24                            '-excludes' : 'excludes';
  25     if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) {
  26         if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') {
  27             return $self->role_params->{$role}->{$excludes_key};
  28         }
  29         return [ $self->role_params->{$role}->{$excludes_key} ];
  30     }
  31     return [];
  32 }
  33
  34 sub get_method_aliases_for_role {
  35     my ($self, $role) = @_;
  36     $role = $role->name if blessed $role;
  37     my $alias_key = exists $self->role_params->{$role}->{'-alias'} ?
  38                         '-alias' : 'alias';
  39     if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) {
  40         return $self->role_params->{$role}->{$alias_key};
  41     }
  42     return {};
  43 }
  44
  45 sub is_method_excluded {
  46     my ($self, $role, $method_name) = @_;
  47     foreach ($self->get_exclusions_for_role($role->name)) {
  48         return 1 if $_ eq $method_name;
  49     }
  50     return 0;
  51 }
  52
  53 sub is_method_aliased {
  54     my ($self, $role, $method_name) = @_;
  55     exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
  56 }
  57
  58 sub is_aliased_method {
  59     my ($self, $role, $method_name) = @_;
  60     my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
  61     exists $aliased_names{$method_name} ? 1 : 0;
  62 }
  63
  64 sub check_role_exclusions {
  65     my ($self, $c) = @_;
  66
  67     my %excluded_roles;
  68     for my $role (@{ $c->get_roles }) {
  69         my $name = $role->name;
  70
  71         for my $excluded ($role->get_excluded_roles_list) {
  72             push @{ $excluded_roles{$excluded} }, $name;
  73         }
  74     }
  75
  76     foreach my $role (@{$c->get_roles}) {
  77         foreach my $excluded (keys %excluded_roles) {
  78             next unless $role->does_role($excluded);
  79
  80             my @excluding = @{ $excluded_roles{$excluded} };
  81
  82             require Moose;
  83             Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
  84         }
  85     }
  86
  87     $c->add_excluded_roles(keys %excluded_roles);
  88 }
  89
  90 sub check_required_methods {
  91     my ($self, $c) = @_;
  92
  93     my %all_required_methods =
  94         map { $_->name => $_ }
  95         map { $_->get_required_method_list }
  96         @{$c->get_roles};
  97
  98     foreach my $role (@{$c->get_roles}) {
  99         foreach my $required (keys %all_required_methods) {
 100
 101             delete $all_required_methods{$required}
 102                 if $role->has_method($required)
 103                 || $self->is_aliased_method($role, $required);
 104         }
 105     }
 106
 107     $c->add_required_methods(values %all_required_methods);
 108 }
 109
 110 sub check_required_attributes {
 111
 112 }
 113
 114 sub apply_attributes {
 115     my ($self, $c) = @_;
 116
 117     my @all_attributes;
 118
 119     for my $role ( @{ $c->get_roles } ) {
 120         push @all_attributes,
 121             map { $role->get_attribute($_) } $role->get_attribute_list;
 122     }
 123
 124     my %seen;
 125     foreach my $attr (@all_attributes) {
 126         my $name = $attr->name;
 127
 128         if ( exists $seen{$name} ) {
 129             next if $seen{$name}->is_same_as($attr);
 130
 131             my $role1 = $seen{$name}->associated_role->name;
 132             my $role2 = $attr->associated_role->name;
 133
 134             require Moose;
 135             Moose->throw_error(
 136                 "We have encountered an attribute conflict with '$name' "
 137                     . "during role composition. "
 138                     . " This attribute is defined in both $role1 and $role2."
 139                     . " This is fatal error and cannot be disambiguated." );
 140         }
 141
 142         $seen{$name} = $attr;
 143     }
 144
 145     foreach my $attr (@all_attributes) {
 146         $c->add_attribute( $attr->clone );
 147     }
 148 }
 149
 150 sub apply_methods {
 151     my ($self, $c) = @_;
 152
 153     my @all_methods = map {
 154         my $role     = $_;
 155         my $aliases  = $self->get_method_aliases_for_role($role);
 156         my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
 157         (
 158             (map {
 159                 exists $excludes{$_} ? () :
 160                 +{
 161                     role   => $role,
 162                     name   => $_,
 163                     method => $role->get_method($_),
 164                 }
 165             } map { $_->name }
 166               grep { !$_->isa('Class::MOP::Method::Meta') }
 167                    $role->_get_local_methods),
 168             (map {
 169                 +{
 170                     role   => $role,
 171                     name   => $aliases->{$_},
 172                     method => $role->get_method($_),
 173                 }
 174             } keys %$aliases)
 175         );
 176     } @{$c->get_roles};
 177
 178     my (%seen, %method_map);
 179     foreach my $method (@all_methods) {
 180         my $seen = $seen{$method->{name}};
 181
 182         if ($seen) {
 183             if ($seen->{method}->body != $method->{method}->body) {
 184                 $c->add_conflicting_method(
 185                     name  => $method->{name},
 186                     roles => [$method->{role}->name, $seen->{role}->name],
 187                 );
 188
 189                 delete $method_map{$method->{name}};
 190                 next;
 191             }
 192         }
 193
 194         $seen{$method->{name}}       = $method;
 195         $method_map{$method->{name}} = $method->{method};
 196     }
 197
 198     $c->add_method($_ => $method_map{$_}) for keys %method_map;
 199 }
 200
 201 sub apply_override_method_modifiers {
 202     my ($self, $c) = @_;
 203
 204     my @all_overrides = map {
 205         my $role = $_;
 206         map {
 207             +{
 208                 name   => $_,
 209                 method => $role->get_override_method_modifier($_),
 210             }
 211         } $role->get_method_modifier_list('override');
 212     } @{$c->get_roles};
 213
 214     my %seen;
 215     foreach my $override (@all_overrides) {
 216         if ( $c->has_method($override->{name}) ){
 217             require Moose;
 218             Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " .
 219                                 "during composition (A local method of the same name as been found). This " .
 220                                 "is fatal error." )
 221         }
 222         if (exists $seen{$override->{name}}) {
 223             if ( $seen{$override->{name}} != $override->{method} ) {
 224                 require Moose;
 225                 Moose->throw_error( "We have encountered an 'override' method conflict during " .
 226                                     "composition (Two 'override' methods of the same name encountered). " .
 227                                     "This is fatal error.")
 228             }
 229         }
 230         $seen{$override->{name}} = $override->{method};
 231     }
 232
 233     $c->add_override_method_modifier(
 234         $_->{name}, $_->{method}
 235     ) for @all_overrides;
 236
 237 }
 238
 239 sub apply_method_modifiers {
 240     my ($self, $modifier_type, $c) = @_;
 241     my $add = "add_${modifier_type}_method_modifier";
 242     my $get = "get_${modifier_type}_method_modifiers";
 243     foreach my $role (@{$c->get_roles}) {
 244         foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 245             $c->$add(
 246                 $method_name,
 247                 $_
 248             ) foreach $role->$get($method_name);
 249         }
 250     }
 251 }
 252
 253 1;
 254
 255 # ABSTRACT: Combine two or more roles
 256
 257 __END__
 258
 259 =pod
 260
 261 =head1 DESCRIPTION
 262
 263 Summation composes two traits, forming the union of non-conflicting
 264 bindings and 'disabling' the conflicting bindings
 265
 266 =head2 METHODS
 267
 268 =over 4
 269
 270 =item B<new>
 271
 272 =item B<meta>
 273
 274 =item B<role_params>
 275
 276 =item B<get_exclusions_for_role>
 277
 278 =item B<get_method_aliases_for_role>
 279
 280 =item B<is_aliased_method>
 281
 282 =item B<is_method_aliased>
 283
 284 =item B<is_method_excluded>
 285
 286 =item B<apply>
 287
 288 =item B<check_role_exclusions>
 289
 290 =item B<check_required_methods>
 291
 292 =item B<check_required_attributes>
 293
 294 =item B<apply_attributes>
 295
 296 =item B<apply_methods>
 297
 298 =item B<apply_method_modifiers>
 299
 300 =item B<apply_override_method_modifiers>
 301
 302 =back
 303
 304 =head1 BUGS
 305
 306 See L<Moose/BUGS> for details on reporting bugs.
 307
 308 =cut
 309