some speedups in Moose
[gitmo/Moose.git] / lib / Moose / Meta / Role.pm
1
2 package Moose::Meta::Role;
3
4 use strict;
5 use warnings;
6 use metaclass;
7
8 use Carp         'confess';
9 use Scalar::Util 'blessed', 'reftype';
10
11 our $VERSION   = '0.14';
12 our $AUTHORITY = 'cpan:STEVAN';
13
14 use Moose::Meta::Class;
15 use Moose::Meta::Role::Method;
16 use Moose::Meta::Role::Method::Required;
17
18 use base 'Class::MOP::Module';
19
20 ## ------------------------------------------------------------------
21 ## NOTE:
22 ## I normally don't do this, but I am doing
23 ## a whole bunch of meta-programmin in this
24 ## module, so it just makes sense. For a clearer
25 ## picture of what is going on in the next 
26 ## several lines of code, look at the really 
27 ## big comment at the end of this file (right
28 ## before the POD).
29 ## - SL
30 ## ------------------------------------------------------------------
31
32 my $META = __PACKAGE__->meta;
33
34 ## ------------------------------------------------------------------
35 ## attributes ...
36
37 # NOTE:
38 # since roles are lazy, we hold all the attributes
39 # of the individual role in 'statis' until which
40 # time when it is applied to a class. This means
41 # keeping a lot of things in hash maps, so we are
42 # using a little of that meta-programmin' magic
43 # here an saving lots of extra typin. And since 
44 # many of these attributes above require similar
45 # functionality to support them, so we again use
46 # the wonders of meta-programmin' to deliver a
47 # very compact solution to this normally verbose
48 # problem.
49 # - SL
50
51 foreach my $action (
52     {
53         name        => 'excluded_roles_map',
54         attr_reader => 'get_excluded_roles_map' ,
55         methods     => {
56             add       => 'add_excluded_roles',
57             get_list  => 'get_excluded_roles_list',
58             existence => 'excludes_role',
59         }
60     },
61     {
62         name        => 'required_methods',
63         attr_reader => 'get_required_methods_map',
64         methods     => {
65             add       => 'add_required_methods',
66             remove    => 'remove_required_methods',
67             get_list  => 'get_required_method_list',
68             existence => 'requires_method',
69         }
70     },  
71     {
72         name        => 'attribute_map',
73         attr_reader => 'get_attribute_map',
74         methods     => {
75             get       => 'get_attribute',
76             get_list  => 'get_attribute_list',
77             existence => 'has_attribute',
78             remove    => 'remove_attribute',
79         }
80     }
81 ) {
82
83     my $attr_reader = $action->{attr_reader};
84     my $methods     = $action->{methods};
85
86     # create the attribute
87     $META->add_attribute($action->{name} => (
88         reader  => $attr_reader,
89         default => sub { {} }
90     ));
91
92     # create some helper methods
93     $META->add_method($methods->{add} => sub {
94         my ($self, @values) = @_;
95         $self->$attr_reader->{$_} = undef foreach @values;
96     }) if exists $methods->{add};
97
98     $META->add_method($methods->{get_list} => sub {
99         my ($self) = @_;
100         keys %{$self->$attr_reader};
101     }) if exists $methods->{get_list};
102
103     $META->add_method($methods->{get} => sub {
104         my ($self, $name) = @_;
105         $self->$attr_reader->{$name}
106     }) if exists $methods->{get};
107
108     $META->add_method($methods->{existence} => sub {
109         my ($self, $name) = @_;
110         exists $self->$attr_reader->{$name} ? 1 : 0;
111     }) if exists $methods->{existence};
112
113     $META->add_method($methods->{remove} => sub {
114         my ($self, @values) = @_;
115         delete $self->$attr_reader->{$_} foreach @values;
116     }) if exists $methods->{remove};
117 }
118
119 ## some things don't always fit, so they go here ...
120
121 sub add_attribute {
122     my $self = shift;
123     my $name = shift;
124     my $attr_desc;
125     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
126         $attr_desc = $_[0];
127     }
128     else {
129         $attr_desc = { @_ };
130     }
131     $self->get_attribute_map->{$name} = $attr_desc;
132 }
133
134 # DEPRECATED 
135 # sub _clean_up_required_methods {
136 #     my $self = shift;
137 #     foreach my $method ($self->get_required_method_list) {
138 #         $self->remove_required_methods($method)
139 #             if $self->has_method($method);
140 #     }
141 # }
142
143 ## ------------------------------------------------------------------
144 ## method modifiers
145
146 # NOTE:
147 # the before/around/after method modifiers are
148 # stored by name, but there can be many methods
149 # then associated with that name. So again we have
150 # lots of similar functionality, so we can do some
151 # meta-programmin' and save some time.
152 # - SL
153
154 foreach my $modifier_type (qw[ before around after ]) {
155
156     my $attr_reader = "get_${modifier_type}_method_modifiers_map";
157     
158     # create the attribute ...
159     $META->add_attribute("${modifier_type}_method_modifiers" => (
160         reader  => $attr_reader,
161         default => sub { {} }
162     ));  
163
164     # and some helper methods ...
165     $META->add_method("get_${modifier_type}_method_modifiers" => sub {
166         my ($self, $method_name) = @_;
167         #return () unless exists $self->$attr_reader->{$method_name};
168         @{$self->$attr_reader->{$method_name}};
169     });
170
171     $META->add_method("has_${modifier_type}_method_modifiers" => sub {
172         my ($self, $method_name) = @_;
173         # NOTE:
174         # for now we assume that if it exists,..
175         # it has at least one modifier in it
176         (exists $self->$attr_reader->{$method_name}) ? 1 : 0;
177     });
178
179     $META->add_method("add_${modifier_type}_method_modifier" => sub {
180         my ($self, $method_name, $method) = @_;
181
182         $self->$attr_reader->{$method_name} = []
183             unless exists $self->$attr_reader->{$method_name};
184
185         my $modifiers = $self->$attr_reader->{$method_name};
186
187         # NOTE:
188         # check to see that we aren't adding the
189         # same code twice. We err in favor of the
190         # first on here, this may not be as expected
191         foreach my $modifier (@{$modifiers}) {
192             return if $modifier == $method;
193         }
194
195         push @{$modifiers} => $method;
196     });
197
198 }
199
200 ## ------------------------------------------------------------------
201 ## override method mofidiers
202
203 $META->add_attribute('override_method_modifiers' => (
204     reader  => 'get_override_method_modifiers_map',
205     default => sub { {} }
206 ));
207
208 # NOTE:
209 # these are a little different because there
210 # can only be one per name, whereas the other
211 # method modifiers can have multiples.
212 # - SL
213
214 sub add_override_method_modifier {
215     my ($self, $method_name, $method) = @_;
216     (!$self->has_method($method_name))
217         || confess "Cannot add an override of method '$method_name' " .
218                    "because there is a local version of '$method_name'";
219     $self->get_override_method_modifiers_map->{$method_name} = $method;
220 }
221
222 sub has_override_method_modifier {
223     my ($self, $method_name) = @_;
224     # NOTE:
225     # for now we assume that if it exists,..
226     # it has at least one modifier in it
227     (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
228 }
229
230 sub get_override_method_modifier {
231     my ($self, $method_name) = @_;
232     $self->get_override_method_modifiers_map->{$method_name};
233 }
234
235 ## general list accessor ...
236
237 sub get_method_modifier_list {
238     my ($self, $modifier_type) = @_;
239     my $accessor = "get_${modifier_type}_method_modifiers_map";
240     keys %{$self->$accessor};
241 }
242
243 ## ------------------------------------------------------------------
244 ## subroles
245
246 __PACKAGE__->meta->add_attribute('roles' => (
247     reader  => 'get_roles',
248     default => sub { [] }
249 ));
250
251 sub add_role {
252     my ($self, $role) = @_;
253     (blessed($role) && $role->isa('Moose::Meta::Role'))
254         || confess "Roles must be instances of Moose::Meta::Role";
255     push @{$self->get_roles} => $role;
256 }
257
258 sub calculate_all_roles {
259     my $self = shift;
260     my %seen;
261     grep {
262         !$seen{$_->name}++
263     } ($self, map {
264                   $_->calculate_all_roles
265               } @{ $self->get_roles });
266 }
267
268 sub does_role {
269     my ($self, $role_name) = @_;
270     (defined $role_name)
271         || confess "You must supply a role name to look for";
272     # if we are it,.. then return true
273     return 1 if $role_name eq $self->name;
274     # otherwise.. check our children
275     foreach my $role (@{$self->get_roles}) {
276         return 1 if $role->does_role($role_name);
277     }
278     return 0;
279 }
280
281 ## ------------------------------------------------------------------
282 ## methods
283
284 sub method_metaclass { 'Moose::Meta::Role::Method' }
285
286 sub get_method_map {
287     my $self = shift;
288     my $map  = {};
289
290     my $role_name        = $self->name;
291     my $method_metaclass = $self->method_metaclass;
292
293     my %all_code = $self->get_all_package_symbols('CODE');
294
295     foreach my $symbol (keys %all_code) {
296         my $code = $all_code{$symbol};
297
298         my ($pkg, $name) = Class::MOP::get_code_info($code);
299
300         if ($pkg->can('meta')
301             # NOTE:
302             # we don't know what ->meta we are calling
303             # here, so we need to be careful cause it
304             # just might blow up at us, or just complain
305             # loudly (in the case of Curses.pm) so we
306             # just be a little overly cautious here.
307             # - SL
308             && eval { no warnings; blessed($pkg->meta) }
309             && $pkg->meta->isa('Moose::Meta::Role')) {
310             my $role = $pkg->meta->name;
311             next unless $self->does_role($role);
312         }
313         else {
314             # NOTE:
315             # in 5.10 constant.pm the constants show up 
316             # as being in the right package, but in pre-5.10
317             # they show up as constant::__ANON__ so we 
318             # make an exception here to be sure that things
319             # work as expected in both.
320             # - SL
321             unless ($pkg eq 'constant' && $name eq '__ANON__') {
322                 next if ($pkg  || '') ne $role_name ||
323                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $role_name);
324             }            
325         }
326         
327         $map->{$symbol} = $method_metaclass->wrap(
328             $code,
329             package_name => $role_name,
330             name         => $name            
331         );
332     }
333
334     return $map;    
335 }
336
337 sub get_method { 
338     my ($self, $name) = @_;
339     $self->get_method_map->{$name};
340 }
341
342 sub has_method {
343     my ($self, $name) = @_;
344     exists $self->get_method_map->{$name} ? 1 : 0
345 }
346
347 sub find_method_by_name { (shift)->get_method(@_) }
348
349 sub get_method_list {
350     my $self = shift;
351     grep { !/^meta$/ } keys %{$self->get_method_map};
352 }
353
354 sub alias_method {
355     my ($self, $method_name, $method) = @_;
356     (defined $method_name && $method_name)
357         || confess "You must define a method name";
358
359     my $body = (blessed($method) ? $method->body : $method);
360     ('CODE' eq (reftype($body) || ''))
361         || confess "Your code block must be a CODE reference";
362
363     $self->add_package_symbol("&${method_name}" => $body);
364 }
365
366 ## ------------------------------------------------------------------
367 ## role construction
368 ## ------------------------------------------------------------------
369
370 sub apply {
371     my ($self, $other, @args) = @_;
372
373     (blessed($other))
374         || confess "You must pass in an blessed instance";
375         
376     if ($other->isa('Moose::Meta::Role')) {
377         require Moose::Meta::Role::Application::ToRole;
378         return Moose::Meta::Role::Application::ToRole->new(@args)->apply($self, $other);
379     }
380     elsif ($other->isa('Moose::Meta::Class')) {
381         require Moose::Meta::Role::Application::ToClass;
382         return Moose::Meta::Role::Application::ToClass->new(@args)->apply($self, $other);
383     }  
384     else {
385         require Moose::Meta::Role::Application::ToInstance;
386         return Moose::Meta::Role::Application::ToInstance->new(@args)->apply($self, $other);        
387     }  
388 }
389
390 sub combine {
391     my ($class, @role_specs) = @_;
392     
393     require Moose::Meta::Role::Application::RoleSummation;
394     require Moose::Meta::Role::Composite;  
395     
396     my (@roles, %role_params);
397     while (@role_specs) {
398         my ($role, $params) = @{ splice @role_specs, 0, 1 };
399         push @roles => $role->meta;
400         next unless defined $params;
401         $role_params{$role} = $params; 
402     }
403     
404     my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
405     Moose::Meta::Role::Application::RoleSummation->new(
406         role_params => \%role_params
407     )->apply($c);
408     
409     return $c;
410 }
411
412 #####################################################################
413 ## NOTE:
414 ## This is Moose::Meta::Role as defined by Moose (plus the use of 
415 ## MooseX::AttributeHelpers module). It is here as a reference to 
416 ## make it easier to see what is happening above with all the meta
417 ## programming. - SL
418 #####################################################################
419 #
420 # has 'roles' => (
421 #     metaclass => 'Collection::Array',
422 #     reader    => 'get_roles',
423 #     isa       => 'ArrayRef[Moose::Meta::Roles]',
424 #     default   => sub { [] },
425 #     provides  => {
426 #         'push' => 'add_role',
427 #     }
428 # );
429
430 # has 'excluded_roles_map' => (
431 #     metaclass => 'Collection::Hash',
432 #     reader    => 'get_excluded_roles_map',
433 #     isa       => 'HashRef[Str]',
434 #     provides  => {
435 #         # Not exactly set, cause it sets multiple
436 #         'set'    => 'add_excluded_roles',
437 #         'keys'   => 'get_excluded_roles_list',
438 #         'exists' => 'excludes_role',
439 #     }
440 # );
441
442 # has 'attribute_map' => (
443 #     metaclass => 'Collection::Hash',
444 #     reader    => 'get_attribute_map',
445 #     isa       => 'HashRef[Str]',    
446 #     provides => {
447 #         # 'set'  => 'add_attribute' # has some special crap in it
448 #         'get'    => 'get_attribute',
449 #         'keys'   => 'get_attribute_list',
450 #         'exists' => 'has_attribute',
451 #         # Not exactly delete, cause it sets multiple
452 #         'delete' => 'remove_attribute',    
453 #     }
454 # );
455
456 # has 'required_methods' => (
457 #     metaclass => 'Collection::Hash',
458 #     reader    => 'get_required_methods_map',
459 #     isa       => 'HashRef[Str]',
460 #     provides  => {    
461 #         # not exactly set, or delete since it works for multiple 
462 #         'set'    => 'add_required_methods',
463 #         'delete' => 'remove_required_methods',
464 #         'keys'   => 'get_required_method_list',
465 #         'exists' => 'requires_method',    
466 #     }
467 # );
468
469 # # the before, around and after modifiers are 
470 # # HASH keyed by method-name, with ARRAY of 
471 # # CODE refs to apply in that order
472
473 # has 'before_method_modifiers' => (
474 #     metaclass => 'Collection::Hash',    
475 #     reader    => 'get_before_method_modifiers_map',
476 #     isa       => 'HashRef[ArrayRef[CodeRef]]',
477 #     provides  => {
478 #         'keys'   => 'get_before_method_modifiers',
479 #         'exists' => 'has_before_method_modifiers',   
480 #         # This actually makes sure there is an 
481 #         # ARRAY at the given key, and pushed onto
482 #         # it. It also checks for duplicates as well
483 #         # 'add'  => 'add_before_method_modifier'     
484 #     }    
485 # );
486
487 # has 'after_method_modifiers' => (
488 #     metaclass => 'Collection::Hash',    
489 #     reader    =>'get_after_method_modifiers_map',
490 #     isa       => 'HashRef[ArrayRef[CodeRef]]',
491 #     provides  => {
492 #         'keys'   => 'get_after_method_modifiers',
493 #         'exists' => 'has_after_method_modifiers', 
494 #         # This actually makes sure there is an 
495 #         # ARRAY at the given key, and pushed onto
496 #         # it. It also checks for duplicates as well          
497 #         # 'add'  => 'add_after_method_modifier'     
498 #     }    
499 # );
500 #     
501 # has 'around_method_modifiers' => (
502 #     metaclass => 'Collection::Hash',    
503 #     reader    =>'get_around_method_modifiers_map',
504 #     isa       => 'HashRef[ArrayRef[CodeRef]]',
505 #     provides  => {
506 #         'keys'   => 'get_around_method_modifiers',
507 #         'exists' => 'has_around_method_modifiers',   
508 #         # This actually makes sure there is an 
509 #         # ARRAY at the given key, and pushed onto
510 #         # it. It also checks for duplicates as well        
511 #         # 'add'  => 'add_around_method_modifier'     
512 #     }    
513 # );
514
515 # # override is similar to the other modifiers
516 # # except that it is not an ARRAY of code refs
517 # # but instead just a single name->code mapping
518 #     
519 # has 'override_method_modifiers' => (
520 #     metaclass => 'Collection::Hash',    
521 #     reader    =>'get_override_method_modifiers_map',
522 #     isa       => 'HashRef[CodeRef]',   
523 #     provides  => {
524 #         'keys'   => 'get_override_method_modifier',
525 #         'exists' => 'has_override_method_modifier',   
526 #         'add'    => 'add_override_method_modifier', # checks for local method ..     
527 #     }
528 # );
529 #     
530 #####################################################################
531
532
533 1;
534
535 __END__
536
537 =pod
538
539 =head1 NAME
540
541 Moose::Meta::Role - The Moose Role metaclass
542
543 =head1 DESCRIPTION
544
545 Please see L<Moose::Role> for more information about roles.
546 For the most part, this has no user-serviceable parts inside
547 this module. It's API is still subject to some change (although
548 probably not that much really).
549
550 =head1 METHODS
551
552 =over 4
553
554 =item B<meta>
555
556 =item B<new>
557
558 =item B<apply>
559
560 =item B<combine>
561
562 =back
563
564 =over 4
565
566 =item B<name>
567
568 =item B<version>
569
570 =item B<role_meta>
571
572 =back
573
574 =over 4
575
576 =item B<get_roles>
577
578 =item B<add_role>
579
580 =item B<does_role>
581
582 =back
583
584 =over 4
585
586 =item B<add_excluded_roles>
587
588 =item B<excludes_role>
589
590 =item B<get_excluded_roles_list>
591
592 =item B<get_excluded_roles_map>
593
594 =item B<calculate_all_roles>
595
596 =back
597
598 =over 4
599
600 =item B<method_metaclass>
601
602 =item B<find_method_by_name>
603
604 =item B<get_method>
605
606 =item B<has_method>
607
608 =item B<alias_method>
609
610 =item B<get_method_list>
611
612 =item B<get_method_map>
613
614 =item B<update_package_cache_flag>
615
616 =item B<reset_package_cache_flag>
617
618 =back
619
620 =over 4
621
622 =item B<add_attribute>
623
624 =item B<has_attribute>
625
626 =item B<get_attribute>
627
628 =item B<get_attribute_list>
629
630 =item B<get_attribute_map>
631
632 =item B<remove_attribute>
633
634 =back
635
636 =over 4
637
638 =item B<add_required_methods>
639
640 =item B<remove_required_methods>
641
642 =item B<get_required_method_list>
643
644 =item B<get_required_methods_map>
645
646 =item B<requires_method>
647
648 =back
649
650 =over 4
651
652 =item B<add_after_method_modifier>
653
654 =item B<add_around_method_modifier>
655
656 =item B<add_before_method_modifier>
657
658 =item B<add_override_method_modifier>
659
660 =over 4
661
662 =back
663
664 =item B<has_after_method_modifiers>
665
666 =item B<has_around_method_modifiers>
667
668 =item B<has_before_method_modifiers>
669
670 =item B<has_override_method_modifier>
671
672 =over 4
673
674 =back
675
676 =item B<get_after_method_modifiers>
677
678 =item B<get_around_method_modifiers>
679
680 =item B<get_before_method_modifiers>
681
682 =item B<get_method_modifier_list>
683
684 =over 4
685
686 =back
687
688 =item B<get_override_method_modifier>
689
690 =item B<get_after_method_modifiers_map>
691
692 =item B<get_around_method_modifiers_map>
693
694 =item B<get_before_method_modifiers_map>
695
696 =item B<get_override_method_modifiers_map>
697
698 =back
699
700 =head1 BUGS
701
702 All complex software has bugs lurking in it, and this module is no
703 exception. If you find a bug please either email me, or add the bug
704 to cpan-RT.
705
706 =head1 AUTHOR
707
708 Stevan Little E<lt>stevan@iinteractive.comE<gt>
709
710 =head1 COPYRIGHT AND LICENSE
711
712 Copyright 2006-2008 by Infinity Interactive, Inc.
713
714 L<http://www.iinteractive.com>
715
716 This library is free software; you can redistribute it and/or modify
717 it under the same terms as Perl itself.
718
719 =cut