Bump version to 1.9900 for new version numbering scheme
[gitmo/Moose.git] / lib / Moose / Meta / Role / Application / ToRole.pm
1 package Moose::Meta::Role::Application::ToRole;
2
3 use strict;
4 use warnings;
5 use metaclass;
6
7 use Scalar::Util    'blessed';
8
9 our $VERSION   = '1.9900';
10 $VERSION = eval $VERSION;
11 our $AUTHORITY = 'cpan:STEVAN';
12
13 use base 'Moose::Meta::Role::Application';
14
15 sub apply {
16     my ($self, $role1, $role2) = @_;
17     $self->SUPER::apply($role1, $role2);
18     $role2->add_role($role1);
19 }
20
21 sub check_role_exclusions {
22     my ($self, $role1, $role2) = @_;
23     if ( $role2->excludes_role($role1->name) ) {
24         require Moose;
25         Moose->throw_error("Conflict detected: " . $role2->name . " excludes role '" . $role1->name . "'");
26     }
27     foreach my $excluded_role_name ($role1->get_excluded_roles_list) {
28         if ( $role2->does_role($excluded_role_name) ) {
29             require Moose;
30             Moose->throw_error("The class " . $role2->name . " does the excluded role '$excluded_role_name'");
31         }
32         $role2->add_excluded_roles($excluded_role_name);
33     }
34 }
35
36 sub check_required_methods {
37     my ($self, $role1, $role2) = @_;
38     foreach my $required_method ($role1->get_required_method_list) {
39         my $required_method_name = $required_method->name;
40
41         next if $self->is_aliased_method($required_method_name);
42
43         $role2->add_required_methods($required_method)
44             unless $role2->find_method_by_name($required_method_name);
45     }
46 }
47
48 sub check_required_attributes {
49
50 }
51
52 sub apply_attributes {
53     my ($self, $role1, $role2) = @_;
54     foreach my $attribute_name ($role1->get_attribute_list) {
55         # it if it has one already
56         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             my $role2_name = $role2->name;
61
62             require Moose;
63             Moose->throw_error( "Role '"
64                     . $role1->name
65                     . "' has encountered an attribute conflict"
66                     . " while being composed into '$role2_name'."
67                     . " This is a fatal error and cannot be disambiguated."
68                     . " The conflicting attribute is named '$attribute_name'." );
69         }
70         else {
71             $role2->add_attribute(
72                 $role1->get_attribute($attribute_name)->clone
73             );
74         }
75     }
76 }
77
78 sub apply_methods {
79     my ( $self, $role1, $role2 ) = @_;
80     foreach my $method ( $role1->_get_local_methods ) {
81
82         my $method_name = $method->name;
83
84         next if $method->isa('Class::MOP::Method::Meta');
85
86         unless ( $self->is_method_excluded($method_name) ) {
87
88             my $role2_method = $role2->get_method($method_name);
89             if (   $role2_method
90                 && $role2_method->body != $method->body ) {
91
92                 # method conflicts between roles result in the method becoming
93                 # a requirement
94                 $role2->add_conflicting_method(
95                     name  => $method_name,
96                     roles => [ $role1->name, $role2->name ],
97                 );
98             }
99             else {
100                 $role2->add_method(
101                     $method_name,
102                     $method,
103                 );
104             }
105         }
106
107         next unless $self->is_method_aliased($method_name);
108
109         my $aliased_method_name = $self->get_method_aliases->{$method_name};
110
111         my $role2_method = $role2->get_method($aliased_method_name);
112
113         if (   $role2_method
114             && $role2_method->body != $method->body ) {
115
116             require Moose;
117             Moose->throw_error(
118                 "Cannot create a method alias if a local method of the same name exists"
119             );
120         }
121
122         $role2->add_method(
123             $aliased_method_name,
124             $role1->get_method($method_name)
125         );
126
127         if ( !$role2->has_method($method_name) ) {
128             $role2->add_required_methods($method_name)
129                 unless $self->is_method_excluded($method_name);
130         }
131     }
132 }
133
134 sub apply_override_method_modifiers {
135     my ($self, $role1, $role2) = @_;
136     foreach my $method_name ($role1->get_method_modifier_list('override')) {
137         # it if it has one already then ...
138         if ($role2->has_method($method_name)) {
139             # if it is being composed into another role
140             # we have a conflict here, because you cannot
141             # combine an overridden method with a locally
142             # defined one
143             require Moose;
144             Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
145                     "during composition (A local method of the same name as been found). This " .
146                     "is fatal error.");
147         }
148         else {
149             # if we are a role, we need to make sure
150             # we dont have a conflict with the role
151             # we are composing into
152             if ($role2->has_override_method_modifier($method_name) &&
153                 $role2->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) {
154
155                 require Moose;
156                 Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
157                         "during composition (Two 'override' methods of the same name encountered). " .
158                         "This is fatal error.");
159             }
160             else {
161                 # if there is no conflict,
162                 # just add it to the role
163                 $role2->add_override_method_modifier(
164                     $method_name,
165                     $role1->get_override_method_modifier($method_name)
166                 );
167             }
168         }
169     }
170 }
171
172 sub apply_method_modifiers {
173     my ($self, $modifier_type, $role1, $role2) = @_;
174     my $add = "add_${modifier_type}_method_modifier";
175     my $get = "get_${modifier_type}_method_modifiers";
176     foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) {
177         $role2->$add(
178             $method_name,
179             $_
180         ) foreach $role1->$get($method_name);
181     }
182 }
183
184
185 1;
186
187 __END__
188
189 =pod
190
191 =head1 NAME
192
193 Moose::Meta::Role::Application::ToRole - Compose a role into another role
194
195 =head1 DESCRIPTION
196
197 =head2 METHODS
198
199 =over 4
200
201 =item B<new>
202
203 =item B<meta>
204
205 =item B<apply>
206
207 =item B<check_role_exclusions>
208
209 =item B<check_required_methods>
210
211 =item B<check_required_attributes>
212
213 =item B<apply_attributes>
214
215 =item B<apply_methods>
216
217 =item B<apply_method_modifiers>
218
219 =item B<apply_override_method_modifiers>
220
221 =back
222
223 =head1 BUGS
224
225 See L<Moose/BUGS> for details on reporting bugs.
226
227 =head1 AUTHOR
228
229 Stevan Little E<lt>stevan@iinteractive.comE<gt>
230
231 =head1 COPYRIGHT AND LICENSE
232
233 Copyright 2006-2010 by Infinity Interactive, Inc.
234
235 L<http://www.iinteractive.com>
236
237 This library is free software; you can redistribute it and/or modify
238 it under the same terms as Perl itself.
239
240 =cut
241