Basic conflict message
[gitmo/Moose.git] / lib / Moose / Meta / Role / Application / ToClass.pm
1 package Moose::Meta::Role::Application::ToClass;
2
3 use strict;
4 use warnings;
5 use metaclass;
6
7 use Moose::Util  'english_list';
8 use Scalar::Util 'weaken', 'blessed';
9
10 our $VERSION   = '0.79';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
13
14 use base 'Moose::Meta::Role::Application';
15
16 __PACKAGE__->meta->add_attribute('role' => (
17     reader => 'role',
18 ));
19
20 __PACKAGE__->meta->add_attribute('class' => (
21     reader => 'class',
22 ));
23
24 sub apply {
25     my ($self, $role, $class) = @_;
26
27     # We need weak_ref in CMOP :(
28     weaken($self->{role}  = $role);
29     weaken($self->{class} = $class);
30
31     $self->SUPER::apply($role, $class);
32
33     $class->add_role($role);
34     $class->add_role_application($self);
35 }
36
37 sub check_role_exclusions {
38     my ($self, $role, $class) = @_;
39     if ($class->excludes_role($role->name)) {
40         $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
41     }
42     foreach my $excluded_role_name ($role->get_excluded_roles_list) {
43         if ($class->does_role($excluded_role_name)) {
44             $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'");
45         }
46     }
47 }
48
49 sub check_required_methods {
50     my ($self, $role, $class) = @_;
51
52     my @missing;
53     my @is_attr;
54
55     # NOTE:
56     # we might need to move this down below the
57     # the attributes so that we can require any
58     # attribute accessors. However I am thinking
59     # that maybe those are somehow exempt from
60     # the require methods stuff.
61     foreach my $required_method ($role->get_required_method_list) {
62         my $required_method_name = $required_method->name;
63
64         if (!$class->find_method_by_name($required_method_name)) {
65
66             next if $self->is_aliased_method($required_method_name);
67
68             push @missing, $required_method;
69         }
70     }
71
72     return unless @missing;
73
74     my $error = '';
75
76     my @conflicts = grep { $_->is_conflict } @missing;
77
78     if (@conflicts) {
79         my $conflict = $conflicts[0];
80
81         $error
82             .= q{'}
83             . $role->name
84             . "' requires the method '"
85             . $conflict->name
86             . "' to be implemented by '"
87             . $class->name
88             . "' due to a method conflict"
89     }
90     elsif (@missing) {
91         my $noun = @missing == 1 ? 'method' : 'methods';
92
93         my $list
94             = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing );
95
96         $error
97             .= q{'}
98             . $role->name
99             . "' requires the $noun $list "
100             . "to be implemented by '"
101             . $class->name . q{'};
102     }
103
104     $class->throw_error($error);
105 }
106
107 sub check_required_attributes {
108
109 }
110
111 sub apply_attributes {
112     my ($self, $role, $class) = @_;
113     foreach my $attribute_name ($role->get_attribute_list) {
114         # it if it has one already
115         if ($class->has_attribute($attribute_name) &&
116             # make sure we haven't seen this one already too
117             $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
118             next;
119         }
120         else {
121             $class->add_attribute(
122                 $attribute_name,
123                 $role->get_attribute($attribute_name)
124             );
125         }
126     }
127 }
128
129 sub apply_methods {
130     my ($self, $role, $class) = @_;
131     foreach my $method_name ($role->get_method_list) {
132
133         unless ($self->is_method_excluded($method_name)) {
134             # it if it has one already
135             if ($class->has_method($method_name) &&
136                 # and if they are not the same thing ...
137                 $class->get_method($method_name)->body != $role->get_method($method_name)->body) {
138                 next;
139             }
140             else {
141                 # add it, although it could be overridden
142                 $class->add_method(
143                     $method_name,
144                     $role->get_method($method_name)
145                 );
146             }
147         }
148
149         if ($self->is_method_aliased($method_name)) {
150             my $aliased_method_name = $self->get_method_aliases->{$method_name};
151             # it if it has one already
152             if ($class->has_method($aliased_method_name) &&
153                 # and if they are not the same thing ...
154                 $class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
155                 $class->throw_error("Cannot create a method alias if a local method of the same name exists");
156             }
157             $class->add_method(
158                 $aliased_method_name,
159                 $role->get_method($method_name)
160             );
161         }
162     }
163     # we must reset the cache here since
164     # we are just aliasing methods, otherwise
165     # the modifiers go wonky.
166     $class->reset_package_cache_flag;
167 }
168
169 sub apply_override_method_modifiers {
170     my ($self, $role, $class) = @_;
171     foreach my $method_name ($role->get_method_modifier_list('override')) {
172         # it if it has one already then ...
173         if ($class->has_method($method_name)) {
174             next;
175         }
176         else {
177             # if this is not a role, then we need to
178             # find the original package of the method
179             # so that we can tell the class were to
180             # find the right super() method
181             my $method = $role->get_override_method_modifier($method_name);
182             my ($package) = Class::MOP::get_code_info($method);
183             # if it is a class, we just add it
184             $class->add_override_method_modifier($method_name, $method, $package);
185         }
186     }
187 }
188
189 sub apply_method_modifiers {
190     my ($self, $modifier_type, $role, $class) = @_;
191     my $add = "add_${modifier_type}_method_modifier";
192     my $get = "get_${modifier_type}_method_modifiers";
193     foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
194         $class->$add(
195             $method_name,
196             $_
197         ) foreach $role->$get($method_name);
198     }
199 }
200
201 1;
202
203 __END__
204
205 =pod
206
207 =head1 NAME
208
209 Moose::Meta::Role::Application::ToClass - Compose a role into a class
210
211 =head1 DESCRIPTION
212
213 =head2 METHODS
214
215 =over 4
216
217 =item B<new>
218
219 =item B<meta>
220
221 =item B<apply>
222
223 =item B<check_role_exclusions>
224
225 =item B<check_required_methods>
226
227 =item B<check_required_attributes>
228
229 =item B<apply_attributes>
230
231 =item B<apply_methods>
232
233 =item B<apply_method_modifiers>
234
235 =item B<apply_override_method_modifiers>
236
237 =back
238
239 =head1 BUGS
240
241 All complex software has bugs lurking in it, and this module is no
242 exception. If you find a bug please either email me, or add the bug
243 to cpan-RT.
244
245 =head1 AUTHOR
246
247 Stevan Little E<lt>stevan@iinteractive.comE<gt>
248
249 =head1 COPYRIGHT AND LICENSE
250
251 Copyright 2006-2009 by Infinity Interactive, Inc.
252
253 L<http://www.iinteractive.com>
254
255 This library is free software; you can redistribute it and/or modify
256 it under the same terms as Perl itself.
257
258 =cut
259