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 Carp            'confess';
   8 use Scalar::Util    'blessed';
   9
  10 use Moose::Meta::Role::Composite;
  11
  12 our $VERSION   = '0.56';
  13 $VERSION = eval $VERSION;
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 use base 'Moose::Meta::Role::Application';
  17
  18 __PACKAGE__->meta->add_attribute('role_params' => (
  19     reader  => 'role_params',
  20     default => sub { {} }
  21 ));
  22
  23 sub get_exclusions_for_role {
  24     my ($self, $role) = @_;
  25     $role = $role->name if blessed $role;
  26     if ($self->role_params->{$role} && defined $self->role_params->{$role}->{excludes}) {
  27         if (ref $self->role_params->{$role}->{excludes} eq 'ARRAY') {
  28             return $self->role_params->{$role}->{excludes};
  29         }
  30         return [ $self->role_params->{$role}->{excludes} ];
  31     }
  32     return [];
  33 }
  34
  35 sub get_method_aliases_for_role {
  36     my ($self, $role) = @_;
  37     $role = $role->name if blessed $role;
  38     if ($self->role_params->{$role} && defined $self->role_params->{$role}->{alias}) {
  39         return $self->role_params->{$role}->{alias};
  40     }
  41     return {};
  42 }
  43
  44 sub is_method_excluded {
  45     my ($self, $role, $method_name) = @_;
  46     foreach ($self->get_exclusions_for_role($role->name)) {
  47         return 1 if $_ eq $method_name;
  48     }
  49     return 0;
  50 }
  51
  52 sub is_method_aliased {
  53     my ($self, $role, $method_name) = @_;
  54     exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
  55 }
  56
  57 sub is_aliased_method {
  58     my ($self, $role, $method_name) = @_;
  59     my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
  60     exists $aliased_names{$method_name} ? 1 : 0;
  61 }
  62
  63 # stolen from List::MoreUtils ...
  64 my $uniq = sub { my %h; map { $h{$_}++ == 0 ? $_ : () } @_ };
  65
  66 sub check_role_exclusions {
  67     my ($self, $c) = @_;
  68
  69     my @all_excluded_roles = $uniq->(map {
  70         $_->get_excluded_roles_list
  71     } @{$c->get_roles});
  72
  73     foreach my $role (@{$c->get_roles}) {
  74         foreach my $excluded (@all_excluded_roles) {
  75             confess "Conflict detected: " . $role->name . " excludes role '" . $excluded . "'"
  76                 if $role->does_role($excluded);
  77         }
  78     }
  79
  80     $c->add_excluded_roles(@all_excluded_roles);
  81 }
  82
  83 sub check_required_methods {
  84     my ($self, $c) = @_;
  85
  86     my %all_required_methods = map { $_ => undef } $uniq->(map {
  87         $_->get_required_method_list
  88     } @{$c->get_roles});
  89
  90     foreach my $role (@{$c->get_roles}) {
  91         foreach my $required (keys %all_required_methods) {
  92
  93             delete $all_required_methods{$required}
  94                 if $role->has_method($required)
  95                 || $self->is_aliased_method($role, $required);
  96         }
  97     }
  98
  99     $c->add_required_methods(keys %all_required_methods);
 100 }
 101
 102 sub check_required_attributes {
 103
 104 }
 105
 106 sub apply_attributes {
 107     my ($self, $c) = @_;
 108
 109     my @all_attributes = map {
 110         my $role = $_;
 111         map {
 112             +{
 113                 name => $_,
 114                 attr => $role->get_attribute($_),
 115             }
 116         } $role->get_attribute_list
 117     } @{$c->get_roles};
 118
 119     my %seen;
 120     foreach my $attr (@all_attributes) {
 121         if (exists $seen{$attr->{name}}) {
 122             confess "We have encountered an attribute conflict with '" . $attr->{name} . "' "
 123                   . "during composition. This is fatal error and cannot be disambiguated."
 124                 if $seen{$attr->{name}} != $attr->{attr};
 125         }
 126         $seen{$attr->{name}} = $attr->{attr};
 127     }
 128
 129     foreach my $attr (@all_attributes) {
 130         $c->add_attribute($attr->{name}, $attr->{attr});
 131     }
 132 }
 133
 134 sub apply_methods {
 135     my ($self, $c) = @_;
 136
 137     my @all_methods = map {
 138         my $role     = $_;
 139         my $aliases  = $self->get_method_aliases_for_role($role);
 140         my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
 141         (
 142             (map {
 143                 exists $excludes{$_} ? () :
 144                 +{
 145                     role   => $role,
 146                     name   => $_,
 147                     method => $role->get_method($_),
 148                 }
 149             } $role->get_method_list),
 150             (map {
 151                 +{
 152                     role   => $role,
 153                     name   => $aliases->{$_},
 154                     method => $role->get_method($_),
 155                 }
 156             } keys %$aliases)
 157         );
 158     } @{$c->get_roles};
 159
 160     my (%seen, %method_map);
 161     foreach my $method (@all_methods) {
 162         if (exists $seen{$method->{name}}) {
 163             if ($seen{$method->{name}}->body != $method->{method}->body) {
 164                 $c->add_required_methods($method->{name});
 165                 delete $method_map{$method->{name}};
 166                 next;
 167             }
 168         }
 169
 170         $seen{$method->{name}}       = $method->{method};
 171         $method_map{$method->{name}} = $method->{method};
 172     }
 173
 174     $c->alias_method($_ => $method_map{$_}) for keys %method_map;
 175 }
 176
 177 sub apply_override_method_modifiers {
 178     my ($self, $c) = @_;
 179
 180     my @all_overrides = map {
 181         my $role = $_;
 182         map {
 183             +{
 184                 name   => $_,
 185                 method => $role->get_override_method_modifier($_),
 186             }
 187         } $role->get_method_modifier_list('override');
 188     } @{$c->get_roles};
 189
 190     my %seen;
 191     foreach my $override (@all_overrides) {
 192         confess "Role '" . $c->name . "' has encountered an 'override' method conflict " .
 193                 "during composition (A local method of the same name as been found). This " .
 194                 "is fatal error."
 195             if $c->has_method($override->{name});
 196         if (exists $seen{$override->{name}}) {
 197             confess "We have encountered an 'override' method conflict during " .
 198                     "composition (Two 'override' methods of the same name encountered). " .
 199                     "This is fatal error."
 200                 if $seen{$override->{name}} != $override->{method};
 201         }
 202         $seen{$override->{name}} = $override->{method};
 203     }
 204
 205     $c->add_override_method_modifier(
 206         $_->{name}, $_->{method}
 207     ) for @all_overrides;
 208
 209 }
 210
 211 sub apply_method_modifiers {
 212     my ($self, $modifier_type, $c) = @_;
 213     my $add = "add_${modifier_type}_method_modifier";
 214     my $get = "get_${modifier_type}_method_modifiers";
 215     foreach my $role (@{$c->get_roles}) {
 216         foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 217             $c->$add(
 218                 $method_name,
 219                 $_
 220             ) foreach $role->$get($method_name);
 221         }
 222     }
 223 }
 224
 225 1;
 226
 227 __END__
 228
 229 =pod
 230
 231 =head1 NAME
 232
 233 Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
 234
 235 =head1 DESCRIPTION
 236
 237 Summation composes two traits, forming the union of non-conflicting
 238 bindings and 'disabling' the conflicting bindings
 239
 240 =head2 METHODS
 241
 242 =over 4
 243
 244 =item B<new>
 245
 246 =item B<meta>
 247
 248 =item B<role_params>
 249
 250 =item B<get_exclusions_for_role>
 251
 252 =item B<get_method_aliases_for_role>
 253
 254 =item B<is_aliased_method>
 255
 256 =item B<is_method_aliased>
 257
 258 =item B<is_method_excluded>
 259
 260 =item B<apply>
 261
 262 =item B<check_role_exclusions>
 263
 264 =item B<check_required_methods>
 265
 266 =item B<check_required_attributes>
 267
 268 =item B<apply_attributes>
 269
 270 =item B<apply_methods>
 271
 272 =item B<apply_method_modifiers>
 273
 274 =item B<apply_override_method_modifiers>
 275
 276 =back
 277
 278 =head1 BUGS
 279
 280 All complex software has bugs lurking in it, and this module is no
 281 exception. If you find a bug please either email me, or add the bug
 282 to cpan-RT.
 283
 284 =head1 AUTHOR
 285
 286 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 287
 288 =head1 COPYRIGHT AND LICENSE
 289
 290 Copyright 2006-2008 by Infinity Interactive, Inc.
 291
 292 L<http://www.iinteractive.com>
 293
 294 This library is free software; you can redistribute it and/or modify
 295 it under the same terms as Perl itself.
 296
 297 =cut
 298