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