File Coverage

blib/lib/Moose/Meta/Role/Application/ToRole.pm
Criterion Covered Total %
statement 64 64 100.0
branch 27 28 96.4
condition 9 12 75.0
subroutine 13 13 100.0
pod 8 8 100.0
total 121 125 96.8


line stmt bran cond sub pod time code
1             package Moose::Meta::Role::Application::ToRole;
2             our $VERSION = '2.2203';
3              
4 388     388   2670 use strict;
  388         896  
  388         11214  
5 388     388   1923 use warnings;
  388         860  
  388         8480  
6 388     388   1836 use metaclass;
  388         820  
  388         2037  
7              
8 388     388   2785 use parent 'Moose::Meta::Role::Application';
  388         972  
  388         2318  
9              
10 388     388   25786 use Moose::Util 'throw_exception';
  388         1111  
  388         2643  
11              
12             sub apply {
13 505     505 1 1499 my ($self, $role1, $role2) = @_;
14 505         2208 $self->SUPER::apply($role1, $role2);
15 498         2000 $role2->add_role($role1);
16             }
17              
18             sub check_role_exclusions {
19 507     507 1 1427 my ($self, $role1, $role2) = @_;
20 507 100       4771 if ( $role2->excludes_role($role1->name) ) {
21 1         9 throw_exception( ConflictDetectedInCheckRoleExclusions => role_name => $role2->name,
22             excluded_role_name => $role1->name,
23             );
24             }
25 506         1982 foreach my $excluded_role_name ($role1->get_excluded_roles_list) {
26 2 100       10 if ( $role2->does_role($excluded_role_name) ) {
27 1         7 throw_exception( RoleDoesTheExcludedRole => role_name => $role2->name,
28             excluded_role_name => $excluded_role_name,
29             second_role_name => $role1->name,
30             );
31             }
32 1         4 $role2->add_excluded_roles($excluded_role_name);
33             }
34             }
35              
36             sub check_required_methods {
37 505     505 1 1285 my ($self, $role1, $role2) = @_;
38 505         2294 foreach my $required_method ($role1->get_required_method_list) {
39 641         17992 my $required_method_name = $required_method->name;
40              
41 641 100       2329 next if $self->is_aliased_method($required_method_name);
42              
43 638 100       2056 $role2->add_required_methods($required_method)
44             unless $role2->find_method_by_name($required_method_name);
45             }
46             }
47              
48       505 1   sub check_required_attributes {
49              
50             }
51              
52             sub apply_attributes {
53 506     506 1 1386 my ($self, $role1, $role2) = @_;
54 506         2317 foreach my $attribute_name ($role1->get_attribute_list) {
55             # it if it has one already
56 87 100 66     335 if ($role2->has_attribute($attribute_name) &&
57             # make sure we haven't seen this one already too
58             $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) {
59              
60 2         10 my $role2_name = $role2->name;
61              
62 2         15 throw_exception( AttributeConflictInRoles => role_name => $role1->name,
63             second_role_name => $role2->name,
64             attribute_name => $attribute_name
65             );
66             }
67             else {
68 85         561 $role2->add_attribute(
69             $role1->get_attribute($attribute_name)->clone
70             );
71             }
72             }
73             }
74              
75             sub apply_methods {
76 504     504 1 1827 my ( $self, $role1, $role2 ) = @_;
77 504         8563 foreach my $method ( $role1->_get_local_methods ) {
78              
79 7202         22535 my $method_name = $method->name;
80              
81 7202 100       26264 next if $method->isa('Class::MOP::Method::Meta');
82              
83 6776 100       15680 unless ( $self->is_method_excluded($method_name) ) {
84              
85 6767         17679 my $role2_method = $role2->get_method($method_name);
86 6767 100 66     16136 if ( $role2_method
87             && $role2_method->body != $method->body ) {
88              
89             # method conflicts between roles used to result in the method
90             # becoming a requirement but now are permitted just like
91             # for classes, hence no code in this branch anymore.
92             }
93             else {
94 6041         13715 $role2->add_method(
95             $method_name,
96             $method,
97             );
98             }
99             }
100              
101 6776 100       19650 next unless $self->is_method_aliased($method_name);
102              
103 11         825 my $aliased_method_name = $self->get_method_aliases->{$method_name};
104              
105 11         41 my $role2_method = $role2->get_method($aliased_method_name);
106              
107 11 100 66     50 if ( $role2_method
108             && $role2_method->body != $method->body ) {
109              
110 2         13 throw_exception( CannotCreateMethodAliasLocalMethodIsPresent => aliased_method_name => $aliased_method_name,
111             method => $method,
112             role_name => $role2->name,
113             role_being_applied_name => $role1->name,
114             );
115             }
116              
117             $role2->add_method(
118 9         31 $aliased_method_name,
119             $role1->get_method($method_name)
120             );
121              
122 9 100       53 if ( !$role2->has_method($method_name) ) {
123 2 50       7 $role2->add_required_methods($method_name)
124             unless $self->is_method_excluded($method_name);
125             }
126             }
127             }
128              
129             sub apply_override_method_modifiers {
130 502     502 1 1798 my ($self, $role1, $role2) = @_;
131 502         1946 foreach my $method_name ($role1->get_method_modifier_list('override')) {
132             # it if it has one already then ...
133 1048 100       2851 if ($role2->has_method($method_name)) {
134             # if it is being composed into another role
135             # we have a conflict here, because you cannot
136             # combine an overridden method with a locally
137             # defined one
138 2         15 throw_exception( OverrideConflictInComposition => role_name => $role2->name,
139             role_being_applied_name => $role1->name,
140             method_name => $method_name
141             );
142             }
143             else {
144             # if we are a role, we need to make sure
145             # we don't have a conflict with the role
146             # we are composing into
147 1046 100 100     2788 if ($role2->has_override_method_modifier($method_name) &&
148             $role1->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) {
149              
150 2         15 throw_exception( OverrideConflictInComposition => role_name => $role2->name,
151             role_being_applied_name => $role1->name,
152             method_name => $method_name,
153             two_overrides_found => 1
154             );
155             }
156             else {
157             # if there is no conflict,
158             # just add it to the role
159 1044         2727 $role2->add_override_method_modifier(
160             $method_name,
161             $role1->get_override_method_modifier($method_name)
162             );
163             }
164             }
165             }
166             }
167              
168             sub apply_method_modifiers {
169 1494     1494 1 3831 my ($self, $modifier_type, $role1, $role2) = @_;
170 1494         3074 my $add = "add_${modifier_type}_method_modifier";
171 1494         2718 my $get = "get_${modifier_type}_method_modifiers";
172 1494         3409 foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) {
173             $role2->$add(
174             $method_name,
175             $_
176 984         3230 ) foreach $role1->$get($method_name);
177             }
178             }
179              
180             1;
181              
182             # ABSTRACT: Compose a role into another role
183              
184             __END__
185              
186             =pod
187              
188             =encoding UTF-8
189              
190             =head1 NAME
191              
192             Moose::Meta::Role::Application::ToRole - Compose a role into another role
193              
194             =head1 VERSION
195              
196             version 2.2203
197              
198             =head1 DESCRIPTION
199              
200             =head2 METHODS
201              
202             =over 4
203              
204             =item B<new>
205              
206             =item B<meta>
207              
208             =item B<apply>
209              
210             =item B<check_role_exclusions>
211              
212             =item B<check_required_methods>
213              
214             =item B<check_required_attributes>
215              
216             =item B<apply_attributes>
217              
218             =item B<apply_methods>
219              
220             =item B<apply_method_modifiers>
221              
222             =item B<apply_override_method_modifiers>
223              
224             =back
225              
226             =head1 BUGS
227              
228             See L<Moose/BUGS> for details on reporting bugs.
229              
230             =head1 AUTHORS
231              
232             =over 4
233              
234             =item *
235              
236             Stevan Little <stevan@cpan.org>
237              
238             =item *
239              
240             Dave Rolsky <autarch@urth.org>
241              
242             =item *
243              
244             Jesse Luehrs <doy@cpan.org>
245              
246             =item *
247              
248             Shawn M Moore <sartak@cpan.org>
249              
250             =item *
251              
252             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
253              
254             =item *
255              
256             Karen Etheridge <ether@cpan.org>
257              
258             =item *
259              
260             Florian Ragwitz <rafl@debian.org>
261              
262             =item *
263              
264             Hans Dieter Pearcey <hdp@cpan.org>
265              
266             =item *
267              
268             Chris Prather <chris@prather.org>
269              
270             =item *
271              
272             Matt S Trout <mstrout@cpan.org>
273              
274             =back
275              
276             =head1 COPYRIGHT AND LICENSE
277              
278             This software is copyright (c) 2006 by Infinity Interactive, Inc.
279              
280             This is free software; you can redistribute it and/or modify it under
281             the same terms as the Perl 5 programming language system itself.
282              
283             =cut