File Coverage

blib/lib/Moose/Meta/Role/Application/RoleSummation.pm
Criterion Covered Total %
statement 169 176 96.0
branch 45 54 83.3
condition 9 12 75.0
subroutine 22 24 91.6
pod 13 13 100.0
total 258 279 92.4


line stmt bran cond sub pod time code
1             package Moose::Meta::Role::Application::RoleSummation;
2             our $VERSION = '2.2205';
3              
4 377     377   507417 use strict;
  377         1263  
  377         12922  
5 377     377   2283 use warnings;
  377         1180  
  377         9509  
6 377     377   5177 use metaclass;
  377         1058  
  377         2569  
7              
8 377     377   3216 use List::Util 1.33 qw( all );
  377         7529  
  377         26414  
9 377     377   3138 use Scalar::Util 'blessed';
  377         1224  
  377         20207  
10              
11 377     377   7252 use Moose::Meta::Role::Composite;
  377         1342  
  377         12609  
12              
13 377     377   2836 use parent 'Moose::Meta::Role::Application';
  377         1300  
  377         2885  
14              
15 377     377   27589 use Moose::Util 'throw_exception';
  377         1268  
  377         2954  
16              
17             __PACKAGE__->meta->add_attribute('role_params' => (
18             reader => 'role_params',
19             default => sub { {} },
20             Class::MOP::_definition_context(),
21             ));
22              
23             sub get_exclusions_for_role {
24 535     535 1 1395 my ($self, $role) = @_;
25 535 50       3487 $role = $role->name if blessed $role;
26 535 100       18473 my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ?
27             '-excludes' : 'excludes';
28 535 100 66     17484 if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) {
29 21 100       679 if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') {
30 6         208 return $self->role_params->{$role}->{$excludes_key};
31             }
32 15         525 return [ $self->role_params->{$role}->{$excludes_key} ];
33             }
34 514         1931 return [];
35             }
36              
37             sub get_method_aliases_for_role {
38 842     842 1 1915 my ($self, $role) = @_;
39 842 100       4308 $role = $role->name if blessed $role;
40 842 100       33219 my $alias_key = exists $self->role_params->{$role}->{'-alias'} ?
41             '-alias' : 'alias';
42 842 100 66     27685 if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) {
43 11         370 return $self->role_params->{$role}->{$alias_key};
44             }
45 831         2896 return {};
46             }
47              
48             sub is_method_excluded {
49 0     0 1 0 my ($self, $role, $method_name) = @_;
50 0         0 foreach ($self->get_exclusions_for_role($role->name)) {
51 0 0       0 return 1 if $_ eq $method_name;
52             }
53 0         0 return 0;
54             }
55              
56             sub is_method_aliased {
57 0     0 1 0 my ($self, $role, $method_name) = @_;
58 0 0       0 exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
59             }
60              
61             sub is_aliased_method {
62 307     307 1 763 my ($self, $role, $method_name) = @_;
63 307         513 my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
  307         1030  
64 307 50       1723 exists $aliased_names{$method_name} ? 1 : 0;
65             }
66              
67             sub check_role_exclusions {
68 255     255 1 897 my ($self, $c) = @_;
69              
70 255         566 my %excluded_roles;
71 255         571 for my $role (@{ $c->get_roles }) {
  255         8366  
72 577         2761 my $name = $role->name;
73              
74 577         1914 for my $excluded ($role->get_excluded_roles_list) {
75 8         18 push @{ $excluded_roles{$excluded} }, $name;
  8         38  
76             }
77             }
78              
79 255         810 foreach my $role (@{$c->get_roles}) {
  255         7454  
80 573         1655 foreach my $excluded (keys %excluded_roles) {
81 11 100       36 next unless $role->does_role($excluded);
82              
83 6         17 my @excluding = @{ $excluded_roles{$excluded} };
  6         21  
84              
85 6         28 throw_exception( RoleExclusionConflict => roles => \@excluding,
86             role_name => $excluded
87             );
88             }
89             }
90              
91 249         2461 $c->add_excluded_roles(keys %excluded_roles);
92             }
93              
94             sub check_required_methods {
95 249     249 1 838 my ($self, $c) = @_;
96              
97             my %all_required_methods =
98 149         4644 map { $_->name => $_ }
99 564         2433 map { $_->get_required_method_list }
100 249         668 @{$c->get_roles};
  249         8043  
101              
102 249         802 foreach my $role (@{$c->get_roles}) {
  249         7139  
103 564         1696 foreach my $required (keys %all_required_methods) {
104              
105 336 100 66     1127 delete $all_required_methods{$required}
106             if $role->has_method($required)
107             || $self->is_aliased_method($role, $required);
108             }
109             }
110              
111 249         1778 $c->add_required_methods(values %all_required_methods);
112             }
113              
114       249 1   sub check_required_attributes {
115              
116             }
117              
118             sub apply_attributes {
119 243     243 1 810 my ($self, $c) = @_;
120              
121 243         527 my @all_attributes;
122              
123 243         551 for my $role ( @{ $c->get_roles } ) {
  243         8007  
124             push @all_attributes,
125 549         2656 map { $role->get_attribute($_) } $role->get_attribute_list;
  221         1131  
126             }
127              
128 243         743 my %seen;
129 243         845 foreach my $attr (@all_attributes) {
130 220         1026 my $name = $attr->name;
131              
132 220 100       719 if ( exists $seen{$name} ) {
133 8 100       78 next if $seen{$name}->is_same_as($attr);
134              
135 6         225 my $role1 = $seen{$name}->associated_role->name;
136 6         182 my $role2 = $attr->associated_role->name;
137              
138 6         54 throw_exception( AttributeConflictInSummation => attribute_name => $name,
139             role_name => $role1,
140             second_role_name => $role2,
141             );
142             }
143              
144 212         624 $seen{$name} = $attr;
145             }
146              
147 237         943 foreach my $attr (@all_attributes) {
148 207         1123 $c->add_attribute( $attr->clone );
149             }
150             }
151              
152             sub apply_methods {
153 237     237 1 882 my ($self, $c) = @_;
154              
155             my @all_methods = map {
156 535         1471 my $role = $_;
157 535         1925 my $aliases = $self->get_method_aliases_for_role($role);
158 535         1593 my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
  29         105  
  535         2181  
159             (
160             (map {
161 1921 100       6364 exists $excludes{$_} ? () :
162             +{
163             role => $role,
164             name => $_,
165             method => $role->get_method($_),
166             }
167 1921         4766 } map { $_->name }
168 2454         9066 grep { !$_->isa('Class::MOP::Method::Meta') }
169             $role->_get_local_methods),
170             (map {
171 535         2469 +{
172             role => $role,
173 12         47 name => $aliases->{$_},
174             method => $role->get_method($_),
175             }
176             } keys %$aliases)
177             );
178 237         644 } @{$c->get_roles};
  237         8670  
179              
180 237         1035 my (%seen, %conflicts, %method_map);
181 237         878 foreach my $method (@all_methods) {
182 1904 100       3992 next if $conflicts{$method->{name}};
183 1901         3121 my $seen = $seen{$method->{name}};
184              
185 1901 100       3881 if ($seen) {
186 265 100       1471 if ($seen->{method}->body != $method->{method}->body) {
187             $c->add_conflicting_method(
188             name => $method->{name},
189 135         1328 roles => [$method->{role}->name, $seen->{role}->name],
190             );
191              
192 135         540 delete $method_map{$method->{name}};
193 135         310 $conflicts{$method->{name}} = 1;
194 135         357 next;
195             }
196             }
197              
198 1766         3450 $seen{$method->{name}} = $method;
199 1766         3637 $method_map{$method->{name}} = $method->{method};
200             }
201              
202 237         1934 $c->add_method($_ => $method_map{$_}) for keys %method_map;
203             }
204              
205             sub apply_override_method_modifiers {
206 237     237 1 856 my ($self, $c) = @_;
207              
208             my @all_overrides = map {
209 535         1327 my $role = $_;
210             map {
211 535         1831 +{
212 255         900 name => $_,
213             method => $role->get_override_method_modifier($_),
214             }
215             } $role->get_method_modifier_list('override');
216 237         581 } @{$c->get_roles};
  237         7506  
217              
218 237         1011 my %seen;
219 237         847 foreach my $override (@all_overrides) {
220 254         450 my @role_names = map { $_->name } @{$c->get_roles};
  569         1793  
  254         7076  
221 254 100       1004 if ( $c->has_method($override->{name}) ){
222             throw_exception( OverrideConflictInSummation => role_names => \@role_names,
223             role_application => $self,
224             method_name => $override->{name}
225 3         30 );
226             }
227 251 100       1229 if (exists $seen{$override->{name}}) {
228 47 100       218 if ( $seen{$override->{name}} != $override->{method} ) {
229             throw_exception( OverrideConflictInSummation => role_names => \@role_names,
230             role_application => $self,
231             method_name => $override->{name},
232 4         42 two_overrides_found => 1
233             );
234             }
235             }
236 247         1148 $seen{$override->{name}} = $override->{method};
237             }
238              
239             $c->add_override_method_modifier(
240             $_->{name}, $_->{method}
241 230         1232 ) for @all_overrides;
242              
243             }
244              
245             sub apply_method_modifiers {
246 690     690 1 1828 my ($self, $modifier_type, $c) = @_;
247 690         1894 my $add = "add_${modifier_type}_method_modifier";
248 690         1621 my $get = "get_${modifier_type}_method_modifiers";
249 690         1246 foreach my $role (@{$c->get_roles}) {
  690         20352  
250 1557         4213 foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
251             $c->$add(
252             $method_name,
253             $_
254 236         1006 ) foreach $role->$get($method_name);
255             }
256             }
257             }
258              
259             sub apply_overloading {
260 249     249 1 843 my ( $self, $c ) = @_;
261              
262 249         600 my @overloaded_roles = grep { $_->is_overloaded } @{ $c->get_roles };
  564         21359  
  249         7440  
263 249 100       12453 return unless @overloaded_roles;
264              
265 10         19 my %fallback;
266 10         37 for my $role (@overloaded_roles) {
267 17         679 $fallback{ $role->name } = $role->get_overload_fallback_value;
268             }
269              
270 10         888 for my $role_name ( keys %fallback ) {
271 15         55 for my $other_role_name ( grep { $_ ne $role_name } keys %fallback ) {
  27         77  
272 12         28 my @fb_values = @fallback{ $role_name, $other_role_name };
273 12 100   14   61 if ( all {defined} @fb_values ) {
  14         39  
274 2 50       11 next if $fallback{$role_name} eq $fallback{$other_role_name};
275 2         15 throw_exception(
276             'OverloadConflictInSummation',
277             role_names => [ $role_name, $other_role_name ],
278             role_application => $self,
279             overloaded_op => 'fallback',
280             );
281             }
282              
283 10 50   20   49 next if all { !defined } @fb_values;
  20         57  
284 0         0 throw_exception(
285             'OverloadConflictInSummation',
286             role_names => [ $role_name, $other_role_name ],
287             role_application => $self,
288             overloaded_op => 'fallback',
289             );
290             }
291             }
292              
293 8 50       38 if ( keys %fallback ) {
294 8         58 $c->set_overload_fallback_value( ( values %fallback )[0] );
295             }
296              
297 8         19 my %overload_map;
298 8         26 for my $role (@overloaded_roles) {
299 13         67 for my $overload ( $role->get_all_overloaded_operators ) {
300 13         57 $overload_map{ $overload->operator }{ $role->name } = $overload;
301             }
302             }
303              
304 8         33 for my $op_name ( keys %overload_map ) {
305 8         18 my @roles = keys %{ $overload_map{$op_name} };
  8         32  
306 8         27 my $overload = $overload_map{$op_name}{ $roles[0] };
307              
308 8 100 100 10   44 if ( @roles > 1 && !all { $overload->_is_equal_to($_) }
  10         27  
309 5         19 values %{ $overload_map{$op_name} } ) {
310              
311 4         22 throw_exception(
312             'OverloadConflictInSummation',
313             role_names => [ @roles[ 0, 1 ] ],
314             role_application => $self,
315             overloaded_op => $op_name,
316             );
317             }
318              
319             $c->add_overloaded_operator(
320 4         30 $op_name => $overload_map{$op_name}{ $roles[0] } );
321             }
322             }
323              
324             1;
325              
326             # ABSTRACT: Combine two or more roles
327              
328             __END__
329              
330             =pod
331              
332             =encoding UTF-8
333              
334             =head1 NAME
335              
336             Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
337              
338             =head1 VERSION
339              
340             version 2.2205
341              
342             =head1 DESCRIPTION
343              
344             Summation composes two traits, forming the union of non-conflicting
345             bindings and 'disabling' the conflicting bindings
346              
347             =head2 METHODS
348              
349             =over 4
350              
351             =item B<new>
352              
353             =item B<meta>
354              
355             =item B<role_params>
356              
357             =item B<get_exclusions_for_role>
358              
359             =item B<get_method_aliases_for_role>
360              
361             =item B<is_aliased_method>
362              
363             =item B<is_method_aliased>
364              
365             =item B<is_method_excluded>
366              
367             =item B<apply>
368              
369             =item B<check_role_exclusions>
370              
371             =item B<check_required_methods>
372              
373             =item B<check_required_attributes>
374              
375             =item B<apply_attributes>
376              
377             =item B<apply_methods>
378              
379             =item B<apply_overloading>
380              
381             =item B<apply_method_modifiers>
382              
383             =item B<apply_override_method_modifiers>
384              
385             =back
386              
387             =head1 AUTHORS
388              
389             =over 4
390              
391             =item *
392              
393             Stevan Little <stevan@cpan.org>
394              
395             =item *
396              
397             Dave Rolsky <autarch@urth.org>
398              
399             =item *
400              
401             Jesse Luehrs <doy@cpan.org>
402              
403             =item *
404              
405             Shawn M Moore <sartak@cpan.org>
406              
407             =item *
408              
409             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
410              
411             =item *
412              
413             Karen Etheridge <ether@cpan.org>
414              
415             =item *
416              
417             Florian Ragwitz <rafl@debian.org>
418              
419             =item *
420              
421             Hans Dieter Pearcey <hdp@cpan.org>
422              
423             =item *
424              
425             Chris Prather <chris@prather.org>
426              
427             =item *
428              
429             Matt S Trout <mstrout@cpan.org>
430              
431             =back
432              
433             =head1 COPYRIGHT AND LICENSE
434              
435             This software is copyright (c) 2006 by Infinity Interactive, Inc.
436              
437             This is free software; you can redistribute it and/or modify it under
438             the same terms as the Perl 5 programming language system itself.
439              
440             =cut