Update MANIFEST
[gitmo/Moose.git] / lib / Moose / Meta / Role / Application / ToClass.pm
CommitLineData
fb1e11d5 1package Moose::Meta::Role::Application::ToClass;
2
3use strict;
4use warnings;
5use metaclass;
6
7use Carp 'confess';
8use Scalar::Util 'blessed';
9
10use Data::Dumper;
11
330dbb07 12our $VERSION = '0.55';
fb1e11d5 13our $AUTHORITY = 'cpan:STEVAN';
14
15use base 'Moose::Meta::Role::Application';
16
1c9db35c 17sub apply {
c4538447 18 my ($self, $role, $class) = @_;
1c9db35c 19 $self->SUPER::apply($role, $class);
c4538447 20 $class->add_role($role);
1c9db35c 21}
22
23sub check_role_exclusions {
24 my ($self, $role, $class) = @_;
25 if ($class->excludes_role($role->name)) {
26 confess "Conflict detected: " . $class->name . " excludes role '" . $role->name . "'";
27 }
28 foreach my $excluded_role_name ($role->get_excluded_roles_list) {
29 if ($class->does_role($excluded_role_name)) {
30 confess "The class " . $class->name . " does the excluded role '$excluded_role_name'";
31 }
32 }
33}
34
35sub check_required_methods {
36 my ($self, $role, $class) = @_;
37 # NOTE:
38 # we might need to move this down below the
39 # the attributes so that we can require any
40 # attribute accessors. However I am thinking
41 # that maybe those are somehow exempt from
42 # the require methods stuff.
43 foreach my $required_method_name ($role->get_required_method_list) {
44
3e19778d 45 if (!$class->find_method_by_name($required_method_name)) {
46
47 next if $self->is_aliased_method($required_method_name);
48
1c9db35c 49 confess "'" . $role->name . "' requires the method '$required_method_name' " .
50 "to be implemented by '" . $class->name . "'";
51 }
52 else {
53 # NOTE:
54 # we need to make sure that the method is
55 # not a method modifier, because those do
56 # not satisfy the requirements ...
57 my $method = $class->find_method_by_name($required_method_name);
58
59 # check if it is a generated accessor ...
60 (!$method->isa('Class::MOP::Method::Accessor'))
61 || confess "'" . $role->name . "' requires the method '$required_method_name' " .
62 "to be implemented by '" . $class->name . "', the method is only an attribute accessor";
63
64 # NOTE:
65 # All other tests here have been removed, they were tests
66 # for overriden methods and before/after/around modifiers.
67 # But we realized that for classes any overriden or modified
68 # methods would be backed by a real method of that name
69 # (and therefore meet the requirement). And for roles, the
70 # overriden and modified methods are "in statis" and so would
71 # not show up in this test anyway (and as a side-effect they
72 # would not fufill the requirement, which is exactly what we
73 # want them to do anyway).
74 # - SL
75 }
76 }
77}
78
709c321c 79sub check_required_attributes {
80
81}
82
1c9db35c 83sub apply_attributes {
84 my ($self, $role, $class) = @_;
85 foreach my $attribute_name ($role->get_attribute_list) {
86 # it if it has one already
87 if ($class->has_attribute($attribute_name) &&
88 # make sure we haven't seen this one already too
89 $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
90 next;
91 }
92 else {
d7d8a8c7 93 $class->add_attribute(
94 $attribute_name,
95 $role->get_attribute($attribute_name)
96 );
1c9db35c 97 }
98 }
99}
100
101sub apply_methods {
102 my ($self, $role, $class) = @_;
103 foreach my $method_name ($role->get_method_list) {
c4538447 104
105 next if $self->is_method_excluded($method_name);
106
1c9db35c 107 # it if it has one already
108 if ($class->has_method($method_name) &&
109 # and if they are not the same thing ...
110 $class->get_method($method_name)->body != $role->get_method($method_name)->body) {
111 next;
112 }
620db045 113 else {
1c9db35c 114 # add it, although it could be overriden
115 $class->alias_method(
116 $method_name,
43a41ede 117 $role->get_method($method_name)
118 );
1c9db35c 119 }
43a41ede 120
121 if ($self->is_method_aliased($method_name)) {
122 my $aliased_method_name = $self->get_method_aliases->{$method_name};
123 # it if it has one already
124 if ($class->has_method($aliased_method_name) &&
125 # and if they are not the same thing ...
126 $class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
127 confess "Cannot create a method alias if a local method of the same name exists";
128 }
129 $class->alias_method(
130 $aliased_method_name,
131 $role->get_method($method_name)
132 );
133 }
1c9db35c 134 }
135 # we must reset the cache here since
136 # we are just aliasing methods, otherwise
137 # the modifiers go wonky.
138 $class->reset_package_cache_flag;
139}
140
141sub apply_override_method_modifiers {
142 my ($self, $role, $class) = @_;
143 foreach my $method_name ($role->get_method_modifier_list('override')) {
144 # it if it has one already then ...
145 if ($class->has_method($method_name)) {
146 next;
147 }
148 else {
149 # if this is not a role, then we need to
150 # find the original package of the method
151 # so that we can tell the class were to
152 # find the right super() method
153 my $method = $role->get_override_method_modifier($method_name);
154 my ($package) = Class::MOP::get_code_info($method);
155 # if it is a class, we just add it
156 $class->add_override_method_modifier($method_name, $method, $package);
157 }
158 }
159}
160
161sub apply_method_modifiers {
162 my ($self, $modifier_type, $role, $class) = @_;
163 my $add = "add_${modifier_type}_method_modifier";
164 my $get = "get_${modifier_type}_method_modifiers";
165 foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
166 $class->$add(
167 $method_name,
168 $_
169 ) foreach $role->$get($method_name);
170 }
171}
172
fb1e11d5 1731;
174
175__END__
176
177=pod
178
179=head1 NAME
180
ab76842e 181Moose::Meta::Role::Application::ToClass - Compose a role into a class
fb1e11d5 182
183=head1 DESCRIPTION
184
185=head2 METHODS
186
187=over 4
188
189=item B<new>
190
191=item B<meta>
192
1c9db35c 193=item B<apply>
194
709c321c 195=item B<check_role_exclusions>
196
1c9db35c 197=item B<check_required_methods>
198
709c321c 199=item B<check_required_attributes>
1c9db35c 200
201=item B<apply_attributes>
202
203=item B<apply_methods>
204
205=item B<apply_method_modifiers>
206
1c9db35c 207=item B<apply_override_method_modifiers>
208
fb1e11d5 209=back
210
211=head1 BUGS
212
213All complex software has bugs lurking in it, and this module is no
214exception. If you find a bug please either email me, or add the bug
215to cpan-RT.
216
217=head1 AUTHOR
218
219Stevan Little E<lt>stevan@iinteractive.comE<gt>
220
221=head1 COPYRIGHT AND LICENSE
222
778db3ac 223Copyright 2006-2008 by Infinity Interactive, Inc.
fb1e11d5 224
225L<http://www.iinteractive.com>
226
227This library is free software; you can redistribute it and/or modify
228it under the same terms as Perl itself.
229
230=cut
231