Move method modifier manipulators into XS
[gitmo/Mouse.git] / lib / Mouse / Meta / Role.pm
1 package Mouse::Meta::Role;
2 use Mouse::Util qw(:meta not_supported); # enables strict and warnings
3
4 use Mouse::Meta::Module;
5 our @ISA = qw(Mouse::Meta::Module);
6
7 sub method_metaclass;
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, $consumer, $args) = @_;
69
70     if($args->{_to} eq 'role'){
71         $consumer->add_required_methods($role->get_required_method_list);
72     }
73     else{ # to class or instance
74         my $consumer_class_name = $consumer->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 $consumer_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                 Mouse::Util::quoted_english_list(@missing),
89                 $consumer_class_name);
90         }
91     }
92
93     return;
94 }
95
96 sub _apply_methods{
97     my($role, $consumer, $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(!$consumer->has_method($method_name)){
109                 # The third argument $role is used in Role::Composite
110                 $consumer->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 = $consumer->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                 $consumer->add_method($dstname => $code, $role);
124             }
125         }
126     }
127
128     return;
129 }
130
131 sub _apply_attributes{
132     my($role, $consumer, $args) = @_;
133
134     for my $attr_name ($role->get_attribute_list) {
135         next if $consumer->has_attribute($attr_name);
136
137         $consumer->add_attribute($attr_name => $role->get_attribute($attr_name));
138     }
139     return;
140 }
141
142 sub _apply_modifiers{
143     my($role, $consumer, $args) = @_;
144
145     if(my $modifiers = $role->{override_method_modifiers}){
146         foreach my $method_name (keys %{$modifiers}){
147             $consumer->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 $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
160                 $consumer->$add_modifier($method_name => $code);
161             }
162         }
163     }
164     return;
165 }
166
167 sub _append_roles{
168     my($role, $consumer, $args) = @_;
169
170     my $roles = ($args->{_to} eq 'role') ? $consumer->get_roles : $consumer->roles;
171
172     foreach my $r($role, @{$role->get_roles}){
173         if(!$consumer->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 $consumer = shift;
184
185     my %args = (@_ == 1) ? %{ $_[0] } : @_;
186
187     my $instance;
188
189     if(Mouse::Util::is_a_metaclass($consumer)){  # Application::ToClass
190         $args{_to} = 'class';
191     }
192     elsif(Mouse::Util::is_a_metarole($consumer)){ # Application::ToRole
193         $args{_to} = 'role';
194     }
195     else{                                       # Appplication::ToInstance
196         $args{_to} = 'instance';
197         $instance  = $consumer;
198
199         $consumer = (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($consumer, \%args);
228     $self->_apply_attributes($consumer, \%args);
229     $self->_apply_methods($consumer, \%args);
230     $self->_apply_modifiers($consumer, \%args);
231     $self->_append_roles($consumer, \%args);
232
233
234     if(defined $instance){ # Application::ToInstance
235         # rebless instance
236         bless $instance, $consumer->name;
237         $consumer->_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 sub add_around_method_modifier;
260 sub add_after_method_modifier;
261
262 sub get_before_method_modifiers;
263 sub get_around_method_modifiers;
264 sub get_after_method_modifiers;
265
266 sub add_override_method_modifier{
267     my($self, $method_name, $method) = @_;
268
269     if($self->has_method($method_name)){
270         # This error happens in the override keyword or during role composition,
271         # so I added a message, "A local method of ...", only for compatibility (gfx)
272         $self->throw_error("Cannot add an override of method '$method_name' "
273                    . "because there is a local version of '$method_name'"
274                    . "(A local method of the same name as been found)");
275     }
276
277     $self->{override_method_modifiers}->{$method_name} = $method;
278 }
279
280 sub get_override_method_modifier {
281     my ($self, $method_name) = @_;
282     return $self->{override_method_modifiers}->{$method_name};
283 }
284
285 sub does_role {
286     my ($self, $role_name) = @_;
287
288     (defined $role_name)
289         || $self->throw_error("You must supply a role name to look for");
290
291     # if we are it,.. then return true
292     return 1 if $role_name eq $self->name;
293     # otherwise.. check our children
294     for my $role (@{ $self->get_roles }) {
295         return 1 if $role->does_role($role_name);
296     }
297     return 0;
298 }
299
300 1;
301 __END__
302
303 =head1 NAME
304
305 Mouse::Meta::Role - The Mouse Role metaclass
306
307 =head1 VERSION
308
309 This document describes Mouse version 0.50_03
310
311 =head1 SEE ALSO
312
313 L<Moose::Meta::Role>
314
315 =cut