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.01';
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 use base 'Moose::Meta::Role::Application';
  17
  18 # stolen from List::MoreUtils ...
  19 my $uniq = sub { my %h; map { $h{$_}++ == 0 ? $_ : () } @_ };
  20
  21 sub check_role_exclusions {
  22     my ($self, $c) = @_;
  23
  24     my @all_excluded_roles = $uniq->(map {
  25         $_->get_excluded_roles_list
  26     } @{$c->get_roles});
  27
  28     foreach my $role (@{$c->get_roles}) {
  29         foreach my $excluded (@all_excluded_roles) {
  30             confess "Conflict detected: " . $role->name . " excludes role '" . $excluded . "'"
  31                 if $role->does_role($excluded);
  32         }
  33     }
  34
  35     $c->add_excluded_roles(@all_excluded_roles);
  36 }
  37
  38 sub check_required_methods {
  39     my ($self, $c) = @_;
  40
  41     my %all_required_methods = map { $_ => undef } $uniq->(map {
  42         $_->get_required_method_list
  43     } @{$c->get_roles});
  44
  45     foreach my $role (@{$c->get_roles}) {
  46         foreach my $required (keys %all_required_methods) {
  47             delete $all_required_methods{$required}
  48                 if $role->has_method($required);
  49         }
  50     }
  51
  52     $c->add_required_methods(keys %all_required_methods);
  53 }
  54
  55 sub apply_attributes {
  56     my ($self, $c) = @_;
  57
  58     my @all_attributes = map {
  59         my $role = $_;
  60         map {
  61             +{
  62                 name => $_,
  63                 attr => $role->get_attribute($_),
  64             }
  65         } $role->get_attribute_list
  66     } @{$c->get_roles};
  67
  68     my %seen;
  69     foreach my $attr (@all_attributes) {
  70         if (exists $seen{$attr->{name}}) {
  71             confess "We have encountered an attribute conflict with '" . $attr->{name} . "'"
  72                   . "during composition. This is fatal error and cannot be disambiguated."
  73                 if $seen{$attr->{name}} != $attr->{attr};
  74         }
  75         $seen{$attr->{name}} = $attr->{attr};
  76     }
  77
  78     foreach my $attr (@all_attributes) {
  79         $c->add_attribute($attr->{name}, $attr->{attr});
  80     }
  81 }
  82
  83 sub apply_methods {
  84     my ($self, $c) = @_;
  85
  86     my @all_methods = map {
  87         my $role = $_;
  88         map {
  89             +{
  90                 name   => $_,
  91                 method => $role->get_method($_),
  92             }
  93         } $role->get_method_list;
  94     } @{$c->get_roles};
  95
  96     my (%seen, %method_map);
  97     foreach my $method (@all_methods) {
  98         if (exists $seen{$method->{name}}) {
  99             if ($seen{$method->{name}}->body != $method->{method}->body) {
 100                 $c->add_required_methods($method->{name});
 101                 delete $method_map{$method->{name}};
 102                 next;
 103             }
 104         }
 105         $seen{$method->{name}}       = $method->{method};
 106         $method_map{$method->{name}} = $method->{method};
 107     }
 108
 109     $c->alias_method($_ => $method_map{$_}) for keys %method_map;
 110 }
 111
 112 sub apply_override_method_modifiers {
 113     my ($self, $c) = @_;
 114
 115     my @all_overrides = map {
 116         my $role = $_;
 117         map {
 118             +{
 119                 name   => $_,
 120                 method => $role->get_override_method_modifier($_),
 121             }
 122         } $role->get_method_modifier_list('override');
 123     } @{$c->get_roles};
 124
 125     my %seen;
 126     foreach my $override (@all_overrides) {
 127         confess "Role '" . $c->name . "' has encountered an 'override' method conflict " .
 128                 "during composition (A local method of the same name as been found). This " .
 129                 "is fatal error."
 130             if $c->has_method($override->{name});
 131         if (exists $seen{$override->{name}}) {
 132             confess "We have encountered an 'override' method conflict during " .
 133                     "composition (Two 'override' methods of the same name encountered). " .
 134                     "This is fatal error."
 135                 if $seen{$override->{name}} != $override->{method};
 136         }
 137         $seen{$override->{name}} = $override->{method};
 138     }
 139
 140     $c->add_override_method_modifier(
 141         $_->{name}, $_->{method}
 142     ) for @all_overrides;
 143
 144 }
 145
 146 sub apply_method_modifiers {
 147     my ($self, $modifier_type, $c) = @_;
 148     my $add = "add_${modifier_type}_method_modifier";
 149     my $get = "get_${modifier_type}_method_modifiers";
 150     foreach my $role (@{$c->get_roles}) {
 151         foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
 152             $c->$add(
 153                 $method_name,
 154                 $_
 155             ) foreach $role->$get($method_name);
 156         }
 157     }
 158 }
 159
 160 1;
 161
 162 __END__
 163
 164 =pod
 165
 166 =head1 NAME
 167
 168 Moose::Meta::Role::Application::RoleSummation
 169
 170 =head1 DESCRIPTION
 171
 172 Summation composes two traits, forming the union of non-conflicting
 173 bindings and 'disabling' the conflicting bindings
 174
 175 =head2 METHODS
 176
 177 =over 4
 178
 179 =item B<new>
 180
 181 =item B<meta>
 182
 183 =item B<apply>
 184
 185 =item B<check_required_methods>
 186
 187 =item B<check_role_exclusions>
 188
 189 =item B<apply_attributes>
 190
 191 =item B<apply_methods>
 192
 193 =item B<apply_method_modifiers>
 194
 195 =item B<apply_override_method_modifiers>
 196
 197 =back
 198
 199 =head1 BUGS
 200
 201 All complex software has bugs lurking in it, and this module is no
 202 exception. If you find a bug please either email me, or add the bug
 203 to cpan-RT.
 204
 205 =head1 AUTHOR
 206
 207 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 208
 209 =head1 COPYRIGHT AND LICENSE
 210
 211 Copyright 2006-2008 by Infinity Interactive, Inc.
 212
 213 L<http://www.iinteractive.com>
 214
 215 This library is free software; you can redistribute it and/or modify
 216 it under the same terms as Perl itself.
 217
 218 =cut
 219