Mouse:::Meta::Method::Constructor is used only in pure perl mode
[gitmo/Mouse.git] / lib / Mouse / Meta / Role.pm
1 package Mouse::Meta::Role;
2 use Mouse::Util qw(:meta not_supported english_list); # enables strict and warnings
3
4 use Mouse::Meta::Module;
5 our @ISA = qw(Mouse::Meta::Module);
6
7 sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
8
9 sub _construct_meta {
10     my $class = shift;
11
12     my %args  = @_;
13
14     $args{methods}          = {};
15     $args{attributes}       = {};
16     $args{required_methods} = [];
17     $args{roles}            = [];
18
19     my $self = bless \%args, ref($class) || $class;
20     if($class ne __PACKAGE__){
21         $self->meta->_initialize_object($self, \%args);
22     }
23
24     return $self;
25 }
26
27 sub create_anon_role{
28     my $self = shift;
29     return $self->create(undef, @_);
30 }
31
32 sub is_anon_role;
33
34 sub get_roles;
35
36 sub calculate_all_roles {
37     my $self = shift;
38     my %seen;
39     return grep { !$seen{ $_->name }++ }
40            ($self, map  { $_->calculate_all_roles } @{ $self->get_roles });
41 }
42
43 sub get_required_method_list{
44     return @{ $_[0]->{required_methods} };
45 }
46
47 sub add_required_methods {
48     my($self, @methods) = @_;
49     my %required = map{ $_ => 1 } @{$self->{required_methods}};
50     push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
51     return;
52 }
53
54 sub requires_method {
55     my($self, $name) = @_;
56     return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
57 }
58
59 sub add_attribute {
60     my $self = shift;
61     my $name = shift;
62
63     $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
64     return;
65 }
66
67 sub _check_required_methods{
68     my($role, $applicant, $args) = @_;
69
70     if($args->{_to} eq 'role'){
71         $applicant->add_required_methods($role->get_required_method_list);
72     }
73     else{ # to class or instance
74         my $applicant_class_name = $applicant->name;
75
76         my @missing;
77         foreach my $method_name(@{$role->{required_methods}}){
78             next if exists $args->{aliased_methods}{$method_name};
79             next if exists $role->{methods}{$method_name};
80             next if $applicant_class_name->can($method_name);
81
82             push @missing, $method_name;
83         }
84         if(@missing){
85             $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
86                 $role->name,
87                 (@missing == 1 ? '' : 's'), # method or methods
88                 english_list(map{ sprintf q{'%s'}, $_ } @missing),
89                 $applicant_class_name);
90         }
91     }
92
93     return;
94 }
95
96 sub _apply_methods{
97     my($role, $applicant, $args) = @_;
98
99     my $alias    = $args->{-alias};
100     my $excludes = $args->{-excludes};
101
102     foreach my $method_name($role->get_method_list){
103         next if $method_name eq 'meta';
104
105         my $code = $role->get_method_body($method_name);
106
107         if(!exists $excludes->{$method_name}){
108             if(!$applicant->has_method($method_name)){
109                 # The third argument $role is used in Role::Composite
110                 $applicant->add_method($method_name => $code, $role);
111             }
112         }
113
114         if(exists $alias->{$method_name}){
115             my $dstname = $alias->{$method_name};
116
117             my $dstcode = $applicant->get_method_body($dstname);
118
119             if(defined($dstcode) && $dstcode != $code){
120                 $role->throw_error("Cannot create a method alias if a local method of the same name exists");
121             }
122             else{
123                 $applicant->add_method($dstname => $code, $role);
124             }
125         }
126     }
127
128     return;
129 }
130
131 sub _apply_attributes{
132     my($role, $applicant, $args) = @_;
133
134     for my $attr_name ($role->get_attribute_list) {
135         next if $applicant->has_attribute($attr_name);
136
137         $applicant->add_attribute($attr_name => $role->get_attribute($attr_name));
138     }
139     return;
140 }
141
142 sub _apply_modifiers{
143     my($role, $applicant, $args) = @_;
144
145     if(my $modifiers = $role->{override_method_modifiers}){
146         foreach my $method_name (keys %{$modifiers}){
147             $applicant->add_override_method_modifier($method_name => $modifiers->{$method_name});
148         }
149     }
150
151     for my $modifier_type (qw/before around after/) {
152         my $modifiers = $role->{"${modifier_type}_method_modifiers"}
153             or next;
154
155         my $add_modifier = "add_${modifier_type}_method_modifier";
156
157         foreach my $method_name (keys %{$modifiers}){
158             foreach my $code(@{ $modifiers->{$method_name} }){
159                 next if $applicant->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
160                 $applicant->$add_modifier($method_name => $code);
161             }
162         }
163     }
164     return;
165 }
166
167 sub _append_roles{
168     my($role, $applicant, $args) = @_;
169
170     my $roles = ($args->{_to} eq 'role') ? $applicant->get_roles : $applicant->roles;
171
172     foreach my $r($role, @{$role->get_roles}){
173         if(!$applicant->does_role($r->name)){
174             push @{$roles}, $r;
175         }
176     }
177     return;
178 }
179
180 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
181 sub apply {
182     my $self      = shift;
183     my $applicant = shift;
184
185     my %args = (@_ == 1) ? %{ $_[0] } : @_;
186
187     my $instance;
188
189     if(Mouse::Util::is_a_metaclass($applicant)){  # Application::ToClass
190         $args{_to} = 'class';
191     }
192     elsif(Mouse::Util::is_a_metarole($applicant)){ # Application::ToRole
193         $args{_to} = 'role';
194     }
195     else{                                       # Appplication::ToInstance
196         $args{_to} = 'instance';
197         $instance = $applicant;
198
199         $applicant = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')->create_anon_class(
200             superclasses => [ref $instance],
201             cache        => 1,
202         );
203     }
204
205     if($args{alias} && !exists $args{-alias}){
206         $args{-alias} = $args{alias};
207     }
208     if($args{excludes} && !exists $args{-excludes}){
209         $args{-excludes} = $args{excludes};
210     }
211
212     $args{aliased_methods} = {};
213     if(my $alias = $args{-alias}){
214         @{$args{aliased_methods}}{ values %{$alias} } = ();
215     }
216
217     if(my $excludes = $args{-excludes}){
218         $args{-excludes} = {}; # replace with a hash ref
219         if(ref $excludes){
220             %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
221         }
222         else{
223             $args{-excludes}{$excludes} = undef;
224         }
225     }
226
227     $self->_check_required_methods($applicant, \%args);
228     $self->_apply_attributes($applicant, \%args);
229     $self->_apply_methods($applicant, \%args);
230     $self->_apply_modifiers($applicant, \%args);
231     $self->_append_roles($applicant, \%args);
232
233
234     if(defined $instance){ # Application::ToInstance
235         # rebless instance
236         bless $instance, $applicant->name;
237         $applicant->_initialize_object($instance, $instance);
238     }
239
240     return;
241 }
242
243
244 sub combine {
245     my($role_class, @role_specs) = @_;
246
247     require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace
248
249     my $composite = Mouse::Meta::Role::Composite->create_anon_role();
250
251     foreach my $role_spec (@role_specs) {
252         my($role_name, $args) = @{$role_spec};
253         $role_name->meta->apply($composite, %{$args});
254     }
255     return $composite;
256 }
257
258 sub add_before_method_modifier {
259     my ($self, $method_name, $method) = @_;
260
261     push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
262     return;
263 }
264 sub add_around_method_modifier {
265     my ($self, $method_name, $method) = @_;
266
267     push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
268     return;
269 }
270 sub add_after_method_modifier {
271     my ($self, $method_name, $method) = @_;
272
273     push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
274     return;
275 }
276
277 sub get_before_method_modifiers {
278     my ($self, $method_name) = @_;
279     return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
280 }
281 sub get_around_method_modifiers {
282     my ($self, $method_name) = @_;
283     return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
284 }
285 sub get_after_method_modifiers {
286     my ($self, $method_name) = @_;
287     return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
288 }
289
290 sub add_override_method_modifier{
291     my($self, $method_name, $method) = @_;
292
293     if($self->has_method($method_name)){
294         # This error happens in the override keyword or during role composition,
295         # so I added a message, "A local method of ...", only for compatibility (gfx)
296         $self->throw_error("Cannot add an override of method '$method_name' "
297                    . "because there is a local version of '$method_name'"
298                    . "(A local method of the same name as been found)");
299     }
300
301     $self->{override_method_modifiers}->{$method_name} = $method;
302 }
303
304 sub get_override_method_modifier {
305     my ($self, $method_name) = @_;
306     return $self->{override_method_modifiers}->{$method_name};
307 }
308
309 sub does_role {
310     my ($self, $role_name) = @_;
311
312     (defined $role_name)
313         || $self->throw_error("You must supply a role name to look for");
314
315     # if we are it,.. then return true
316     return 1 if $role_name eq $self->name;
317     # otherwise.. check our children
318     for my $role (@{ $self->get_roles }) {
319         return 1 if $role->does_role($role_name);
320     }
321     return 0;
322 }
323
324 1;
325 __END__
326
327 =head1 NAME
328
329 Mouse::Meta::Role - The Mouse Role metaclass
330
331 =head1 VERSION
332
333 This document describes Mouse version 0.40_05
334
335 =head1 SEE ALSO
336
337 L<Moose::Meta::Role>
338
339 =cut