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